From 49294a83ee67eef83180721c578f69855bf96cad Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Fri, 24 Nov 2017 06:21:01 +0100 Subject: Create the simul.ads package (for a namespace). --- src/vhdl/simulate/annotations.adb | 1345 -------- src/vhdl/simulate/annotations.ads | 120 - src/vhdl/simulate/debugger-ams.adb | 85 - src/vhdl/simulate/debugger-ams.ads | 28 - src/vhdl/simulate/debugger.adb | 2284 ------------- src/vhdl/simulate/debugger.ads | 91 - src/vhdl/simulate/elaboration-ams.adb | 199 -- src/vhdl/simulate/elaboration-ams.ads | 163 - src/vhdl/simulate/elaboration.adb | 2979 ----------------- src/vhdl/simulate/elaboration.ads | 187 -- src/vhdl/simulate/execution.adb | 4831 --------------------------- src/vhdl/simulate/execution.ads | 192 -- src/vhdl/simulate/file_operation.adb | 384 --- src/vhdl/simulate/file_operation.ads | 89 - src/vhdl/simulate/grt_interface.adb | 44 - src/vhdl/simulate/grt_interface.ads | 27 - src/vhdl/simulate/iir_values.adb | 1127 ------- src/vhdl/simulate/iir_values.ads | 481 --- src/vhdl/simulate/simul-annotations.adb | 1345 ++++++++ src/vhdl/simulate/simul-annotations.ads | 120 + src/vhdl/simulate/simul-debugger-ams.adb | 85 + src/vhdl/simulate/simul-debugger-ams.ads | 28 + src/vhdl/simulate/simul-debugger.adb | 2283 +++++++++++++ src/vhdl/simulate/simul-debugger.ads | 91 + src/vhdl/simulate/simul-elaboration-ams.adb | 199 ++ src/vhdl/simulate/simul-elaboration-ams.ads | 163 + src/vhdl/simulate/simul-elaboration.adb | 2979 +++++++++++++++++ src/vhdl/simulate/simul-elaboration.ads | 187 ++ src/vhdl/simulate/simul-environments.adb | 1127 +++++++ src/vhdl/simulate/simul-environments.ads | 481 +++ src/vhdl/simulate/simul-execution.adb | 4831 +++++++++++++++++++++++++++ src/vhdl/simulate/simul-execution.ads | 192 ++ src/vhdl/simulate/simul-file_operation.adb | 384 +++ src/vhdl/simulate/simul-file_operation.ads | 89 + src/vhdl/simulate/simul-grt_interface.adb | 44 + src/vhdl/simulate/simul-grt_interface.ads | 27 + src/vhdl/simulate/simul-simulation-main.adb | 1145 +++++++ src/vhdl/simulate/simul-simulation-main.ads | 4 + src/vhdl/simulate/simul-simulation.adb | 716 ++++ src/vhdl/simulate/simul-simulation.ads | 136 + src/vhdl/simulate/simul.ads | 21 + src/vhdl/simulate/simulation-main.adb | 1145 ------- src/vhdl/simulate/simulation-main.ads | 4 - src/vhdl/simulate/simulation.adb | 716 ---- src/vhdl/simulate/simulation.ads | 136 - 45 files changed, 16677 insertions(+), 16657 deletions(-) delete mode 100644 src/vhdl/simulate/annotations.adb delete mode 100644 src/vhdl/simulate/annotations.ads delete mode 100644 src/vhdl/simulate/debugger-ams.adb delete mode 100644 src/vhdl/simulate/debugger-ams.ads delete mode 100644 src/vhdl/simulate/debugger.adb delete mode 100644 src/vhdl/simulate/debugger.ads delete mode 100644 src/vhdl/simulate/elaboration-ams.adb delete mode 100644 src/vhdl/simulate/elaboration-ams.ads delete mode 100644 src/vhdl/simulate/elaboration.adb delete mode 100644 src/vhdl/simulate/elaboration.ads delete mode 100644 src/vhdl/simulate/execution.adb delete mode 100644 src/vhdl/simulate/execution.ads delete mode 100644 src/vhdl/simulate/file_operation.adb delete mode 100644 src/vhdl/simulate/file_operation.ads delete mode 100644 src/vhdl/simulate/grt_interface.adb delete mode 100644 src/vhdl/simulate/grt_interface.ads delete mode 100644 src/vhdl/simulate/iir_values.adb delete mode 100644 src/vhdl/simulate/iir_values.ads create mode 100644 src/vhdl/simulate/simul-annotations.adb create mode 100644 src/vhdl/simulate/simul-annotations.ads create mode 100644 src/vhdl/simulate/simul-debugger-ams.adb create mode 100644 src/vhdl/simulate/simul-debugger-ams.ads create mode 100644 src/vhdl/simulate/simul-debugger.adb create mode 100644 src/vhdl/simulate/simul-debugger.ads create mode 100644 src/vhdl/simulate/simul-elaboration-ams.adb create mode 100644 src/vhdl/simulate/simul-elaboration-ams.ads create mode 100644 src/vhdl/simulate/simul-elaboration.adb create mode 100644 src/vhdl/simulate/simul-elaboration.ads create mode 100644 src/vhdl/simulate/simul-environments.adb create mode 100644 src/vhdl/simulate/simul-environments.ads create mode 100644 src/vhdl/simulate/simul-execution.adb create mode 100644 src/vhdl/simulate/simul-execution.ads create mode 100644 src/vhdl/simulate/simul-file_operation.adb create mode 100644 src/vhdl/simulate/simul-file_operation.ads create mode 100644 src/vhdl/simulate/simul-grt_interface.adb create mode 100644 src/vhdl/simulate/simul-grt_interface.ads create mode 100644 src/vhdl/simulate/simul-simulation-main.adb create mode 100644 src/vhdl/simulate/simul-simulation-main.ads create mode 100644 src/vhdl/simulate/simul-simulation.adb create mode 100644 src/vhdl/simulate/simul-simulation.ads create mode 100644 src/vhdl/simulate/simul.ads delete mode 100644 src/vhdl/simulate/simulation-main.adb delete mode 100644 src/vhdl/simulate/simulation-main.ads delete mode 100644 src/vhdl/simulate/simulation.adb delete mode 100644 src/vhdl/simulate/simulation.ads (limited to 'src/vhdl') diff --git a/src/vhdl/simulate/annotations.adb b/src/vhdl/simulate/annotations.adb deleted file mode 100644 index c898aa01d..000000000 --- a/src/vhdl/simulate/annotations.adb +++ /dev/null @@ -1,1345 +0,0 @@ --- Annotations for 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 Tables; -with Ada.Text_IO; -with Std_Package; -with Errorout; use Errorout; -with Iirs_Utils; use Iirs_Utils; - -package body Annotations is - -- Current scope. Used when an object is created to indicate which scope - -- it belongs to. - Current_Scope: Scope_Type := (Kind => Scope_Kind_None); - - procedure Annotate_Declaration_List - (Block_Info: Sim_Info_Acc; Decl_Chain: Iir); - procedure Annotate_Sequential_Statement_Chain - (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir); - procedure Annotate_Concurrent_Statements_List - (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir); - procedure Annotate_Block_Configuration - (Block : Iir_Block_Configuration); - procedure Annotate_Subprogram_Interfaces_Type - (Block_Info : Sim_Info_Acc; Subprg: Iir); - procedure Annotate_Subprogram_Specification - (Block_Info : Sim_Info_Acc; Subprg: Iir); - procedure Annotate_Interface_List - (Block_Info: Sim_Info_Acc; Decl_Chain: Iir; With_Types : Boolean); - - procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir); - - -- Annotate type definition DEF only if it is anonymous. - procedure Annotate_Anonymous_Type_Definition - (Block_Info: Sim_Info_Acc; Def: Iir); - - procedure Increment_Current_Scope is - begin - case Current_Scope.Kind is - when Scope_Kind_None - | Scope_Kind_Package - | Scope_Kind_Pkg_Inst => - -- For a subprogram in a package - Current_Scope := (Scope_Kind_Frame, Scope_Depth_Type'First); - when Scope_Kind_Frame => - Current_Scope := (Scope_Kind_Frame, Current_Scope.Depth + 1); - when Scope_Kind_Component => - raise Internal_Error; - end case; - end Increment_Current_Scope; - - -- Add an annotation to object OBJ. - procedure Create_Object_Info (Block_Info : Sim_Info_Acc; - Obj : Iir; - Obj_Kind : Sim_Info_Kind := Kind_Object) - is - Info : Sim_Info_Acc; - begin - Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1; - case Obj_Kind is - when Kind_Object => - Info := new Sim_Info_Type'(Kind => Kind_Object, - Obj_Scope => Current_Scope, - Slot => Block_Info.Nbr_Objects); - when Kind_File => - Info := new Sim_Info_Type'(Kind => Kind_File, - Obj_Scope => Current_Scope, - Slot => Block_Info.Nbr_Objects); - when Kind_Signal => - Info := new Sim_Info_Type'(Kind => Kind_Signal, - Obj_Scope => Current_Scope, - Slot => Block_Info.Nbr_Objects); - -- Reserve one more slot for value. - Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1; - when Kind_Terminal => - Info := new Sim_Info_Type'(Kind => Kind_Terminal, - Obj_Scope => Current_Scope, - Slot => Block_Info.Nbr_Objects); - when Kind_Quantity => - Info := new Sim_Info_Type'(Kind => Kind_Quantity, - Obj_Scope => Current_Scope, - Slot => Block_Info.Nbr_Objects); - when Kind_PSL => - Info := new Sim_Info_Type'(Kind => Kind_PSL, - Obj_Scope => Current_Scope, - Slot => Block_Info.Nbr_Objects); - when Kind_Environment => - Info := new Sim_Info_Type'(Kind => Kind_Environment, - Env_Slot => Block_Info.Nbr_Objects, - Frame_Scope => Current_Scope, - Nbr_Objects => 0); - when Kind_Block - | Kind_Process - | Kind_Frame - | Kind_Scalar_Type - | Kind_File_Type - | Kind_Extra => - raise Internal_Error; - end case; - Set_Info (Obj, Info); - end Create_Object_Info; - - -- Add an annotation to SIGNAL. - procedure Create_Signal_Info (Block_Info: Sim_Info_Acc; Signal: Iir) is - begin - Create_Object_Info (Block_Info, Signal, Kind_Signal); - end Create_Signal_Info; - - procedure Add_Terminal_Info (Block_Info: Sim_Info_Acc; Terminal : Iir) is - begin - Create_Object_Info (Block_Info, Terminal, Kind_Terminal); - end Add_Terminal_Info; - - procedure Add_Quantity_Info (Block_Info: Sim_Info_Acc; Quantity : Iir) is - begin - Create_Object_Info (Block_Info, Quantity, Kind_Quantity); - end Add_Quantity_Info; - - -- If EXPR has not a literal value, create one. - -- This is necessary for subtype bounds. - procedure Annotate_Range_Expression - (Block_Info: Sim_Info_Acc; Expr: Iir_Range_Expression) - is - begin - if Get_Info (Expr) /= null then - return; - end if; --- if Expr = null or else Get_Info (Expr) /= null then --- return; --- end if; - Create_Object_Info (Block_Info, Expr); - end Annotate_Range_Expression; - - -- Annotate type definition DEF only if it is anonymous. - procedure Annotate_Anonymous_Type_Definition - (Block_Info: Sim_Info_Acc; Def: Iir) - is - begin - if Is_Anonymous_Type_Definition (Def) then - Annotate_Type_Definition (Block_Info, Def); - end if; - end Annotate_Anonymous_Type_Definition; - - function Get_File_Signature_Length (Def : Iir) return Natural is - begin - case Get_Kind (Def) is - when Iir_Kinds_Scalar_Type_And_Subtype_Definition => - return 1; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - return 2 - + Get_File_Signature_Length (Get_Element_Subtype (Def)); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Def)); - El : Iir; - Res : Natural; - begin - Res := 2; - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Res := Res + Get_File_Signature_Length (Get_Type (El)); - end loop; - return Res; - end; - when others => - Error_Kind ("get_file_signature_length", Def); - end case; - end Get_File_Signature_Length; - - procedure Get_File_Signature (Def : Iir; - Res : in out String; - Off : in out Natural) - is - Scalar_Map : constant array (Iir_Value_Scalars) of Character := "beEIF"; - begin - case Get_Kind (Def) is - when Iir_Kinds_Scalar_Type_And_Subtype_Definition => - Res (Off) := - Scalar_Map (Get_Info (Get_Base_Type (Def)).Scalar_Mode); - Off := Off + 1; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - Res (Off) := '['; - Off := Off + 1; - Get_File_Signature (Get_Element_Subtype (Def), Res, Off); - Res (Off) := ']'; - Off := Off + 1; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Def)); - El : Iir; - begin - Res (Off) := '<'; - Off := Off + 1; - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Get_File_Signature (Get_Type (El), Res, Off); - end loop; - Res (Off) := '>'; - Off := Off + 1; - end; - when others => - Error_Kind ("get_file_signature", Def); - end case; - end Get_File_Signature; - - procedure Annotate_Protected_Type_Declaration (Block_Info : Sim_Info_Acc; - Prot: Iir) - is - Prev_Scope : constant Scope_Type := Current_Scope; - Decl : Iir; - Prot_Info: Sim_Info_Acc; - begin - -- First the interfaces type (they are elaborated in their context). - Decl := Get_Declaration_Chain (Prot); - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Annotate_Subprogram_Interfaces_Type (Block_Info, Decl); - when Iir_Kind_Use_Clause => - null; - when others => - -- FIXME: attribute - Error_Kind ("annotate_protected_type_declaration", Decl); - end case; - Decl := Get_Chain (Decl); - end loop; - - -- Then the interfaces object. Increment the scope to reserve a scope - -- for the protected object. - Increment_Current_Scope; - - Prot_Info := - new Sim_Info_Type'(Kind => Kind_Frame, - Frame_Scope => Current_Scope, - Nbr_Objects => 0); - Set_Info (Prot, Prot_Info); - - Decl := Get_Declaration_Chain (Prot); - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Annotate_Subprogram_Specification (Block_Info, Decl); - when Iir_Kind_Use_Clause => - null; - when others => - Error_Kind ("annotate_protected_type_declaration", Decl); - end case; - Decl := Get_Chain (Decl); - end loop; - - Current_Scope := Prev_Scope; - end Annotate_Protected_Type_Declaration; - - procedure Annotate_Protected_Type_Body (Block_Info : Sim_Info_Acc; - Prot: Iir) - is - pragma Unreferenced (Block_Info); - Prot_Info: Sim_Info_Acc; - Prev_Scope : constant Scope_Type := Current_Scope; - begin - Prot_Info := Get_Info (Get_Protected_Type_Declaration (Prot)); - Set_Info (Prot, Prot_Info); - - Current_Scope := Prot_Info.Frame_Scope; - - Annotate_Declaration_List (Prot_Info, Get_Declaration_Chain (Prot)); - - Current_Scope := Prev_Scope; - end Annotate_Protected_Type_Body; - - procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir) - is - El: Iir; - begin - -- Happen only with universal types. - if Def = Null_Iir then - return; - end if; - - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition => - declare - Mode : Iir_Value_Kind; - begin - if Def = Std_Package.Boolean_Type_Definition - or else Def = Std_Package.Bit_Type_Definition - then - Mode := Iir_Value_B1; - elsif (Get_Nbr_Elements (Get_Enumeration_Literal_List (Def)) - <= 256) - then - Mode := Iir_Value_E8; - else - Mode := Iir_Value_E32; - end if; - Set_Info (Def, new Sim_Info_Type'(Kind => Kind_Scalar_Type, - Scalar_Mode => Mode)); - Annotate_Range_Expression - (Block_Info, Get_Range_Constraint (Def)); - end; - - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - El := Get_Range_Constraint (Def); - if El /= Null_Iir then - case Get_Kind (El) is - when Iir_Kind_Range_Expression => - Annotate_Range_Expression (Block_Info, El); - -- A physical subtype may be defined by an integer range. - if Get_Kind (Def) = Iir_Kind_Physical_Subtype_Definition - then - null; - -- FIXME - -- Convert_Int_To_Phys (Get_Info (El).Value); - end if; - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - null; - when others => - Error_Kind ("annotate_type_definition (rc)", El); - end case; - end if; - Annotate_Anonymous_Type_Definition - (Block_Info, Get_Base_Type (Def)); - - when Iir_Kind_Integer_Type_Definition => - Set_Info (Def, - new Sim_Info_Type'(Kind => Kind_Scalar_Type, - Scalar_Mode => Iir_Value_I64)); - - when Iir_Kind_Floating_Type_Definition => - Set_Info (Def, - new Sim_Info_Type'(Kind => Kind_Scalar_Type, - Scalar_Mode => Iir_Value_F64)); - - when Iir_Kind_Physical_Type_Definition => - Set_Info (Def, - new Sim_Info_Type'(Kind => Kind_Scalar_Type, - Scalar_Mode => Iir_Value_I64)); - - when Iir_Kind_Array_Type_Definition => - El := Get_Element_Subtype (Def); - Annotate_Anonymous_Type_Definition (Block_Info, El); - - when Iir_Kind_Array_Subtype_Definition => - declare - List : constant Iir_Flist := Get_Index_Subtype_List (Def); - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Index_Type (List, I); - Annotate_Anonymous_Type_Definition (Block_Info, El); - end loop; - end; - - when Iir_Kind_Record_Type_Definition => - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Def); - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Annotate_Anonymous_Type_Definition - (Block_Info, Get_Type (El)); - end loop; - end; - - when Iir_Kind_Record_Subtype_Definition => - null; - - when Iir_Kind_Access_Type_Definition => - Annotate_Anonymous_Type_Definition - (Block_Info, Get_Designated_Type (Def)); - - when Iir_Kind_Access_Subtype_Definition => - null; - - when Iir_Kind_File_Type_Definition => - declare - Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); - Res : String_Acc; - begin - if Get_Text_File_Flag (Def) - or else - (Get_Kind (Type_Name) - in Iir_Kinds_Scalar_Type_And_Subtype_Definition) - then - Res := null; - else - declare - Sig : String - (1 .. Get_File_Signature_Length (Type_Name) + 2); - Off : Natural := Sig'First; - begin - Get_File_Signature (Type_Name, Sig, Off); - Sig (Off + 0) := '.'; - Sig (Off + 1) := ASCII.NUL; - Res := new String'(Sig); - end; - end if; - Set_Info (Def, - new Sim_Info_Type'(Kind => Kind_File_Type, - File_Signature => Res)); - end; - - when Iir_Kind_Protected_Type_Declaration => - Annotate_Protected_Type_Declaration (Block_Info, Def); - - when Iir_Kind_Incomplete_Type_Definition => - null; - - when others => - Error_Kind ("annotate_type_definition", Def); - end case; - end Annotate_Type_Definition; - - procedure Annotate_Interface_List_Subtype - (Block_Info: Sim_Info_Acc; Decl_Chain: Iir) - is - El: Iir; - begin - El := Decl_Chain; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El)); - when others => - Error_Kind ("annotate_interface_list", El); - end case; - El := Get_Chain (El); - end loop; - end Annotate_Interface_List_Subtype; - - procedure Annotate_Interface_Package_Declaration - (Block_Info: Sim_Info_Acc; Inter : Iir) - is - Prev_Scope : constant Scope_Type := Current_Scope; - Package_Info : Sim_Info_Acc; - begin - Create_Object_Info (Block_Info, Inter, Kind_Environment); - Package_Info := Get_Info (Inter); - - Current_Scope := (Kind => Scope_Kind_Pkg_Inst, - Pkg_Param => 0); --- Pkg_Parent => Package_Info); - - Annotate_Interface_List - (Package_Info, Get_Generic_Chain (Inter), True); - Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Inter)); - - Current_Scope := Prev_Scope; - end Annotate_Interface_Package_Declaration; - - procedure Annotate_Interface_List - (Block_Info: Sim_Info_Acc; Decl_Chain: Iir; With_Types : Boolean) - is - Decl : Iir; - begin - Decl := Decl_Chain; - while Decl /= Null_Iir loop - if With_Types - and then Get_Kind (Decl) in Iir_Kinds_Interface_Object_Declaration - then - Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); - end if; - case Get_Kind (Decl) is - when Iir_Kind_Interface_Signal_Declaration => - Create_Signal_Info (Block_Info, Decl); - when Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - Create_Object_Info (Block_Info, Decl); - when Iir_Kind_Interface_Package_Declaration => - Annotate_Interface_Package_Declaration (Block_Info, Decl); - when others => - Error_Kind ("annotate_interface_list", Decl); - end case; - Decl := Get_Chain (Decl); - end loop; - end Annotate_Interface_List; - - procedure Annotate_Subprogram_Interfaces_Type - (Block_Info : Sim_Info_Acc; Subprg: Iir) - is - Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg); - begin - -- See LRM93 12.3.1.1 (Subprogram declarations and bodies). The type - -- of the interfaces are elaborated in the outer context. - Annotate_Interface_List_Subtype (Block_Info, Interfaces); - - if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then - -- FIXME: can this create a new annotation ? - Annotate_Anonymous_Type_Definition - (Block_Info, Get_Return_Type (Subprg)); - end if; - end Annotate_Subprogram_Interfaces_Type; - - procedure Annotate_Subprogram_Specification - (Block_Info : Sim_Info_Acc; Subprg: Iir) - is - pragma Unreferenced (Block_Info); - Subprg_Info: Sim_Info_Acc; - Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg); - Prev_Scope : constant Scope_Type := Current_Scope; - begin - Increment_Current_Scope; - - Subprg_Info := - new Sim_Info_Type'(Kind => Kind_Frame, - Frame_Scope => Current_Scope, - Nbr_Objects => 0); - Set_Info (Subprg, Subprg_Info); - - Annotate_Interface_List (Subprg_Info, Interfaces, False); - - Current_Scope := Prev_Scope; - end Annotate_Subprogram_Specification; - - procedure Annotate_Subprogram_Body - (Block_Info : Sim_Info_Acc; Subprg: Iir) - is - pragma Unreferenced (Block_Info); - Spec : constant Iir := Get_Subprogram_Specification (Subprg); - Subprg_Info : constant Sim_Info_Acc := Get_Info (Spec); - Prev_Scope : constant Scope_Type := Current_Scope; - begin - -- Do not annotate body of foreign subprograms. - if Get_Foreign_Flag (Spec) then - return; - end if; - - Set_Info (Subprg, Subprg_Info); - - Current_Scope := Subprg_Info.Frame_Scope; - - Annotate_Declaration_List - (Subprg_Info, Get_Declaration_Chain (Subprg)); - - Annotate_Sequential_Statement_Chain - (Subprg_Info, Get_Sequential_Statement_Chain (Subprg)); - - Current_Scope := Prev_Scope; - end Annotate_Subprogram_Body; - - procedure Annotate_Component_Declaration (Comp: Iir_Component_Declaration) - is - Prev_Scope : constant Scope_Type := Current_Scope; - Info : Sim_Info_Acc; - begin - Current_Scope := (Kind => Scope_Kind_Component); - - Info := new Sim_Info_Type'(Kind => Kind_Block, - Frame_Scope => Current_Scope, - Inst_Slot => Invalid_Instance_Slot, - Nbr_Objects => 0, - Nbr_Instances => 1); -- For the instance. - Set_Info (Comp, Info); - - Annotate_Interface_List (Info, Get_Generic_Chain (Comp), True); - Annotate_Interface_List (Info, Get_Port_Chain (Comp), True); - - Current_Scope := Prev_Scope; - end Annotate_Component_Declaration; - - procedure Annotate_Declaration (Block_Info: Sim_Info_Acc; Decl: Iir) is - begin - case Get_Kind (Decl) is - when Iir_Kind_Signal_Attribute_Declaration => - declare - Attr : Iir; - begin - Attr := Get_Signal_Attribute_Chain (Decl); - while Is_Valid (Attr) loop - Annotate_Anonymous_Type_Definition - (Block_Info, Get_Type (Attr)); - Create_Signal_Info (Block_Info, Attr); - Attr := Get_Attr_Chain (Attr); - end loop; - end; - - when Iir_Kind_Signal_Declaration => - Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); - Create_Signal_Info (Block_Info, Decl); - - when Iir_Kind_Variable_Declaration - | Iir_Kind_Iterator_Declaration => - Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); - Create_Object_Info (Block_Info, Decl); - - when Iir_Kind_Constant_Declaration => - if Get_Deferred_Declaration (Decl) = Null_Iir - or else Get_Deferred_Declaration_Flag (Decl) - then - -- Create the slot only if the constant is not a full constant - -- declaration. - Annotate_Anonymous_Type_Definition - (Block_Info, Get_Type (Decl)); - Create_Object_Info (Block_Info, Decl); - end if; - - when Iir_Kind_File_Declaration => - Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); - Create_Object_Info (Block_Info, Decl, Kind_File); - - when Iir_Kind_Terminal_Declaration => - Add_Terminal_Info (Block_Info, Decl); - when Iir_Kinds_Branch_Quantity_Declaration => - Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); - Add_Quantity_Info (Block_Info, Decl); - - when Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration => - Annotate_Type_Definition (Block_Info, Get_Type_Definition (Decl)); - when Iir_Kind_Subtype_Declaration => - Annotate_Type_Definition (Block_Info, Get_Type (Decl)); - - when Iir_Kind_Protected_Type_Body => - Annotate_Protected_Type_Body (Block_Info, Decl); - - when Iir_Kind_Component_Declaration => - Annotate_Component_Declaration (Decl); - - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Get_Implicit_Definition (Decl) in Iir_Predefined_Explicit - and then not Is_Second_Subprogram_Specification (Decl) - then - Annotate_Subprogram_Interfaces_Type (Block_Info, Decl); - Annotate_Subprogram_Specification (Block_Info, Decl); - end if; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - Annotate_Subprogram_Body (Block_Info, Decl); - - when Iir_Kind_Object_Alias_Declaration => - Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); - Create_Object_Info (Block_Info, Decl); - - when Iir_Kind_Non_Object_Alias_Declaration => - null; - - when Iir_Kind_Attribute_Declaration => - null; - when Iir_Kind_Attribute_Specification => - declare - Value : Iir_Attribute_Value; - begin - Value := Get_Attribute_Value_Spec_Chain (Decl); - while Value /= Null_Iir loop - Annotate_Anonymous_Type_Definition - (Block_Info, Get_Type (Value)); - Create_Object_Info (Block_Info, Value); - Value := Get_Spec_Chain (Value); - end loop; - end; - when Iir_Kind_Disconnection_Specification => - null; - - when Iir_Kind_Group_Template_Declaration => - null; - when Iir_Kind_Group_Declaration => - null; - when Iir_Kind_Use_Clause => - null; - - when Iir_Kind_Configuration_Specification => - null; - --- when Iir_Kind_Implicit_Signal_Declaration => --- declare --- Nsig : Iir; --- begin --- Nsig := Decl; --- loop --- Nsig := Get_Implicit_Signal_Chain (Nsig); --- exit when Nsig = Null_Iir; --- Add_Signal_Info (Block_Info, Nsig); --- end loop; --- end; - - when Iir_Kind_Nature_Declaration => - null; - - when others => - Error_Kind ("annotate_declaration", Decl); - end case; - end Annotate_Declaration; - - procedure Annotate_Declaration_List - (Block_Info: Sim_Info_Acc; Decl_Chain: Iir) - is - El: Iir; - begin - El := Decl_Chain; - while El /= Null_Iir loop - Annotate_Declaration (Block_Info, El); - El := Get_Chain (El); - end loop; - end Annotate_Declaration_List; - - procedure Annotate_Sequential_Statement_Chain - (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir) - is - El: Iir; - Max_Nbr_Objects : Object_Slot_Type; - Current_Nbr_Objects : Object_Slot_Type; - - procedure Save_Nbr_Objects is - begin - -- Objects used by loop statements can be reused later by - -- other (ie following) loop statements. - -- Furthermore, this allow to correctly check elaboration - -- order. - Max_Nbr_Objects := Object_Slot_Type'Max - (Block_Info.Nbr_Objects, Max_Nbr_Objects); - Block_Info.Nbr_Objects := Current_Nbr_Objects; - end Save_Nbr_Objects; - begin - Current_Nbr_Objects := Block_Info.Nbr_Objects; - Max_Nbr_Objects := Current_Nbr_Objects; - - El := Stmt_Chain; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Null_Statement => - null; - when Iir_Kind_Assertion_Statement - | Iir_Kind_Report_Statement => - null; - when Iir_Kind_Return_Statement => - null; - when Iir_Kind_Simple_Signal_Assignment_Statement - | Iir_Kind_Variable_Assignment_Statement => - null; - when Iir_Kind_Procedure_Call_Statement => - null; - when Iir_Kind_Exit_Statement - | Iir_Kind_Next_Statement => - null; - when Iir_Kind_Wait_Statement => - null; - - when Iir_Kind_If_Statement => - declare - Clause: Iir := El; - begin - loop - Annotate_Sequential_Statement_Chain - (Block_Info, Get_Sequential_Statement_Chain (Clause)); - Clause := Get_Else_Clause (Clause); - exit when Clause = Null_Iir; - Save_Nbr_Objects; - end loop; - end; - - when Iir_Kind_Case_Statement => - declare - Assoc: Iir; - begin - Assoc := Get_Case_Statement_Alternative_Chain (El); - loop - Annotate_Sequential_Statement_Chain - (Block_Info, Get_Associated_Chain (Assoc)); - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - Save_Nbr_Objects; - end loop; - end; - - when Iir_Kind_For_Loop_Statement => - Annotate_Declaration - (Block_Info, Get_Parameter_Specification (El)); - Annotate_Sequential_Statement_Chain - (Block_Info, Get_Sequential_Statement_Chain (El)); - - when Iir_Kind_While_Loop_Statement => - Annotate_Sequential_Statement_Chain - (Block_Info, Get_Sequential_Statement_Chain (El)); - - when others => - Error_Kind ("annotate_sequential_statement_chain", El); - end case; - - Save_Nbr_Objects; - - El := Get_Chain (El); - end loop; - Block_Info.Nbr_Objects := Max_Nbr_Objects; - end Annotate_Sequential_Statement_Chain; - - procedure Annotate_Block_Statement - (Block_Info : Sim_Info_Acc; Block : Iir_Block_Statement) - is - Info : Sim_Info_Acc; - Header : Iir_Block_Header; - Guard : Iir; - Prev_Scope : constant Scope_Type := Current_Scope; - begin - Increment_Current_Scope; - - Info := new Sim_Info_Type'(Kind => Kind_Block, - Inst_Slot => Block_Info.Nbr_Instances, - Frame_Scope => Current_Scope, - Nbr_Objects => 0, - Nbr_Instances => 0); - Set_Info (Block, Info); - - Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; - - Guard := Get_Guard_Decl (Block); - if Guard /= Null_Iir then - Create_Signal_Info (Info, Guard); - end if; - Header := Get_Block_Header (Block); - if Header /= Null_Iir then - Annotate_Interface_List (Info, Get_Generic_Chain (Header), True); - Annotate_Interface_List (Info, Get_Port_Chain (Header), True); - end if; - Annotate_Declaration_List (Info, Get_Declaration_Chain (Block)); - Annotate_Concurrent_Statements_List - (Info, Get_Concurrent_Statement_Chain (Block)); - - Current_Scope := Prev_Scope; - end Annotate_Block_Statement; - - procedure Annotate_Generate_Statement_Body - (Block_Info : Sim_Info_Acc; Bod : Iir; It : Iir) - is - Info : Sim_Info_Acc; - Prev_Scope : constant Scope_Type := Current_Scope; - begin - Increment_Current_Scope; - - Info := new Sim_Info_Type'(Kind => Kind_Block, - Inst_Slot => Block_Info.Nbr_Instances, - Frame_Scope => Current_Scope, - Nbr_Objects => 0, - Nbr_Instances => 0); - Set_Info (Bod, Info); - - Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; - - if It /= Null_Iir then - Annotate_Declaration (Info, It); - end if; - Annotate_Declaration_List (Info, Get_Declaration_Chain (Bod)); - Annotate_Concurrent_Statements_List - (Info, Get_Concurrent_Statement_Chain (Bod)); - - Current_Scope := Prev_Scope; - end Annotate_Generate_Statement_Body; - - procedure Annotate_If_Generate_Statement - (Block_Info : Sim_Info_Acc; Stmt : Iir) - is - Clause : Iir; - begin - Clause := Stmt; - while Clause /= Null_Iir loop - Annotate_Generate_Statement_Body - (Block_Info, Get_Generate_Statement_Body (Clause), Null_Iir); - Clause := Get_Generate_Else_Clause (Clause); - end loop; - end Annotate_If_Generate_Statement; - - procedure Annotate_For_Generate_Statement - (Block_Info : Sim_Info_Acc; Stmt : Iir) is - begin - Annotate_Generate_Statement_Body - (Block_Info, - Get_Generate_Statement_Body (Stmt), - Get_Parameter_Specification (Stmt)); - end Annotate_For_Generate_Statement; - - procedure Annotate_Component_Instantiation_Statement - (Block_Info : Sim_Info_Acc; Stmt : Iir) - is - Info: Sim_Info_Acc; - Prev_Scope : constant Scope_Type := Current_Scope; - begin - Increment_Current_Scope; - - -- Add a slot just to put the instance. - Info := new Sim_Info_Type'(Kind => Kind_Block, - Inst_Slot => Block_Info.Nbr_Instances, - Frame_Scope => Current_Scope, - Nbr_Objects => 0, - Nbr_Instances => 1); - Set_Info (Stmt, Info); - Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; - - Current_Scope := Prev_Scope; - end Annotate_Component_Instantiation_Statement; - - procedure Annotate_Process_Statement (Block_Info : Sim_Info_Acc; Stmt : Iir) - is - pragma Unreferenced (Block_Info); - Prev_Scope : constant Scope_Type := Current_Scope; - Info : Sim_Info_Acc; - begin - Increment_Current_Scope; - - Info := new Sim_Info_Type'(Kind => Kind_Process, - Frame_Scope => Current_Scope, - Nbr_Objects => 0); - Set_Info (Stmt, Info); - - Annotate_Declaration_List - (Info, Get_Declaration_Chain (Stmt)); - Annotate_Sequential_Statement_Chain - (Info, Get_Sequential_Statement_Chain (Stmt)); - - Current_Scope := Prev_Scope; - end Annotate_Process_Statement; - - procedure Annotate_Concurrent_Statements_List - (Block_Info: Sim_Info_Acc; Stmt_Chain : Iir) - is - El : Iir; - begin - El := Stmt_Chain; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement => - Annotate_Process_Statement (Block_Info, El); - - when Iir_Kind_Component_Instantiation_Statement => - Annotate_Component_Instantiation_Statement (Block_Info, El); - - when Iir_Kind_Block_Statement => - Annotate_Block_Statement (Block_Info, El); - - when Iir_Kind_If_Generate_Statement => - Annotate_If_Generate_Statement (Block_Info, El); - when Iir_Kind_For_Generate_Statement => - Annotate_For_Generate_Statement (Block_Info, El); - - when Iir_Kind_Psl_Default_Clock - | Iir_Kind_Psl_Declaration => - null; - - when Iir_Kind_Psl_Cover_Statement - | Iir_Kind_Psl_Assert_Statement => - Create_Object_Info (Block_Info, El, Kind_PSL); - - when Iir_Kind_Simple_Simultaneous_Statement => - null; - - when Iir_Kind_Concurrent_Simple_Signal_Assignment => - -- In case concurrent signal assignemnts were not - -- canonicalized. - null; - - when others => - Error_Kind ("annotate_concurrent_statements_list", El); - end case; - El := Get_Chain (El); - end loop; - end Annotate_Concurrent_Statements_List; - - procedure Annotate_Entity (Decl: Iir_Entity_Declaration) - is - Entity_Info: Sim_Info_Acc; - begin - pragma Assert (Current_Scope.Kind = Scope_Kind_None); - Increment_Current_Scope; - - Entity_Info := - new Sim_Info_Type'(Kind => Kind_Block, - Inst_Slot => Invalid_Instance_Slot, - Frame_Scope => Current_Scope, - Nbr_Objects => 0, - Nbr_Instances => 0); - Set_Info (Decl, Entity_Info); - - -- generic list. - Annotate_Interface_List (Entity_Info, Get_Generic_Chain (Decl), True); - - -- Port list. - Annotate_Interface_List (Entity_Info, Get_Port_Chain (Decl), True); - - -- declarations - Annotate_Declaration_List (Entity_Info, Get_Declaration_Chain (Decl)); - - -- processes. - Annotate_Concurrent_Statements_List - (Entity_Info, Get_Concurrent_Statement_Chain (Decl)); - - Current_Scope := (Kind => Scope_Kind_None); - end Annotate_Entity; - - procedure Annotate_Architecture (Decl: Iir_Architecture_Body) - is - Entity_Info : constant Sim_Info_Acc := Get_Info (Get_Entity (Decl)); - Arch_Info: Sim_Info_Acc; - begin - pragma Assert (Current_Scope.Kind = Scope_Kind_None); - Current_Scope := Entity_Info.Frame_Scope; - - -- No blocks nor instantiation in entities. - pragma Assert (Entity_Info.Nbr_Instances = 0); - - Arch_Info := new Sim_Info_Type' - (Kind => Kind_Block, - Inst_Slot => 0, -- Slot for a component - Frame_Scope => Current_Scope, - Nbr_Objects => Entity_Info.Nbr_Objects, - Nbr_Instances => Entity_Info.Nbr_Instances); -- Should be 0. - Set_Info (Decl, Arch_Info); - - -- FIXME: annotate the default configuration for the arch ? - - -- declarations - Annotate_Declaration_List (Arch_Info, Get_Declaration_Chain (Decl)); - - -- processes. - Annotate_Concurrent_Statements_List - (Arch_Info, Get_Concurrent_Statement_Chain (Decl)); - - Current_Scope := (Kind => Scope_Kind_None); - end Annotate_Architecture; - - procedure Annotate_Package (Decl: Iir_Package_Declaration) - is - Prev_Scope : constant Scope_Type := Current_Scope; - Package_Info: Sim_Info_Acc; - Header : Iir; - begin - pragma Assert (Current_Scope.Kind = Scope_Kind_None); - - if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration - or else not Is_Uninstantiated_Package (Decl) - then - Nbr_Packages := Nbr_Packages + 1; - Current_Scope := (Scope_Kind_Package, Nbr_Packages); - else - Increment_Current_Scope; - end if; - - Package_Info := new Sim_Info_Type' - (Kind => Kind_Block, - Inst_Slot => Invalid_Instance_Slot, - Frame_Scope => Current_Scope, - Nbr_Objects => 0, - Nbr_Instances => 0); - - Set_Info (Decl, Package_Info); - - if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then - Annotate_Interface_List - (Package_Info, Get_Generic_Chain (Decl), True); - else - Header := Get_Package_Header (Decl); - if Header /= Null_Iir then - Annotate_Interface_List - (Package_Info, Get_Generic_Chain (Header), True); - end if; - end if; - -- declarations - Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl)); - - if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then - declare - Uninst : constant Iir := Get_Uninstantiated_Package_Decl (Decl); - Uninst_Info : constant Sim_Info_Acc := Get_Info (Uninst); - begin - -- There is not corresponding body for an instantiation, so - -- also add objects for the shared body. - Package_Info.Nbr_Objects := Uninst_Info.Nbr_Objects; - end; - end if; - - Current_Scope := Prev_Scope; - end Annotate_Package; - - procedure Annotate_Package_Body (Decl: Iir) - is - Package_Info: Sim_Info_Acc; - begin - pragma Assert (Current_Scope.Kind = Scope_Kind_None); - - -- Set info field of package body declaration. - Package_Info := Get_Info (Get_Package (Decl)); - Set_Info (Decl, Package_Info); - - Current_Scope := Package_Info.Frame_Scope; - - -- declarations - Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl)); - - Current_Scope := (Kind => Scope_Kind_None); - end Annotate_Package_Body; - - procedure Annotate_Component_Configuration - (Conf : Iir_Component_Configuration) - is - Block : constant Iir := Get_Block_Configuration (Conf); - begin - Annotate_Block_Configuration (Block); - end Annotate_Component_Configuration; - - procedure Annotate_Block_Configuration (Block : Iir_Block_Configuration) - is - El : Iir; - begin - if Block = Null_Iir then - return; - end if; - - -- Declaration are use_clause only. - El := Get_Configuration_Item_Chain (Block); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Block_Configuration => - Annotate_Block_Configuration (El); - when Iir_Kind_Component_Configuration => - Annotate_Component_Configuration (El); - when others => - Error_Kind ("annotate_block_configuration", El); - end case; - El := Get_Chain (El); - end loop; - end Annotate_Block_Configuration; - - procedure Annotate_Configuration_Declaration - (Decl : Iir_Configuration_Declaration) - is - Config_Info: Sim_Info_Acc; - begin - pragma Assert (Current_Scope.Kind = Scope_Kind_None); - - Nbr_Packages := Nbr_Packages + 1; - Current_Scope := (Scope_Kind_Package, Nbr_Packages); - - Config_Info := new Sim_Info_Type' - (Kind => Kind_Block, - Inst_Slot => Invalid_Instance_Slot, - Frame_Scope => Current_Scope, - Nbr_Objects => 0, - Nbr_Instances => 0); - - Set_Info (Decl, Config_Info); - - Annotate_Declaration_List (Config_Info, Get_Declaration_Chain (Decl)); - Annotate_Block_Configuration (Get_Block_Configuration (Decl)); - - Current_Scope := (Kind => Scope_Kind_None); - end Annotate_Configuration_Declaration; - - package Info_Node is new Tables - (Table_Component_Type => Sim_Info_Acc, - Table_Index_Type => Iir, - Table_Low_Bound => 2, - Table_Initial => 1024); - - procedure Annotate_Expand_Table - is - El: Iir; - begin - Info_Node.Increment_Last; - El := Info_Node.Last; - Info_Node.Set_Last (Get_Last_Node); - for I in El .. Info_Node.Last loop - Info_Node.Table (I) := null; - end loop; - end Annotate_Expand_Table; - - -- Decorate the tree in order to be usable with the internal simulator. - procedure Annotate (Unit : Iir_Design_Unit) - is - El : constant Iir := Get_Library_Unit (Unit); - begin - -- Expand info table. - Annotate_Expand_Table; - - case Get_Kind (El) is - when Iir_Kind_Entity_Declaration => - Annotate_Entity (El); - when Iir_Kind_Architecture_Body => - Annotate_Architecture (El); - when Iir_Kind_Package_Declaration => - Annotate_Package (El); - declare - use Std_Package; - begin - if El = Standard_Package then - -- These types are not in std.standard! - Annotate_Type_Definition - (Get_Info (El), Convertible_Integer_Type_Definition); - Annotate_Type_Definition - (Get_Info (El), Convertible_Real_Type_Definition); - end if; - end; - when Iir_Kind_Package_Body => - Annotate_Package_Body (El); - when Iir_Kind_Configuration_Declaration => - Annotate_Configuration_Declaration (El); - when Iir_Kind_Package_Instantiation_Declaration => - Annotate_Package (El); - when Iir_Kind_Context_Declaration => - null; - when others => - Error_Kind ("annotate2", El); - end case; - end Annotate; - - function Image (Scope : Scope_Type) return String is - begin - case Scope.Kind is - when Scope_Kind_None => - return "none"; - when Scope_Kind_Component => - return "component"; - when Scope_Kind_Frame => - return "frame" & Scope_Depth_Type'Image (Scope.Depth); - when Scope_Kind_Package => - return "package" & Pkg_Index_Type'Image (Scope.Pkg_Index); - when Scope_Kind_Pkg_Inst => - return "pkg inst" & Parameter_Slot_Type'Image (Scope.Pkg_Param); - end case; - end Image; - - -- Disp annotations for an iir node. - procedure Disp_Vhdl_Info (Node: Iir) is - use Ada.Text_IO; - Info : constant Sim_Info_Acc := Get_Info (Node); - Indent : Count; - begin - if Info = null then - return; - end if; - - Indent := Col; - case Info.Kind is - when Kind_Block => - Put_Line - ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects)); - - when Kind_Frame | Kind_Process => - Put_Line ("-- scope:" & Image (Info.Frame_Scope)); - Set_Col (Indent); - Put_Line - ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects)); - - when Kind_Object | Kind_Signal | Kind_File - | Kind_Terminal - | Kind_Quantity - | Kind_Environment - | Kind_PSL => - Put_Line ("-- slot:" & Object_Slot_Type'Image (Info.Slot) - & ", scope:" & Image (Info.Obj_Scope)); - when Kind_Scalar_Type - | Kind_File_Type - | Kind_Extra => - null; - end case; - end Disp_Vhdl_Info; - - procedure Disp_Info (Info : Sim_Info_Acc) - is - use Ada.Text_IO; - Indent: Count; - begin - Indent := Col + 2; - Set_Col (Indent); - if Info = null then - Put_Line ("*null*"); - return; - end if; - case Info.Kind is - when Kind_Block | Kind_Frame | Kind_Process => - Put_Line ("scope:" & Image (Info.Frame_Scope)); - Set_Col (Indent); - Put_Line ("inst_slot:" - & Instance_Slot_Type'Image (Info.Inst_Slot)); - Set_Col (Indent); - Put_Line ("nbr objects:" - & Object_Slot_Type'Image (Info.Nbr_Objects)); - Set_Col (Indent); - Put_Line ("nbr instance:" - & Instance_Slot_Type'Image (Info.Nbr_Instances)); - when Kind_Object | Kind_Signal | Kind_File - | Kind_Terminal | Kind_Quantity | Kind_Environment - | Kind_PSL => - Put_Line ("slot:" & Object_Slot_Type'Image (Info.Slot) - & ", scope:" & Image (Info.Obj_Scope)); - when Kind_Extra => - Put_Line ("extra:" & Extra_Slot_Type'Image (Info.Extra_Slot)); - when Kind_Scalar_Type => - Put_Line ("scalar type: " - & Iir_Value_Kind'Image (Info.Scalar_Mode)); - when Kind_File_Type => - Put ("file type: "); - if Info.File_Signature = null then - Put ("(no sig)"); - else - Put (Info.File_Signature.all); - end if; - New_Line; - end case; - end Disp_Info; - - procedure Disp_Tree_Info (Node: Iir) is - begin - Disp_Info (Get_Info (Node)); - end Disp_Tree_Info; - - procedure Set_Info (Target: Iir; Info: Sim_Info_Acc) is - begin - pragma Assert (Info_Node.Table (Target) = null); - Info_Node.Table (Target) := Info; - end Set_Info; - - function Get_Info (Target: Iir) return Sim_Info_Acc is - begin - return Info_Node.Table (Target); - end Get_Info; -end Annotations; diff --git a/src/vhdl/simulate/annotations.ads b/src/vhdl/simulate/annotations.ads deleted file mode 100644 index c8519fa46..000000000 --- a/src/vhdl/simulate/annotations.ads +++ /dev/null @@ -1,120 +0,0 @@ --- Annotations for 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 Iirs; use Iirs; -with Iir_Values; use Iir_Values; -with Types; use Types; - -package Annotations is - -- Decorate the tree in order to be usable with the internal simulator. - procedure Annotate (Unit : Iir_Design_Unit); - - -- Disp annotations for an iir node. - procedure Disp_Vhdl_Info (Node : Iir); - procedure Disp_Tree_Info (Node : Iir); - - -- For Kind_Extra: a number. Kind_Extra is not used by annotations, and - -- is free for another pass like preelab. - type Extra_Slot_Type is new Natural; - - Nbr_Packages : Pkg_Index_Type := 0; - - -- Annotations are used to collect informations for elaboration and to - -- locate iir_value_literal for signals, variables or constants. - - -- The annotation depends on the kind of the node. - type Sim_Info_Kind is - (Kind_Block, Kind_Process, Kind_Frame, - Kind_Scalar_Type, Kind_File_Type, - Kind_Object, Kind_Signal, - Kind_File, - Kind_Terminal, Kind_Quantity, - Kind_Environment, - Kind_PSL, - Kind_Extra); - - type Sim_Info_Type (Kind : Sim_Info_Kind); - type Sim_Info_Acc is access all Sim_Info_Type; - - type Instance_Slot_Type is new Integer; - Invalid_Instance_Slot : constant Instance_Slot_Type := -1; - - -- Annotation for an iir node in order to be able to simulate it. - type Sim_Info_Type (Kind: Sim_Info_Kind) is record - case Kind is - when Kind_Block - | Kind_Frame - | Kind_Process - | Kind_Environment => - -- Scope level for this frame. - Frame_Scope : Scope_Type; - - -- Number of objects/signals. - Nbr_Objects : Object_Slot_Type; - - case Kind is - when Kind_Block => - -- Slot number in the parent (for blocks). - Inst_Slot : Instance_Slot_Type; - - -- Number of children (blocks, generate, instantiation). - Nbr_Instances : Instance_Slot_Type; - - when Kind_Environment => - Env_Slot : Object_Slot_Type; - - when others => - null; - end case; - - when Kind_Object - | Kind_Signal - | Kind_File - | Kind_Terminal - | Kind_Quantity - | Kind_PSL => - -- Block in which this object is declared in. - Obj_Scope : Scope_Type; - - -- Variable index in the block. - Slot: Object_Slot_Type; - - when Kind_Scalar_Type => - Scalar_Mode : Iir_Value_Kind; - - when Kind_File_Type => - File_Signature : String_Acc; - - when Kind_Extra => - Extra_Slot : Extra_Slot_Type; - end case; - end record; - - -- Get/Set annotation fied from/to an iir. - procedure Set_Info (Target : Iir; Info : Sim_Info_Acc); - pragma Inline (Set_Info); - function Get_Info (Target : Iir) return Sim_Info_Acc; - pragma Inline (Get_Info); - - -- Expand the annotation table. This is automatically done by Annotate, - -- to be used only by debugger. - procedure Annotate_Expand_Table; - - -- For debugging. - function Image (Scope : Scope_Type) return String; -end Annotations; diff --git a/src/vhdl/simulate/debugger-ams.adb b/src/vhdl/simulate/debugger-ams.adb deleted file mode 100644 index fec635048..000000000 --- a/src/vhdl/simulate/debugger-ams.adb +++ /dev/null @@ -1,85 +0,0 @@ --- Interpreter AMS 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 Iirs_Utils; use Iirs_Utils; -with Ada.Text_IO; use Ada.Text_IO; -with Disp_Vhdl; - -package body Debugger.AMS is - procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type) - is - Obj : Scalar_Quantity renames Scalar_Quantities.Table (Quantity); - begin - Disp_Instance_Name (Obj.Instance, True); - Put ('.'); - Put (Image_Identifier (Obj.Decl)); - if Obj.Kind = Quantity_Reference then - Put ("'Ref"); - end if; - end Disp_Quantity_Name; - - procedure Disp_Term (Term : Ams_Term_Acc) is - begin - case Term.Sign is - when Op_Plus => - Put (" + "); - when Op_Minus => - Put (" - "); - end case; - - case Term.Op is - when Op_Quantity => - Disp_Quantity_Name (Term.Quantity); - when Op_Vhdl_Expr => - Disp_Vhdl.Disp_Expression (Term.Vhdl_Expr); - end case; - end Disp_Term; - - procedure Disp_Characteristic_Expression - (Ce : Characteristic_Expressions_Index) - is - Obj : Characteristic_Expr renames - Characteristic_Expressions.Table (Ce); - Expr : Ams_Term_Acc := Obj.Expr; - begin - case Obj.Kind is - when Explicit => - Put ("Explic:"); - when Contribution => - Put ("Contri:"); - when Structural => - Put ("Struct:"); - end case; - - while Expr /= null loop - Disp_Term (Expr); - Expr := Expr.Next; - end loop; - New_Line; - end Disp_Characteristic_Expression; - - procedure Disp_Characteristic_Expressions is - begin - Put_Line ("Characteristic expressions:"); - for I in Characteristic_Expressions.First - .. Characteristic_Expressions.Last - loop - Disp_Characteristic_Expression (I); - end loop; - end Disp_Characteristic_Expressions; -end Debugger.AMS; diff --git a/src/vhdl/simulate/debugger-ams.ads b/src/vhdl/simulate/debugger-ams.ads deleted file mode 100644 index f89fda276..000000000 --- a/src/vhdl/simulate/debugger-ams.ads +++ /dev/null @@ -1,28 +0,0 @@ --- Interpreter AMS 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 Elaboration.AMS; use Elaboration.AMS; - -package Debugger.AMS is - procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type); - - procedure Disp_Characteristic_Expression - (Ce : Characteristic_Expressions_Index); - - procedure Disp_Characteristic_Expressions; -end Debugger.AMS; diff --git a/src/vhdl/simulate/debugger.adb b/src/vhdl/simulate/debugger.adb deleted file mode 100644 index eea71f84c..000000000 --- a/src/vhdl/simulate/debugger.adb +++ /dev/null @@ -1,2284 +0,0 @@ --- Debugger for interpreter --- 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 System; -with Ada.Text_IO; use Ada.Text_IO; -with Tables; -with Types; use Types; -with Name_Table; -with Str_Table; -with Files_Map; -with Parse; -with Scanner; -with Tokens; -with Sem_Expr; -with Sem_Scopes; -with Canon; -with Std_Names; -with Libraries; -with Std_Package; -with Annotations; use Annotations; -with Elaboration; use Elaboration; -with Iirs_Utils; use Iirs_Utils; -with Errorout; use Errorout; -with Disp_Vhdl; -with Execution; use Execution; ---with Simulation; use Simulation; -with Iirs_Walk; use Iirs_Walk; -with Areapools; use Areapools; -with Grt.Types; -with Grt.Disp; -with Grt.Readline; -with Grt.Errors; -with Grt.Disp_Signals; - -package body Debugger is - -- This exception can be raised by a debugger command to directly return - -- to the prompt. - Command_Error : exception; - - type Menu_Procedure is access procedure (Line : String); - - -- If set (by commands), call this procedure on empty line to repeat - -- last command. - Cmd_Repeat : Menu_Procedure; - - -- For the list command: current file and current line. - List_Current_File : Source_File_Entry := No_Source_File_Entry; - List_Current_Line : Natural := 0; - List_Current_Line_Pos : Source_Ptr := 0; - - -- Set List_Current_* from a location. To be called after program break - -- to indicate current location. - procedure Set_List_Current (Loc : Location_Type) - is - Offset : Natural; - begin - Files_Map.Location_To_Coord - (Loc, List_Current_File, List_Current_Line_Pos, - List_Current_Line, Offset); - end Set_List_Current; - - Dbg_Top_Frame : Block_Instance_Acc; - Dbg_Cur_Frame : Block_Instance_Acc; - - procedure Set_Cur_Frame (Frame : Block_Instance_Acc) is - begin - Dbg_Cur_Frame := Frame; - end Set_Cur_Frame; - - procedure Set_Top_Frame (Frame : Block_Instance_Acc) is - begin - Dbg_Top_Frame := Frame; - Set_Cur_Frame (Frame); - end Set_Top_Frame; - - type Breakpoint_Entry is record - Stmt : Iir; - end record; - - package Breakpoints is new Tables - (Table_Index_Type => Natural, - Table_Component_Type => Breakpoint_Entry, - Table_Low_Bound => 1, - Table_Initial => 16); - - -- Current execution state, or reason to stop execution (set by the - -- last debugger command). - type Exec_State_Type is - (-- Execution should continue until a breakpoint is reached or assertion - -- failure. - Exec_Run, - - -- Execution will stop at the next statement. - Exec_Single_Step, - - -- Execution will stop at the next simple statement in the same frame. - Exec_Next, - - -- Execution will stop at the next statement in the same frame. In - -- case of compound statement, stop after the compound statement. - Exec_Next_Stmt); - - Exec_State : Exec_State_Type := Exec_Run; - - -- Current frame for next. - Exec_Instance : Block_Instance_Acc; - - -- Current statement for next_stmt. - Exec_Statement : Iir; - - procedure Disp_Iir_Location (N : Iir) is - begin - if N = Null_Iir then - Put (Standard_Error, "??:??:??"); - else - Put (Standard_Error, Disp_Location (N)); - end if; - Put (Standard_Error, ": "); - end Disp_Iir_Location; - - -- Disp a message during execution. - procedure Error_Msg_Exec (Msg: String; Loc: in Iir) is - begin - Disp_Iir_Location (Loc); - Put_Line (Standard_Error, Msg); - Grt.Errors.Fatal_Error; - end Error_Msg_Exec; - - procedure Warning_Msg_Exec (Msg: String; Loc: Iir) is - begin - Disp_Iir_Location (Loc); - Put (Standard_Error, "warning: "); - Put_Line (Standard_Error, Msg); - end Warning_Msg_Exec; - - -- Disp a message for a constraint error. - procedure Error_Msg_Constraint (Expr: in Iir) is - begin - if Expr /= Null_Iir then - Disp_Iir_Location (Expr); - end if; - Put (Standard_Error, "constraint violation"); - if Expr /= Null_Iir then - case Get_Kind (Expr) is - when Iir_Kind_Addition_Operator => - Put_Line (Standard_Error, " in the ""+"" operation"); - when Iir_Kind_Substraction_Operator => - Put_Line (Standard_Error, " in the ""-"" operation"); - when Iir_Kind_Integer_Literal => - Put_Line (Standard_Error, ", literal out of range"); - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration => - Put_Line (Standard_Error, " for " & Disp_Node (Expr)); - when others => - New_Line (Standard_Error); - end case; - end if; - Grt.Errors.Fatal_Error; - end Error_Msg_Constraint; - - function Get_Instance_Local_Name (Instance : Block_Instance_Acc; - Short : Boolean := False) - return String - is - Name : constant Iir := Instance.Label; - begin - if Name = Null_Iir then - return ""; - end if; - - case Get_Kind (Name) is - when Iir_Kind_Block_Statement - | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Component_Instantiation_Statement - | Iir_Kind_Procedure_Declaration - | Iir_Kinds_Process_Statement - | Iir_Kind_Package_Declaration - | Iir_Kind_Configuration_Declaration => - return Image_Identifier (Name); - when Iir_Kind_Generate_Statement_Body => - return Image_Identifier (Get_Parent (Name)) - & '(' & Image_Identifier (Name) & ')'; - when Iir_Kind_Iterator_Declaration => - return Image_Identifier (Get_Parent (Name)) & '(' - & Execute_Image_Attribute - (Instance.Objects (Get_Info (Name).Slot), Get_Type (Name)) - & ')'; - when Iir_Kind_Architecture_Body => - if Short then - return Image_Identifier (Get_Entity (Name)); - else - return Image_Identifier (Get_Entity (Name)) - & '(' & Image_Identifier (Name) & ')'; - end if; - when others => - Error_Kind ("disp_instance_local_name", Name); - end case; - end Get_Instance_Local_Name; - - -- Disp the name of an instance, without newline. - procedure Disp_Instance_Name (Instance: Block_Instance_Acc; - Short : Boolean := False) is - begin - if Instance.Parent /= null then - Disp_Instance_Name (Instance.Parent); - Put ('.'); - end if; - Put (Get_Instance_Local_Name (Instance, Short)); - end Disp_Instance_Name; - - function Get_Instance_Name (Instance: Block_Instance_Acc) return String - is - function Parent_Name return String is - begin - if Instance.Parent /= null then - return Get_Instance_Name (Instance.Parent) & '.'; - else - return ""; - end if; - end Parent_Name; - begin - return Parent_Name & Get_Instance_Local_Name (Instance); - end Get_Instance_Name; - - procedure Disp_Instances_Tree_Name (Inst : Block_Instance_Acc) is - begin - if Inst = null then - Put ("*null*"); - New_Line; - return; - end if; - Put (Get_Instance_Local_Name (Inst)); - - Put (" "); - case Get_Kind (Inst.Label) is - when Iir_Kind_Block_Statement => - Put ("[block]"); - when Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Generate_Statement_Body => - Put ("[generate]"); - when Iir_Kind_Iterator_Declaration => - Put ("[iterator]"); - when Iir_Kind_Component_Instantiation_Statement => - Put ("[component]"); - when Iir_Kinds_Process_Statement => - Put ("[process]"); - when Iir_Kind_Architecture_Body => - Put ("[entity]"); - when Iir_Kind_Package_Declaration => - Put ("[package]"); - when Iir_Kind_Configuration_Declaration => - Put ("[configuration]"); - when others => - Error_Kind ("disp_instances_tree_name", Inst.Label); - end case; - New_Line; - end Disp_Instances_Tree_Name; - - procedure Disp_Instances_Tree1 (Inst : Block_Instance_Acc; Pfx : String) - is - Child : Block_Instance_Acc; - begin - Child := Inst.Children; - if Child = null then - return; - end if; - - loop - if Child.Brother /= null then - Put (Pfx & "+-"); - Disp_Instances_Tree_Name (Child); - - Disp_Instances_Tree1 (Child, Pfx & "| "); - Child := Child.Brother; - else - Put (Pfx & "`-"); - Disp_Instances_Tree_Name (Child); - - Disp_Instances_Tree1 (Child, Pfx & " "); - exit; - end if; - end loop; - end Disp_Instances_Tree1; - - procedure Disp_Instances_Tree is - begin - for I in Package_Instances'Range loop - if Package_Instances (I) /= null then - Disp_Instances_Tree_Name (Package_Instances (I)); - end if; - end loop; - Disp_Instances_Tree_Name (Top_Instance); - Disp_Instances_Tree1 (Top_Instance, ""); - end Disp_Instances_Tree; - - -- Disp a block instance, in a human readable way. - -- Used to debug. - procedure Disp_Block_Instance (Instance: Block_Instance_Acc) is - begin - Put_Line ("scope:" & Image (Instance.Block_Scope)); - Put_Line ("Objects:"); - for I in Instance.Objects'Range loop - Put (Object_Slot_Type'Image (I) & ": "); - Disp_Value_Tab (Instance.Objects (I), 3); - New_Line; - end loop; - end Disp_Block_Instance; - - procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir); - - procedure Disp_Signal_Array (Value : Iir_Value_Literal_Acc; - A_Type : Iir; - Dim : Natural) - is - begin - if Dim = Get_Nbr_Elements (Get_Index_Subtype_List (A_Type)) then - Put ("("); - for I in Value.Val_Array.V'Range loop - if I /= 1 then - Put (", "); - end if; - Disp_Signal (Value.Val_Array.V (I), Get_Element_Subtype (A_Type)); - end loop; - Put (")"); - else - Put ("("); - Disp_Signal_Array (Value, A_Type, Dim + 1); - Put (")"); - end if; - end Disp_Signal_Array; - - procedure Disp_Signal_Record (Value : Iir_Value_Literal_Acc; A_Type : Iir) - is - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (A_Type)); - El : Iir_Element_Declaration; - begin - Put ("("); - for I in Value.Val_Record.V'Range loop - El := Get_Nth_Element (List, Natural (I - 1)); - if I /= 1 then - Put (", "); - end if; - Put (Name_Table.Image (Get_Identifier (El))); - Put (" => "); - Disp_Signal (Value.Val_Record.V (I), Get_Type (El)); - end loop; - Put (")"); - end Disp_Signal_Record; - - procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir) is - begin - if Value = null then - Put ("!NULL!"); - return; - end if; - case Value.Kind is - when Iir_Value_Scalars - | Iir_Value_Access => - Disp_Iir_Value (Value, A_Type); - when Iir_Value_Array => - Disp_Signal_Array (Value, A_Type, 1); - when Iir_Value_Record => - Disp_Signal_Record (Value, A_Type); - when Iir_Value_Range => - -- FIXME. - raise Internal_Error; - when Iir_Value_Signal => - Grt.Disp_Signals.Disp_A_Signal (Value.Sig); - when Iir_Value_File - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Disp_Signal; - - procedure Disp_Instance_Signal (Instance: Block_Instance_Acc; Decl : Iir) - is - Info : constant Sim_Info_Acc := Get_Info (Decl); - begin - Put (" "); - Put (Name_Table.Image (Get_Identifier (Decl))); - Put (" = "); - Disp_Signal (Instance.Objects (Info.Slot), Get_Type (Decl)); - end Disp_Instance_Signal; - - procedure Disp_Instance_Signals_Of_Chain (Instance: Block_Instance_Acc; - Chain : Iir) - is - El : Iir; - begin - El := Chain; - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration => - Disp_Instance_Signal (Instance, El); - when others => - null; - end case; - El := Get_Chain (El); - end loop; - end Disp_Instance_Signals_Of_Chain; - - procedure Disp_Instance_Signals (Instance: Block_Instance_Acc) - is - Blk : constant Iir := Instance.Label; - Child: Block_Instance_Acc; - begin - case Get_Kind (Blk) is - when Iir_Kind_Architecture_Body => - declare - Ent : constant Iir := Get_Entity (Blk); - begin - Disp_Instance_Name (Instance); - Put_Line (" [architecture]:"); - - Disp_Instance_Signals_Of_Chain - (Instance, Get_Port_Chain (Ent)); - Disp_Instance_Signals_Of_Chain - (Instance, Get_Declaration_Chain (Ent)); - end; - when Iir_Kind_Block_Statement => - Disp_Instance_Name (Instance); - Put_Line (" [block]:"); - - -- FIXME: ports. - Disp_Instance_Signals_Of_Chain - (Instance, Get_Declaration_Chain (Blk)); - - when Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement => - Disp_Instance_Name (Instance); - Put_Line (" [generate]:"); - - when Iir_Kind_Generate_Statement_Body => - Disp_Instance_Signals_Of_Chain - (Instance, Get_Declaration_Chain (Blk)); - when Iir_Kind_Component_Instantiation_Statement => - Disp_Instance_Name (Instance); - Put_Line (" [component]:"); - Disp_Instance_Signals_Of_Chain - (Instance, Get_Port_Chain (Instance.Stmt)); - when Iir_Kinds_Process_Statement => - null; - when Iir_Kind_Iterator_Declaration => - null; - when others => - Error_Kind ("disp_instance_signals", Instance.Label); - end case; - - Child := Instance.Children; - while Child /= null loop - Disp_Instance_Signals (Child); - Child := Child.Brother; - end loop; - end Disp_Instance_Signals; - - -- Disp all signals name and values. - procedure Disp_Signals_Value is - begin - if Disp_Time_Before_Values then - Grt.Disp.Disp_Now; - end if; - Disp_Instance_Signals (Top_Instance); - end Disp_Signals_Value; - - procedure Disp_Label (Process : Iir) - is - Label : Name_Id; - begin - Label := Get_Label (Process); - if Label = Null_Identifier then - Put (""); - else - Put (Name_Table.Image (Label)); - end if; - end Disp_Label; - - procedure Disp_Declaration_Object - (Instance : Block_Instance_Acc; Decl : Iir) is - begin - case Get_Kind (Decl) is - when Iir_Kind_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Object_Alias_Declaration => - Put (Disp_Node (Decl)); - Put (" = "); - Disp_Value_Tab (Instance.Objects (Get_Info (Decl).Slot), 3); - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration => - declare - Sig : Iir_Value_Literal_Acc; - begin - Sig := Instance.Objects (Get_Info (Decl).Slot); - Put (Disp_Node (Decl)); - Put (" = "); - Disp_Signal (Sig, Get_Type (Decl)); - New_Line; - end; - when Iir_Kinds_Signal_Attribute => - -- FIXME: todo ? - null; - when Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration - | Iir_Kind_Subtype_Declaration => - -- FIXME: disp ranges - null; - when others => - Error_Kind ("disp_declaration_object", Decl); - end case; - end Disp_Declaration_Object; - - procedure Disp_Declaration_Objects - (Instance : Block_Instance_Acc; Decl_Chain : Iir) - is - El : Iir; - begin - El := Decl_Chain; - while El /= Null_Iir loop - Disp_Declaration_Object (Instance, El); - El := Get_Chain (El); - end loop; - end Disp_Declaration_Objects; - - procedure Disp_Objects (Instance : Block_Instance_Acc) - is - Decl : constant Iir := Instance.Label; - begin - Disp_Instance_Name (Instance); - New_Line; - case Get_Kind (Decl) is - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration => - Disp_Declaration_Objects - (Instance, Get_Interface_Declaration_Chain (Decl)); - Disp_Declaration_Objects - (Instance, - Get_Declaration_Chain (Get_Subprogram_Body (Decl))); - when Iir_Kind_Architecture_Body => - declare - Entity : constant Iir_Entity_Declaration := Get_Entity (Decl); - begin - Disp_Declaration_Objects - (Instance, Get_Generic_Chain (Entity)); - Disp_Declaration_Objects - (Instance, Get_Port_Chain (Entity)); - Disp_Declaration_Objects - (Instance, Get_Declaration_Chain (Entity)); - Disp_Declaration_Objects - (Instance, Get_Declaration_Chain (Decl)); - -- FIXME: processes. - end; - when Iir_Kind_Component_Instantiation_Statement => - null; - when others => - Error_Kind ("disp_objects", Decl); - end case; - end Disp_Objects; - pragma Unreferenced (Disp_Objects); - - procedure Disp_Process_Stats - is - Proc : Iir; - Stmt : Iir; - Nbr_User_Sensitized_Processes : Natural := 0; - Nbr_User_If_Sensitized_Processes : Natural := 0; - Nbr_Conc_Sensitized_Processes : Natural := 0; - Nbr_User_Non_Sensitized_Processes : Natural := 0; - Nbr_Conc_Non_Sensitized_Processes : Natural := 0; - begin - for I in Processes_Table.First .. Processes_Table.Last loop - Proc := Processes_Table.Table (I).Label; - case Get_Kind (Proc) is - when Iir_Kind_Sensitized_Process_Statement => - if Get_Process_Origin (Proc) = Null_Iir then - Stmt := Get_Sequential_Statement_Chain (Proc); - if Stmt /= Null_Iir - and then Get_Kind (Stmt) = Iir_Kind_If_Statement - and then Get_Chain (Stmt) = Null_Iir - then - Nbr_User_If_Sensitized_Processes := - Nbr_User_If_Sensitized_Processes + 1; - else - Nbr_User_Sensitized_Processes := - Nbr_User_Sensitized_Processes + 1; - end if; - else - Nbr_Conc_Sensitized_Processes := - Nbr_Conc_Sensitized_Processes + 1; - end if; - when Iir_Kind_Process_Statement => - if Get_Process_Origin (Proc) = Null_Iir then - Nbr_User_Non_Sensitized_Processes := - Nbr_User_Non_Sensitized_Processes + 1; - else - Nbr_Conc_Non_Sensitized_Processes := - Nbr_Conc_Non_Sensitized_Processes + 1; - end if; - when others => - raise Internal_Error; - end case; - end loop; - - Put (Natural'Image (Nbr_User_If_Sensitized_Processes)); - Put_Line (" user sensitized processes with only a if stmt"); - Put (Natural'Image (Nbr_User_Sensitized_Processes)); - Put_Line (" user sensitized processes (others)"); - Put (Natural'Image (Nbr_User_Non_Sensitized_Processes)); - Put_Line (" user non sensitized processes"); - Put (Natural'Image (Nbr_Conc_Sensitized_Processes)); - Put_Line (" sensitized concurrent statements"); - Put (Natural'Image (Nbr_Conc_Non_Sensitized_Processes)); - Put_Line (" non sensitized concurrent statements"); - Put (Process_Index_Type'Image (Processes_Table.Last)); - Put_Line (" processes (total)"); - end Disp_Process_Stats; - - procedure Disp_Signals_Stats - is - use Grt.Types; - type Counters_Type is array (Mode_Signal_Type) of Natural; - Counters : Counters_Type := (others => 0); - Nbr_User_Signals : Natural := 0; - Nbr_Signal_Elements : Natural := 0; - begin - for I in Signals_Table.First .. Signals_Table.Last loop - declare - Ent : Signal_Entry renames Signals_Table.Table (I); - begin - if Ent.Kind in Mode_Signal_User then - Nbr_User_Signals := Nbr_User_Signals + 1; - Nbr_Signal_Elements := Nbr_Signal_Elements + - Get_Nbr_Of_Scalars (Signals_Table.Table (I).Sig); - end if; - Counters (Ent.Kind) := Counters (Ent.Kind) + 1; - end; - end loop; - Put (Integer'Image (Nbr_User_Signals)); - Put_Line (" declared user signals or ports"); - Put (Integer'Image (Nbr_Signal_Elements)); - Put_Line (" user signals sub-elements"); - Put (Integer'Image (Counters (Mode_Quiet))); - Put_Line (" 'quiet implicit signals"); - Put (Integer'Image (Counters (Mode_Stable))); - Put_Line (" 'stable implicit signals"); - Put (Integer'Image (Counters (Mode_Delayed))); - Put_Line (" 'delayed implicit signals"); - Put (Integer'Image (Counters (Mode_Transaction))); - Put_Line (" 'transaction implicit signals"); - Put (Integer'Image (Counters (Mode_Guard))); - Put_Line (" guard signals"); - end Disp_Signals_Stats; - - procedure Disp_Design_Stats is - begin - Disp_Process_Stats; - - New_Line; - - Disp_Signals_Stats; - - New_Line; - - Put (Integer'Image (Connect_Table.Last)); - Put_Line (" connections"); - end Disp_Design_Stats; - - procedure Disp_Design_Non_Sensitized - is - Instance : Block_Instance_Acc; - Proc : Iir; - begin - for I in Processes_Table.First .. Processes_Table.Last loop - Instance := Processes_Table.Table (I); - Proc := Processes_Table.Table (I).Label; - if Get_Kind (Proc) = Iir_Kind_Process_Statement then - Disp_Instance_Name (Instance); - New_Line; - Put_Line (" at " & Disp_Location (Proc)); - end if; - end loop; - end Disp_Design_Non_Sensitized; - - procedure Disp_Design_Connections is - begin - for I in Connect_Table.First .. Connect_Table.Last loop - declare - Conn : Connect_Entry renames Connect_Table.Table (I); - begin - Disp_Iir_Location (Conn.Assoc); - New_Line; - end; - end loop; - end Disp_Design_Connections; - - function Walk_Files (Cb : Walk_Cb) return Walk_Status - is - Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; - File : Iir_Design_File; - begin - while Lib /= Null_Iir loop - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - case Cb.all (File) is - when Walk_Continue => - null; - when Walk_Up => - exit; - when Walk_Abort => - return Walk_Abort; - end case; - File := Get_Chain (File); - end loop; - Lib := Get_Chain (Lib); - end loop; - return Walk_Continue; - end Walk_Files; - - Walk_Units_Cb : Walk_Cb; - - function Cb_Walk_Units (Design_File : Iir) return Walk_Status - is - Unit : Iir_Design_Unit; - begin - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is - when Walk_Continue => - null; - when Walk_Abort => - return Walk_Abort; - when Walk_Up => - exit; - end case; - Unit := Get_Chain (Unit); - end loop; - return Walk_Continue; - end Cb_Walk_Units; - - function Walk_Units (Cb : Walk_Cb) return Walk_Status is - begin - Walk_Units_Cb := Cb; - return Walk_Files (Cb_Walk_Units'Access); - end Walk_Units; - - Walk_Declarations_Cb : Walk_Cb; - - function Cb_Walk_Declarations (Unit : Iir) return Walk_Status - is - function Walk_Decl_Chain (Chain : Iir) return Walk_Status - is - Decl : Iir; - begin - Decl := Chain; - while Decl /= Null_Iir loop - case Walk_Declarations_Cb.all (Decl) is - when Walk_Abort => - return Walk_Abort; - when Walk_Up => - return Walk_Continue; - when Walk_Continue => - null; - end case; - Decl := Get_Chain (Decl); - end loop; - return Walk_Continue; - end Walk_Decl_Chain; - - function Walk_Conc_Chain (Chain : Iir) return Walk_Status; - - function Walk_Generate_Statement_Body (Bod : Iir) return Walk_Status is - begin - if Walk_Decl_Chain (Get_Declaration_Chain (Bod)) = Walk_Abort then - return Walk_Abort; - end if; - if Walk_Conc_Chain (Get_Concurrent_Statement_Chain (Bod)) = Walk_Abort - then - return Walk_Abort; - end if; - return Walk_Continue; - end Walk_Generate_Statement_Body; - - function Walk_Conc_Chain (Chain : Iir) return Walk_Status - is - Stmt : Iir := Chain; - begin - while Stmt /= Null_Iir loop - case Get_Kind (Stmt) is - when Iir_Kinds_Process_Statement => - if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) - = Walk_Abort - then - return Walk_Abort; - end if; - when Iir_Kind_For_Generate_Statement => - if Walk_Declarations_Cb.all - (Get_Parameter_Specification (Stmt)) = Walk_Abort - or else Walk_Generate_Statement_Body - (Get_Generate_Statement_Body (Stmt)) = Walk_Abort - then - return Walk_Abort; - end if; - when Iir_Kind_If_Generate_Statement => - declare - Stmt1 : Iir; - begin - Stmt1 := Stmt; - while Stmt1 /= Null_Iir loop - if Walk_Generate_Statement_Body - (Get_Generate_Statement_Body (Stmt)) = Walk_Abort - then - return Walk_Abort; - end if; - Stmt1 := Get_Generate_Else_Clause (Stmt1); - end loop; - end; - when Iir_Kind_Component_Instantiation_Statement => - null; - when Iir_Kind_Block_Statement => - -- FIXME: header - if (Walk_Decl_Chain - (Get_Declaration_Chain (Stmt)) = Walk_Abort) - or else - (Walk_Conc_Chain - (Get_Concurrent_Statement_Chain (Stmt)) = Walk_Abort) - then - return Walk_Abort; - end if; - when others => - Error_Kind ("walk_conc_chain", Stmt); - end case; - Stmt := Get_Chain (Stmt); - end loop; - return Walk_Continue; - end Walk_Conc_Chain; - begin - case Get_Kind (Unit) is - when Iir_Kind_Entity_Declaration => - if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort - or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort - or else (Walk_Decl_Chain - (Get_Declaration_Chain (Unit)) = Walk_Abort) - or else (Walk_Conc_Chain - (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) - then - return Walk_Abort; - end if; - when Iir_Kind_Architecture_Body => - if (Walk_Decl_Chain - (Get_Declaration_Chain (Unit)) = Walk_Abort) - or else (Walk_Conc_Chain - (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) - then - return Walk_Abort; - end if; - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body => - if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort - then - return Walk_Abort; - end if; - when Iir_Kind_Configuration_Declaration => - if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort - then - return Walk_Abort; - end if; - -- FIXME: block configuration ? - when Iir_Kind_Context_Declaration => - null; - when others => - Error_Kind ("Cb_Walk_Declarations", Unit); - end case; - return Walk_Continue; - end Cb_Walk_Declarations; - - function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is - begin - Walk_Declarations_Cb := Cb; - return Walk_Units (Cb_Walk_Declarations'Access); - end Walk_Declarations; - - function Is_Blank (C : Character) return Boolean is - begin - return C = ' ' or else C = ASCII.HT; - end Is_Blank; - - function Skip_Blanks (S : String) return Positive - is - P : Positive := S'First; - begin - while P <= S'Last and then Is_Blank (S (P)) loop - P := P + 1; - end loop; - return P; - end Skip_Blanks; - - -- Return the position of the last character of the word (the last - -- non-blank character). - function Get_Word (S : String) return Positive - is - P : Positive := S'First; - begin - while P <= S'Last and then not Is_Blank (S (P)) loop - P := P + 1; - end loop; - return P - 1; - end Get_Word; - - procedure Disp_A_Frame (Instance: Block_Instance_Acc) is - begin - Put (Disp_Node (Instance.Label)); - if Instance.Stmt /= Null_Iir then - Put (" at "); - Put (Files_Map.Image (Get_Location (Instance.Stmt))); - end if; - New_Line; - end Disp_A_Frame; - - procedure Disp_Current_Lines - is - use Files_Map; - -- Number of lines to display before and after the current line. - Radius : constant := 5; - - Buf : File_Buffer_Acc; - - Pos : Source_Ptr; - Line : Natural; - Len : Source_Ptr; - C : Character; - begin - if List_Current_Line > Radius then - Line := List_Current_Line - Radius; - else - Line := 1; - end if; - - Pos := Line_To_Position (List_Current_File, Line); - Buf := Get_File_Source (List_Current_File); - - while Line < List_Current_Line + Radius loop - -- Compute line length. - Len := 0; - loop - C := Buf (Pos + Len); - exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; - Len := Len + 1; - end loop; - - -- Disp line number. - declare - Str : constant String := Natural'Image (Line); - begin - if Line = List_Current_Line then - Put ('*'); - else - Put (' '); - end if; - Put ((Str'Length .. 5 => ' ')); - Put (Str (Str'First + 1 .. Str'Last)); - Put (' '); - end; - - -- Disp line. - Put_Line (String (Buf (Pos .. Pos + Len - 1))); - - -- Skip EOL. - exit when C = ASCII.EOT; - Pos := Pos + Len + 1; - if C = ASCII.CR then - if Buf (Pos) = ASCII.LF then - Pos := Pos + 1; - end if; - else - pragma Assert (C = ASCII.LF); - if Buf (Pos) = ASCII.CR then - Pos := Pos + 1; - end if; - end if; - - Line := Line + 1; - end loop; - end Disp_Current_Lines; - - procedure Disp_Source_Line (Loc : Location_Type) - is - use Files_Map; - - File : Source_File_Entry; - Line_Pos : Source_Ptr; - Line : Natural; - Offset : Natural; - Buf : File_Buffer_Acc; - Next_Line_Pos : Source_Ptr; - begin - Location_To_Coord (Loc, File, Line_Pos, Line, Offset); - Buf := Get_File_Source (File); - Next_Line_Pos := Line_To_Position (File, Line + 1); - Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); - end Disp_Source_Line; - - type Menu_Kind is (Menu_Command, Menu_Submenu); - type Menu_Entry (Kind : Menu_Kind); - type Menu_Entry_Acc is access all Menu_Entry; - - type Cst_String_Acc is access constant String; - - type Menu_Entry (Kind : Menu_Kind) is record - Name : Cst_String_Acc; - Next : Menu_Entry_Acc; - - case Kind is - when Menu_Command => - Proc : Menu_Procedure; - when Menu_Submenu => - First, Last : Menu_Entry_Acc := null; - end case; - end record; - - -- Check there is a current process. - procedure Check_Current_Process is - begin - if Current_Process = null then - Put_Line ("no current process"); - raise Command_Error; - end if; - end Check_Current_Process; - - -- The status of the debugger. This status can be modified by a command - -- as a side effect to resume or quit the debugger. - type Command_Status_Type is (Status_Default, Status_Quit); - Command_Status : Command_Status_Type; - - procedure Help_Proc (Line : String); - - procedure Disp_Process_Loc (Proc : Process_State_Type) is - begin - Disp_Instance_Name (Proc.Top_Instance); - Put (" (" & Files_Map.Image (Get_Location (Proc.Proc)) & ")"); - New_Line; - end Disp_Process_Loc; - - -- Disp the list of processes (and its state) - procedure Ps_Proc (Line : String) is - pragma Unreferenced (Line); - Process : Iir; - begin - if Processes_State = null then - Put_Line ("no processes"); - return; - end if; - - for I in Processes_State'Range loop - Put (Process_Index_Type'Image (I) & ": "); - Process := Processes_State (I).Proc; - if Process /= Null_Iir then - Disp_Process_Loc (Processes_State (I)); - Disp_A_Frame (Processes_State (I).Instance); - else - Put_Line ("not yet elaborated"); - end if; - end loop; - end Ps_Proc; - - procedure List_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Disp_Current_Lines; - end List_Proc; - - procedure Up_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Check_Current_Process; - if Dbg_Cur_Frame.Parent = null then - Put_Line ("top of frames reached"); - else - Set_Cur_Frame (Dbg_Cur_Frame.Parent); - end if; - end Up_Proc; - - procedure Down_Proc (Line : String) - is - pragma Unreferenced (Line); - Inst : Block_Instance_Acc; - begin - Check_Current_Process; - if Dbg_Cur_Frame = Dbg_Top_Frame then - Put_Line ("bottom of frames reached"); - else - Inst := Dbg_Top_Frame; - while Inst.Parent /= Dbg_Cur_Frame loop - Inst := Inst.Parent; - end loop; - Set_Cur_Frame (Inst); - end if; - end Down_Proc; - - procedure Set_Breakpoint (Stmt : Iir) is - begin - Put_Line ("set breakpoint at: " & Files_Map.Image (Get_Location (Stmt))); - Breakpoints.Append (Breakpoint_Entry'(Stmt => Stmt)); - Flag_Need_Debug := True; - end Set_Breakpoint; - - function Is_Within_Statement (Stmt : Iir; Cur : Iir) return Boolean - is - Parent : Iir; - begin - Parent := Cur; - loop - if Parent = Stmt then - return True; - end if; - case Get_Kind (Parent) is - when Iir_Kinds_Sequential_Statement => - Parent := Get_Parent (Parent); - when others => - return False; - end case; - end loop; - end Is_Within_Statement; - - -- Next statement in the same frame, but handle compound statements as - -- one statement. - procedure Next_Stmt_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Next_Stmt; - Exec_Instance := Dbg_Top_Frame; - Exec_Statement := Dbg_Top_Frame.Stmt; - Flag_Need_Debug := True; - Command_Status := Status_Quit; - end Next_Stmt_Proc; - - -- Finish parent statement. - procedure Finish_Stmt_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Next_Stmt; - Exec_Instance := Dbg_Top_Frame; - Exec_Statement := Get_Parent (Dbg_Top_Frame.Stmt); - Flag_Need_Debug := True; - Command_Status := Status_Quit; - end Finish_Stmt_Proc; - - procedure Next_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Next; - Exec_Instance := Dbg_Top_Frame; - Flag_Need_Debug := True; - Command_Status := Status_Quit; - Cmd_Repeat := Next_Proc'Access; - end Next_Proc; - - procedure Step_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - Exec_State := Exec_Single_Step; - Flag_Need_Debug := True; - Command_Status := Status_Quit; - Cmd_Repeat := Step_Proc'Access; - end Step_Proc; - - Break_Id : Name_Id; - - function Cb_Set_Break (El : Iir) return Walk_Status is - begin - case Get_Kind (El) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Get_Identifier (El) = Break_Id - and then - Get_Implicit_Definition (El) not in Iir_Predefined_Implicit - then - Set_Breakpoint - (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El))); - end if; - when others => - null; - end case; - return Walk_Continue; - end Cb_Set_Break; - - procedure Break_Proc (Line : String) - is - Status : Walk_Status; - P : Natural; - begin - P := Skip_Blanks (Line); - if Line (P) = '"' then - -- An operator name. - declare - use Str_Table; - Str : String8_Id; - Len : Nat32; - begin - Str := Create_String8; - Len := 0; - P := P + 1; - while Line (P) /= '"' loop - Append_String8_Char (Line (P)); - Len := Len + 1; - P := P + 1; - end loop; - Break_Id := Parse.Str_To_Operator_Name (Str, Len, No_Location); - -- FIXME: free string. - -- FIXME: catch error. - end; - else - Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); - end if; - Status := Walk_Declarations (Cb_Set_Break'Access); - pragma Assert (Status = Walk_Continue); - end Break_Proc; - - procedure Where_Proc (Line : String) is - pragma Unreferenced (Line); - Frame : Block_Instance_Acc; - begin - Check_Current_Process; - Frame := Dbg_Top_Frame; - while Frame /= null loop - if Frame = Dbg_Cur_Frame then - Put ("* "); - else - Put (" "); - end if; - Disp_A_Frame (Frame); - Frame := Frame.Parent; - end loop; - end Where_Proc; - - procedure Info_Tree_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - if Top_Instance = null then - Put_Line ("design not yet fully elaborated"); - else - Disp_Instances_Tree; - end if; - end Info_Tree_Proc; - - procedure Info_Instances_Proc (Line : String) - is - pragma Unreferenced (Line); - procedure Disp_Instances (Inst : Block_Instance_Acc) - is - Child : Block_Instance_Acc; - begin - case Get_Kind (Inst.Label) is - when Iir_Kind_Architecture_Body => - Disp_Instances_Tree_Name (Inst); - when others => - null; - end case; - - Child := Inst.Children; - while Child /= null loop - if Get_Kind (Child.Label) not in Iir_Kinds_Process_Statement then - Disp_Instances (Child); - end if; - Child := Child.Brother; - end loop; - - end Disp_Instances; - begin - if Top_Instance = null then - Put_Line ("design not yet fully elaborated"); - return; - end if; - for I in Package_Instances'Range loop - if Package_Instances (I) /= null then - Put (Get_Instance_Local_Name (Package_Instances (I))); - Put_Line (" [package]"); - end if; - end loop; - Disp_Instances (Top_Instance); - end Info_Instances_Proc; - - procedure Info_Params_Proc (Line : String) - is - pragma Unreferenced (Line); - Decl : Iir; - Params : Iir; - begin - Check_Current_Process; - if Dbg_Cur_Frame = null then - Put_Line ("not in a subprogram"); - return; - end if; - Decl := Dbg_Cur_Frame.Label; - if Decl = Null_Iir - or else Get_Kind (Decl) not in Iir_Kinds_Subprogram_Declaration - then - Put_Line ("current frame is not a subprogram"); - return; - end if; - Params := Get_Interface_Declaration_Chain (Decl); - Disp_Declaration_Objects (Dbg_Cur_Frame, Params); - end Info_Params_Proc; - - procedure Info_Proc_Proc (Line : String) is - pragma Unreferenced (Line); - begin - Check_Current_Process; - Disp_Process_Loc (Current_Process.all); - end Info_Proc_Proc; - - function Cb_Disp_Subprograms (El : Iir) return Walk_Status is - begin - case Get_Kind (El) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Put_Line (Name_Table.Image (Get_Identifier (El))); - when others => - null; - end case; - return Walk_Continue; - end Cb_Disp_Subprograms; - - procedure Info_Subprograms_Proc (Line : String) is - pragma Unreferenced (Line); - Status : Walk_Status; - begin - Status := Walk_Declarations (Cb_Disp_Subprograms'Access); - pragma Assert (Status = Walk_Continue); - end Info_Subprograms_Proc; - - function Cb_Disp_Units (El : Iir) return Walk_Status is - begin - case Get_Kind (El) is - when Iir_Kind_Package_Declaration => - Put ("package "); - Put_Line (Name_Table.Image (Get_Identifier (El))); - when Iir_Kind_Entity_Declaration => - Put ("entity "); - Put_Line (Name_Table.Image (Get_Identifier (El))); - when Iir_Kind_Architecture_Body => - Put ("architecture "); - Put (Name_Table.Image (Get_Identifier (El))); - Put (" of "); - Put_Line (Name_Table.Image (Get_Identifier - (Get_Entity_Name (El)))); - when Iir_Kind_Configuration_Declaration => - Put ("configuration "); - Put_Line (Name_Table.Image (Get_Identifier (El))); - when Iir_Kind_Package_Body => - null; - when others => - Error_Kind ("cb_disp_units", El); - end case; - return Walk_Continue; - end Cb_Disp_Units; - - procedure Info_Units_Proc (Line : String) is - pragma Unreferenced (Line); - Status : Walk_Status; - begin - Status := Walk_Units (Cb_Disp_Units'Access); - pragma Assert (Status = Walk_Continue); - end Info_Units_Proc; - - function Cb_Disp_File (El : Iir) return Walk_Status is - begin - Put_Line (Name_Table.Image (Get_Design_File_Filename (El))); - return Walk_Continue; - end Cb_Disp_File; - - procedure Info_PSL_Proc (Line : String) - is - pragma Unreferenced (Line); - begin - if PSL_Table.Last < PSL_Table.First then - Put_Line ("no PSL directive"); - return; - end if; - - for I in PSL_Table.First .. PSL_Table.Last loop - declare - E : PSL_Entry renames PSL_Table.Table (I); - begin - Disp_Instance_Name (E.Instance); - Put ('.'); - Put (Name_Table.Image (Get_Identifier (E.Stmt))); - New_Line; - Disp_Vhdl.Disp_PSL_NFA (Get_PSL_NFA (E.Stmt)); - Put (" 01234567890123456789012345678901234567890123456789"); - for I in E.States'Range loop - if I mod 50 = 0 then - New_Line; - Put (Int32'Image (I / 10)); - Put (": "); - end if; - if E.States (I) then - Put ('*'); - else - Put ('.'); - end if; - end loop; - New_Line; - end; - end loop; - end Info_PSL_Proc; - - procedure Info_Stats_Proc (Line : String) is - P : Natural := Line'First; - E : Natural; - begin - P := Skip_Blanks (Line (P .. Line'Last)); - if P > Line'Last then - -- No parameters. - Disp_Design_Stats; - return; - end if; - - E := Get_Word (Line (P .. Line'Last)); - if Line (P .. E) = "global" then - Disp_Design_Stats; - elsif Line (P .. E) = "non-sensitized" then - Disp_Design_Non_Sensitized; - null; - elsif Line (P .. E) = "connections" then - Disp_Design_Connections; - -- TODO: nbr of conversions - else - Put_Line ("options are: global, non-sensitized, connections"); - -- TODO: signals: nbr of scalars, nbr of non-user... - end if; - end Info_Stats_Proc; - - procedure Info_Files_Proc (Line : String) - is - pragma Unreferenced (Line); - Status : Walk_Status; - begin - Status := Walk_Files (Cb_Disp_File'Access); - pragma Assert (Status = Walk_Continue); - end Info_Files_Proc; - - procedure Info_Libraries_Proc (Line : String) is - pragma Unreferenced (Line); - Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; - begin - while Lib /= Null_Iir loop - Put_Line (Name_Table.Image (Get_Identifier (Lib))); - Lib := Get_Chain (Lib); - end loop; - end Info_Libraries_Proc; - - procedure Disp_Declared_Signals_Chain - (Chain : Iir; Instance : Block_Instance_Acc) - is - pragma Unreferenced (Instance); - Decl : Iir; - begin - Decl := Chain; - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration => - Put_Line (" " & Name_Table.Image (Get_Identifier (Decl))); - when others => - null; - end case; - Decl := Get_Chain (Decl); - end loop; - end Disp_Declared_Signals_Chain; - - procedure Disp_Declared_Signals (Decl : Iir; Instance : Block_Instance_Acc) - is - begin - case Get_Kind (Decl) is - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement => - Disp_Declared_Signals (Get_Parent (Decl), Instance); - when Iir_Kind_Architecture_Body => - Disp_Declared_Signals (Get_Entity (Decl), Instance); - when Iir_Kind_Entity_Declaration => - null; - when others => - Error_Kind ("disp_declared_signals", Decl); - end case; - - case Get_Kind (Decl) is - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement => - -- No signal declaration in a process (FIXME: implicit signals) - null; - when Iir_Kind_Architecture_Body => - Put_Line ("Signals of architecture " - & Name_Table.Image (Get_Identifier (Decl)) & ':'); - Disp_Declared_Signals_Chain - (Get_Declaration_Chain (Decl), Instance); - when Iir_Kind_Entity_Declaration => - Put_Line ("Ports of entity " - & Name_Table.Image (Get_Identifier (Decl)) & ':'); - Disp_Declared_Signals_Chain - (Get_Port_Chain (Decl), Instance); - when others => - Error_Kind ("disp_declared_signals (2)", Decl); - end case; - end Disp_Declared_Signals; - - procedure Info_Signals_Proc (Line : String) is - pragma Unreferenced (Line); - begin - if False then - Check_Current_Process; - Disp_Declared_Signals - (Current_Process.Proc, Current_Process.Top_Instance); - elsif True then - for I in Signals_Table.First .. Signals_Table.Last loop - declare - S : Signal_Entry renames Signals_Table.Table (I); - begin - Disp_Instance_Name (S.Instance, False); - Put ('.'); - if S.Kind in Grt.Types.Mode_Signal_User then - Put (Name_Table.Image (Get_Identifier (S.Decl))); - Disp_Value (S.Sig); - Disp_Value (S.Val); - else - Disp_Declaration_Object (S.Instance, S.Decl); - end if; - end; - end loop; - else - Disp_Signals_Value; - end if; - end Info_Signals_Proc; - - type Handle_Scope_Type is access procedure (N : Iir); - - procedure Foreach_Scopes (N : Iir; Handler : Handle_Scope_Type) is - begin - case Get_Kind (N) is - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Foreach_Scopes (Get_Parent (N), Handler); - Handler.all (N); - when Iir_Kind_Architecture_Body => - Foreach_Scopes (Get_Entity (N), Handler); - Handler.all (N); - - when Iir_Kind_Entity_Declaration => - -- Top of scopes. - Handler.all (N); - - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - Foreach_Scopes (Get_Parent (N), Handler); - Handler.all (N); - when Iir_Kind_Package_Body => - Handler.all (N); - - when Iir_Kind_Variable_Assignment_Statement - | Iir_Kind_Simple_Signal_Assignment_Statement - | Iir_Kind_Null_Statement - | Iir_Kind_Assertion_Statement - | Iir_Kind_Report_Statement - | Iir_Kind_Wait_Statement - | Iir_Kind_Return_Statement - | Iir_Kind_Next_Statement - | Iir_Kind_Exit_Statement - | Iir_Kind_Procedure_Call_Statement - | Iir_Kind_If_Statement - | Iir_Kind_While_Loop_Statement - | Iir_Kind_Case_Statement => - Foreach_Scopes (Get_Parent (N), Handler); - - when Iir_Kind_For_Loop_Statement - | Iir_Kind_Block_Statement - | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Generate_Statement_Body => - Foreach_Scopes (Get_Parent (N), Handler); - Handler.all (N); - - when others => - Error_Kind ("foreach_scopes", N); - end case; - end Foreach_Scopes; - - procedure Add_Decls_For (N : Iir) - is - use Sem_Scopes; - begin - case Get_Kind (N) is - when Iir_Kind_Entity_Declaration => - declare - Unit : constant Iir := Get_Design_Unit (N); - begin - Add_Context_Clauses (Unit); - -- Add_Name (Unit, Get_Identifier (N), False); - Add_Entity_Declarations (N); - end; - when Iir_Kind_Architecture_Body => - Open_Declarative_Region; - Add_Context_Clauses (Get_Design_Unit (N)); - Add_Declarations (Get_Declaration_Chain (N), False); - Add_Declarations_Of_Concurrent_Statement (N); - when Iir_Kind_Package_Body => - declare - Package_Decl : constant Iir := Get_Package (N); - Package_Unit : constant Iir := Get_Design_Unit (Package_Decl); - begin - Add_Name (Package_Unit); - Add_Context_Clauses (Package_Unit); - Open_Declarative_Region; - Add_Declarations (Get_Declaration_Chain (Package_Decl), False); - Add_Declarations (Get_Declaration_Chain (N), False); - end; - when Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body => - declare - Spec : constant Iir := Get_Subprogram_Specification (N); - begin - Open_Declarative_Region; - Add_Declarations - (Get_Interface_Declaration_Chain (Spec), False); - Add_Declarations - (Get_Declaration_Chain (N), False); - end; - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Open_Declarative_Region; - Add_Declarations (Get_Declaration_Chain (N), False); - when Iir_Kind_For_Loop_Statement - | Iir_Kind_For_Generate_Statement => - Open_Declarative_Region; - Add_Name (Get_Parameter_Specification (N)); - when Iir_Kind_Block_Statement => - declare - Header : constant Iir := Get_Block_Header (N); - begin - Open_Declarative_Region; - if Header /= Null_Iir then - Add_Declarations (Get_Generic_Chain (Header), False); - Add_Declarations (Get_Port_Chain (Header), False); - end if; - Add_Declarations (Get_Declaration_Chain (N), False); - Add_Declarations_Of_Concurrent_Statement (N); - end; - when Iir_Kind_Generate_Statement_Body => - Open_Declarative_Region; - Add_Declarations (Get_Declaration_Chain (N), False); - Add_Declarations_Of_Concurrent_Statement (N); - when others => - Error_Kind ("enter_scope(2)", N); - end case; - end Add_Decls_For; - - procedure Enter_Scope (Node : Iir) - is - use Sem_Scopes; - begin - Push_Interpretations; - Open_Declarative_Region; - - -- Add STD - Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); - Use_All_Names (Std_Package.Standard_Package); - - Foreach_Scopes (Node, Add_Decls_For'Access); - end Enter_Scope; - - procedure Del_Decls_For (N : Iir) - is - use Sem_Scopes; - begin - case Get_Kind (N) is - when Iir_Kind_Entity_Declaration => - null; - when Iir_Kind_Architecture_Body => - Close_Declarative_Region; - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Package_Body - | Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body - | Iir_Kind_For_Loop_Statement - | Iir_Kind_Block_Statement - | Iir_Kind_If_Generate_Statement - | Iir_Kind_For_Generate_Statement - | Iir_Kind_Generate_Statement_Body => - Close_Declarative_Region; - when others => - Error_Kind ("Decl_Decls_For", N); - end case; - end Del_Decls_For; - - procedure Leave_Scope (Node : Iir) - is - use Sem_Scopes; - begin - Foreach_Scopes (Node, Del_Decls_For'Access); - - Close_Declarative_Region; - Pop_Interpretations; - end Leave_Scope; - - Buffer_Index : Natural := 1; - - procedure Print_Proc (Line : String) - is - use Tokens; - Index_Str : String := Natural'Image (Buffer_Index); - File : Source_File_Entry; - Expr : Iir; - Res : Iir_Value_Literal_Acc; - P : Natural; - Opt_Value : Boolean := False; - Opt_Name : Boolean := False; - Marker : Mark_Type; - begin - -- Decode options: /v - P := Line'First; - loop - P := Skip_Blanks (Line (P .. Line'Last)); - if P + 2 < Line'Last and then Line (P .. P + 1) = "/v" then - Opt_Value := True; - P := P + 2; - elsif P + 2 < Line'Last and then Line (P .. P + 1) = "/n" then - Opt_Name := True; - P := P + 2; - else - exit; - end if; - end loop; - - Buffer_Index := Buffer_Index + 1; - Index_Str (Index_Str'First) := '*'; - File := Files_Map.Create_Source_File_From_String - (Name_Table.Get_Identifier ("*debug" & Index_Str & '*'), - Line (P .. Line'Last)); - Scanner.Set_File (File); - Scanner.Scan; - Expr := Parse.Parse_Expression; - if Scanner.Current_Token /= Tok_Eof then - Put_Line ("garbage at end of expression ignored"); - end if; - Scanner.Close_File; - if Nbr_Errors /= 0 then - Put_Line ("error while parsing expression, evaluation aborted"); - Nbr_Errors := 0; - return; - end if; - - Enter_Scope (Dbg_Cur_Frame.Stmt); - Expr := Sem_Expr.Sem_Expression_Universal (Expr); - Leave_Scope (Dbg_Cur_Frame.Stmt); - - if Expr = Null_Iir - or else Nbr_Errors /= 0 - then - Put_Line ("error while analyzing expression, evaluation aborted"); - Nbr_Errors := 0; - return; - end if; - - Disp_Vhdl.Disp_Expression (Expr); - New_Line; - - Annotate_Expand_Table; - Canon.Canon_Expression (Expr); - - Mark (Marker, Expr_Pool); - - if Opt_Name then - case Get_Kind (Expr) is - when Iir_Kind_Simple_Name => - null; - when others => - Put_Line ("expression is not a name"); - Opt_Name := False; - end case; - end if; - if Opt_Name then - Res := Execute_Name (Dbg_Cur_Frame, Expr, True); - else - Res := Execute_Expression (Dbg_Cur_Frame, Expr); - end if; - if Opt_Value then - Disp_Value (Res); - else - Disp_Iir_Value (Res, Get_Type (Expr)); - end if; - New_Line; - - -- Free value - Release (Marker, Expr_Pool); - end Print_Proc; - - procedure Quit_Proc (Line : String) is - pragma Unreferenced (Line); - begin - Command_Status := Status_Quit; - raise Debugger_Quit; - end Quit_Proc; - - procedure Cont_Proc (Line : String) is - pragma Unreferenced (Line); - begin - Command_Status := Status_Quit; - - -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. - Flag_Need_Debug := False; - for I in Breakpoints.First .. Breakpoints.Last loop - Flag_Need_Debug := True; - exit; - end loop; - end Cont_Proc; - - Menu_Info_Instances : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("instances"), - Next => null, - Proc => Info_Instances_Proc'Access); - - Menu_Info_Psl : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("psl"), - Next => Menu_Info_Instances'Access, - Proc => Info_PSL_Proc'Access); - - Menu_Info_Stats : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("stats"), - Next => Menu_Info_Psl'Access, - Proc => Info_Stats_Proc'Access); - - Menu_Info_Tree : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("tree"), - Next => Menu_Info_Stats'Access, - Proc => Info_Tree_Proc'Access); - - Menu_Info_Params : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("param*eters"), - Next => Menu_Info_Tree'Access, - Proc => Info_Params_Proc'Access); - - Menu_Info_Subprograms : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("subp*rograms"), - Next => Menu_Info_Params'Access, - Proc => Info_Subprograms_Proc'Access); - - Menu_Info_Units : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("units"), - Next => Menu_Info_Subprograms'Access, - Proc => Info_Units_Proc'Access); - - Menu_Info_Files : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("files"), - Next => Menu_Info_Units'Access, - Proc => Info_Files_Proc'Access); - - Menu_Info_Libraries : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("lib*raries"), - Next => Menu_Info_Files'Access, - Proc => Info_Libraries_Proc'Access); - - Menu_Info_Signals : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("sig*nals"), - Next => Menu_Info_Libraries'Access, - Proc => Info_Signals_Proc'Access); - - Menu_Info_Proc : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("proc*esses"), - Next => Menu_Info_Signals'Access, - Proc => Info_Proc_Proc'Access); - - Menu_List : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("l*list"), - Next => null, - Proc => List_Proc'Access); - - Menu_Down : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("down"), - Next => Menu_List'Access, - Proc => Down_Proc'Access); - - Menu_Up : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("up"), - Next => Menu_Down'Access, - Proc => Up_Proc'Access); - - Menu_Nstmt : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("ns*tmt"), - Next => Menu_Up'Access, - Proc => Next_Stmt_Proc'Access); - - Menu_Fstmt : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("fs*tmt"), - Next => Menu_Nstmt'Access, - Proc => Finish_Stmt_Proc'Access); - - Menu_Next : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("n*ext"), - Next => Menu_Fstmt'Access, - Proc => Next_Proc'Access); - - Menu_Step : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("s*tep"), - Next => Menu_Next'Access, - Proc => Step_Proc'Access); - - Menu_Break : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("b*reak"), - Next => Menu_Step'Access, - Proc => Break_Proc'Access); - - Menu_Where : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("where"), - Next => Menu_Break'Access, - Proc => Where_Proc'Access); - - Menu_Ps : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("ps"), - Next => Menu_Where'Access, - Proc => Ps_Proc'Access); - - Menu_Info : aliased Menu_Entry := - (Kind => Menu_Submenu, - Name => new String'("i*nfo"), - Next => Menu_Ps'Access, - First | Last => Menu_Info_Proc'Access); - - Menu_Print : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("pr*int"), - Next => Menu_Info'Access, - Proc => Print_Proc'Access); - - Menu_Cont : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("c*ont"), - Next => Menu_Print'Access, - Proc => Cont_Proc'Access); - - Menu_Quit : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("q*uit"), - Next => Menu_Cont'Access, - Proc => Quit_Proc'Access); - - Menu_Help1 : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("help"), - Next => Menu_Quit'Access, - Proc => Help_Proc'Access); - - Menu_Help2 : aliased Menu_Entry := - (Kind => Menu_Command, - Name => new String'("?"), - Next => Menu_Help1'Access, - Proc => Help_Proc'Access); - - Menu_Top : aliased Menu_Entry := - (Kind => Menu_Submenu, - Name => null, - Next => null, - First | Last => Menu_Help2'Access); - - function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String) - return Menu_Entry_Acc - is - function Is_Cmd (Cmd_Name : String; Str : String) return Boolean - is - -- Number of characters that were compared. - P : Natural; - begin - P := 0; - -- Prefix (before the '*'). - loop - if P = Cmd_Name'Length then - -- Full match. - return P = Str'Length; - end if; - exit when Cmd_Name (Cmd_Name'First + P) = '*'; - if P = Str'Length then - -- Command is too short - return False; - end if; - if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then - return False; - end if; - P := P + 1; - end loop; - -- Suffix (after the '*') - loop - if P = Str'Length then - return True; - end if; - if P + 1 = Cmd_Name'Length then - -- String is too long - return False; - end if; - if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then - return False; - end if; - P := P + 1; - end loop; - end Is_Cmd; - Ent : Menu_Entry_Acc; - begin - Ent := Menu.First; - while Ent /= null loop - if Is_Cmd (Ent.Name.all, Cmd) then - return Ent; - end if; - Ent := Ent.Next; - end loop; - return null; - end Find_Menu; - - procedure Parse_Command (Line : String; - P : in out Natural; - Menu : out Menu_Entry_Acc) - is - E : Natural; - begin - P := Skip_Blanks (Line (P .. Line'Last)); - if P > Line'Last then - return; - end if; - E := Get_Word (Line (P .. Line'Last)); - Menu := Find_Menu (Menu, Line (P .. E)); - if Menu = null then - Put_Line ("command '" & Line (P .. E) & "' not found"); - end if; - P := E + 1; - end Parse_Command; - - procedure Help_Proc (Line : String) - is - P : Natural; - Root : Menu_Entry_Acc := Menu_Top'access; - begin - Put_Line ("This is the help command"); - P := Line'First; - while P < Line'Last loop - Parse_Command (Line, P, Root); - if Root = null then - return; - elsif Root.Kind /= Menu_Submenu then - Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); - return; - end if; - end loop; - - Root := Root.First; - while Root /= null loop - Put (Root.Name.all); - if Root.Kind = Menu_Submenu then - Put (" (menu)"); - end if; - New_Line; - Root := Root.Next; - end loop; - end Help_Proc; - - function Breakpoint_Hit return Natural - is - Stmt : constant Iir := Current_Process.Instance.Stmt; - begin - for I in Breakpoints.First .. Breakpoints.Last loop - if Stmt = Breakpoints.Table (I).Stmt then - return I; - end if; - end loop; - return 0; - end Breakpoint_Hit; - - Prompt_Debug : constant String := "debug> " & ASCII.NUL; - Prompt_Crash : constant String := "crash> " & ASCII.NUL; - Prompt_Init : constant String := "init> " & ASCII.NUL; - Prompt_Elab : constant String := "elab> " & ASCII.NUL; - - procedure Debug (Reason: Debug_Reason) - is - use Grt.Readline; - Raw_Line : Char_Ptr; - Prompt : System.Address; - begin - -- Unless interractive, do not use the debugger. - case Reason is - when Reason_Internal_Debug => - null; - when Reason_Assert - | Reason_Error => - if not Flag_Debugger then - return; - end if; - when Reason_Start - | Reason_Elab => - if not Flag_Interractive then - return; - end if; - when Reason_Break => - null; - end case; - - Prompt := Prompt_Debug'Address; - - case Reason is - when Reason_Start => - Set_Top_Frame (null); - Prompt := Prompt_Init'Address; - when Reason_Elab => - Set_Top_Frame (null); - Prompt := Prompt_Elab'Address; - when Reason_Internal_Debug => - if Current_Process = null then - Set_Top_Frame (null); - else - Set_Top_Frame (Current_Process.Instance); - end if; - when Reason_Break => - case Exec_State is - when Exec_Run => - if Breakpoint_Hit /= 0 then - Put_Line ("breakpoint hit"); - else - return; - end if; - when Exec_Single_Step => - null; - when Exec_Next => - if Current_Process.Instance /= Exec_Instance then - return; - end if; - when Exec_Next_Stmt => - if Current_Process.Instance /= Exec_Instance - or else Is_Within_Statement (Exec_Statement, - Current_Process.Instance.Stmt) - then - return; - end if; - end case; - -- Default state. - Exec_State := Exec_Run; - Set_Top_Frame (Current_Process.Instance); - declare - Stmt : constant Iir := Dbg_Cur_Frame.Stmt; - begin - Put ("stopped at: "); - Disp_Iir_Location (Stmt); - New_Line; - Disp_Source_Line (Get_Location (Stmt)); - end; - when Reason_Assert => - Set_Top_Frame (Current_Process.Instance); - Prompt := Prompt_Crash'Address; - Put_Line ("assertion failure, enterring in debugger"); - when Reason_Error => - Set_Top_Frame (Current_Process.Instance); - Prompt := Prompt_Crash'Address; - Put_Line ("error occurred, enterring in debugger"); - end case; - - if Dbg_Cur_Frame /= null then - Set_List_Current (Get_Location (Dbg_Cur_Frame.Stmt)); - end if; - - Command_Status := Status_Default; - - loop - loop - Raw_Line := Readline (Prompt); - -- Skip empty lines - if Raw_Line = null or else Raw_Line (1) = ASCII.NUL then - if Cmd_Repeat /= null then - Cmd_Repeat.all (""); - case Command_Status is - when Status_Default => - null; - when Status_Quit => - return; - end case; - end if; - else - Cmd_Repeat := null; - exit; - end if; - end loop; - declare - Line_Last : constant Natural := Strlen (Raw_Line); - Line : String renames Raw_Line (1 .. Line_Last); - P, E : Positive; - Cmd : Menu_Entry_Acc := Menu_Top'Access; - begin - -- Find command - P := 1; - loop - E := P; - Parse_Command (Line, E, Cmd); - exit when Cmd = null; - case Cmd.Kind is - when Menu_Submenu => - if E > Line_Last then - Put_Line ("missing command for submenu " - & Line (P .. E - 1)); - Cmd := null; - exit; - end if; - P := E; - when Menu_Command => - exit; - end case; - end loop; - - if Cmd /= null then - Cmd.Proc.all (Line (E .. Line_Last)); - - case Command_Status is - when Status_Default => - null; - when Status_Quit => - exit; - end case; - end if; - exception - when Command_Error => - null; - end; - end loop; - -- Put ("resuming"); - end Debug; - - procedure Debug_Error is - begin - Debug (Reason_Error); - end Debug_Error; -end Debugger; diff --git a/src/vhdl/simulate/debugger.ads b/src/vhdl/simulate/debugger.ads deleted file mode 100644 index ecb170eaa..000000000 --- a/src/vhdl/simulate/debugger.ads +++ /dev/null @@ -1,91 +0,0 @@ --- Debugger for interpreter --- 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 Iirs; use Iirs; -with Iir_Values; use Iir_Values; - -package Debugger is - Flag_Debugger : Boolean := False; - Flag_Interractive : Boolean := False; - - Flag_Need_Debug : Boolean := False; - - -- Disp a message for a constraint error. - -- And raise the exception execution_constraint_error. - procedure Error_Msg_Constraint (Expr: Iir); - pragma No_Return (Error_Msg_Constraint); - - -- Disp a message during execution. - procedure Error_Msg_Exec (Msg: String; Loc: Iir); - pragma No_Return (Error_Msg_Exec); - - procedure Warning_Msg_Exec (Msg: String; Loc: Iir); - - -- Disp a block instance, in a human readable way. - -- Used to debug. - procedure Disp_Block_Instance (Instance: Block_Instance_Acc); - - -- Disp the instance tree. - procedure Disp_Instances_Tree; - - -- Disp the name of an instance, without newline. The name of - -- architectures is displayed unless Short is True. - procedure Disp_Instance_Name (Instance: Block_Instance_Acc; - Short : Boolean := False); - - -- Disp the resulting processes of elaboration. - -- procedure Disp_Processes; - - -- Disp the label of PROCESS, or if PROCESS has no label. - procedure Disp_Label (Process : Iir); - - -- Disp all signals name and values. - procedure Disp_Signals_Value; - - -- Disp stats about the design (number of process, number of signals...) - procedure Disp_Design_Stats; - - -- The reason why the debugger is invoked. - type Debug_Reason is - (-- Called from an external debugger while debugging ghdl. - Reason_Internal_Debug, - - -- Interractive session, elaboration not done - Reason_Start, - - -- At end of elaboration, for an interractive session - Reason_Elab, - - -- Before execution of a statement. - Reason_Break, - - -- Assertion failure - Reason_Assert, - - -- Non recoverable error occurred (such as index error, overflow...) - Reason_Error - ); - - Debugger_Quit : exception; - - -- Interractive debugger. - procedure Debug (Reason: Debug_Reason); - - -- Call the debugger in case of error. - procedure Debug_Error; -end Debugger; diff --git a/src/vhdl/simulate/elaboration-ams.adb b/src/vhdl/simulate/elaboration-ams.adb deleted file mode 100644 index de4edc980..000000000 --- a/src/vhdl/simulate/elaboration-ams.adb +++ /dev/null @@ -1,199 +0,0 @@ --- Interpreter AMS 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 Errorout; use Errorout; -with Execution; - -package body Elaboration.AMS is - function Create_Characteristic_Expression - (Kind : Characteristic_Expr_Kind) return Characteristic_Expressions_Index - is - begin - case Kind is - when Contribution => - Characteristic_Expressions.Append - ((Kind => Contribution, - Expr => null, - Tolerance => 0, - Dependencies => null)); - when others => - raise Program_Error; - end case; - return Characteristic_Expressions.Last; - end Create_Characteristic_Expression; - - function Create_Scalar_Quantity (Kind : Quantity_Kind; - Decl : Iir; - Instance : Block_Instance_Acc) - return Quantity_Index_Type - is - begin - case Kind is - when Quantity_Reference => - Scalar_Quantities.Append - ((Kind => Quantity_Reference, - Value => 0.0, - Decl => Decl, - Instance => Instance, - Contribution => - Create_Characteristic_Expression (Contribution))); - when Quantity_Across => - Scalar_Quantities.Append - ((Kind => Quantity_Across, - Value => 0.0, - Decl => Decl, - Instance => Instance)); - when Quantity_Through => - Scalar_Quantities.Append - ((Kind => Quantity_Through, - Value => 0.0, - Decl => Decl, - Instance => Instance)); - when others => - raise Program_Error; - end case; - return Scalar_Quantities.Last; - end Create_Scalar_Quantity; - - function Create_Scalar_Terminal (Decl : Iir; - Instance : Block_Instance_Acc) - return Terminal_Index_Type - is - begin - -- Simply create the reference quantity for a terminal - return Terminal_Index_Type - (Create_Scalar_Quantity (Quantity_Reference, Decl, Instance)); - end Create_Scalar_Terminal; - - function Get_Terminal_Reference (Terminal : Terminal_Index_Type) - return Quantity_Index_Type is - begin - return Quantity_Index_Type (Terminal); - end Get_Terminal_Reference; - - procedure Add_Characteristic_Expression - (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc) - is - begin - Characteristic_Expressions.Append - ((Kind => Kind, - Expr => Expr, - Tolerance => Default_Tolerance_Index, - Dependencies => null)); - end Add_Characteristic_Expression; - - procedure Compute_Dependencies (Idx : Characteristic_Expressions_Index) - is - package Quantity_Table is new Tables - (Table_Component_Type => Quantity_Index_Type, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 16); - - El : Characteristic_Expr renames Characteristic_Expressions.Table (Idx); - Res : Quantity_Dependency_Acc := null; - - procedure Add_Dependency (Block : Block_Instance_Acc; N : Iir) - is - Q : Iir_Value_Literal_Acc; - begin - case Get_Kind (N) is - when Iir_Kinds_Branch_Quantity_Declaration => - Q := Execution.Execute_Name (Block, N, True); - Quantity_Table.Append (Q.Quantity); - when Iir_Kind_Simple_Name => - Add_Dependency (Block, Get_Named_Entity (N)); - when Iir_Kinds_Dyadic_Operator => - Add_Dependency (Block, Get_Left (N)); - Add_Dependency (Block, Get_Right (N)); - when Iir_Kinds_Literal => - null; - when others => - Error_Kind ("compute_dependencies", N); - end case; - end Add_Dependency; - - Term : Ams_Term_Acc := El.Expr; - begin - pragma Assert (El.Dependencies = null); - - while Term /= null loop - case Term.Op is - when Op_Quantity => - Quantity_Table.Append (Term.Quantity); - when Op_Vhdl_Expr => - Add_Dependency (Term.Vhdl_Instance, Term.Vhdl_Expr); - end case; - Term := Term.Next; - end loop; - Res := new Quantity_Dependency_Type (Nbr => Quantity_Table.Last); - for I in Quantity_Table.First .. Quantity_Table.Last loop - Res.Quantities (I) := Quantity_Table.Table (I); - end loop; - Quantity_Table.Free; - El.Dependencies := Res; - end Compute_Dependencies; - - function Build (Op : Ams_Sign; - Val : Quantity_Index_Type; - Right : Ams_Term_Acc := null) - return Ams_Term_Acc - is - begin - return new Ams_Term'(Op => Op_Quantity, - Sign => Op, - Next => Right, - Quantity => Val); - end Build; - - function Build (Op : Ams_Sign; - Instance : Block_Instance_Acc; - Expr : Iir; - Right : Ams_Term_Acc := null) - return Ams_Term_Acc - is - begin - return new Ams_Term' - (Op => Op_Vhdl_Expr, - Sign => Op, - Vhdl_Expr => Expr, - Vhdl_Instance => Instance, - Next => Right); - end Build; - - procedure Append_Characteristic_Expression - (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc) - is - Ref : constant Quantity_Index_Type := Get_Terminal_Reference (Terminal); - Ce : constant Characteristic_Expressions_Index := - Scalar_Quantities.Table (Ref).Contribution; - begin - pragma Assert (Expr.Next = null); - Expr.Next := Characteristic_Expressions.Table (Ce).Expr; - Characteristic_Expressions.Table (Ce).Expr := Expr; - end Append_Characteristic_Expression; - - procedure Create_Tables is - begin - for I in Characteristic_Expressions.First - .. Characteristic_Expressions.Last - loop - Compute_Dependencies (I); - end loop; - end Create_Tables; -end Elaboration.AMS; diff --git a/src/vhdl/simulate/elaboration-ams.ads b/src/vhdl/simulate/elaboration-ams.ads deleted file mode 100644 index f4c295a97..000000000 --- a/src/vhdl/simulate/elaboration-ams.ads +++ /dev/null @@ -1,163 +0,0 @@ --- Interpreter AMS 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 Tables; - -package Elaboration.AMS is - -- AMS expressions - -- - -- At many places during elaboration, the LRM defines characteristic - -- expressions that aren't present in source code: - -- * contribution expression (12.3.1.4) - -- * characteristic expression for an across quantity declaration - -- (12.3.1.4) - -- * characteristic expression for simple simultaneous statement (the - -- expression is in the source in that case) (15.1) - -- - -- They are represented using a list of Ams_Expression elements. The value - -- is the sum of each element, using the + or - sign. - - type Ams_Sign is (Op_Plus, Op_Minus); - -- Sign for the operand - - type Ams_Operand is (Op_Quantity, Op_Vhdl_Expr); - -- The operand is one of: - -- Op_Quantity: a quantity - -- Op_Vhdl_Expr: an expression from the design. This expression may contain - -- quantities - - type Ams_Term; - type Ams_Term_Acc is access Ams_Term; - -- A term of a characteristic expression - - type Characteristic_Expr_Kind is - (Explicit, - Contribution, - Structural); - - type Tolerance_Index_Type is new Natural; - Default_Tolerance_Index : constant Tolerance_Index_Type := 0; - -- Tolerance - - type Characteristic_Expressions_Index is new Natural; - - type Quantity_Kind is - (Quantity_Reference, - -- The potential of a terminal. This is an across quantity between the - -- terminal and the reference terminal of the nature. - - Quantity_Across, - Quantity_Through, - Quantity_Free - -- Explicitly declared quantities - ); - - function Create_Scalar_Quantity (Kind : Quantity_Kind; - Decl : Iir; - Instance : Block_Instance_Acc) - return Quantity_Index_Type; - -- Create a new scalar quantity - - function Create_Scalar_Terminal (Decl : Iir; - Instance : Block_Instance_Acc) - return Terminal_Index_Type; - -- Create a new scalar terminal - - function Get_Terminal_Reference (Terminal : Terminal_Index_Type) - return Quantity_Index_Type; - -- Get the reference quantity of a terminal - - procedure Add_Characteristic_Expression - (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc); - -- Add a new characteristic expression - - function Build (Op : Ams_Sign; - Val : Quantity_Index_Type; - Right : Ams_Term_Acc := null) - return Ams_Term_Acc; - function Build (Op : Ams_Sign; - Instance : Block_Instance_Acc; - Expr : Iir; - Right : Ams_Term_Acc := null) - return Ams_Term_Acc; - -- Build a term of a characteristic expression - - procedure Append_Characteristic_Expression - (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc); - -- Append an expression to the contribution of a terminal - - procedure Create_Tables; - - type Quantity_Index_Array is array (Positive range <>) - of Quantity_Index_Type; - - type Quantity_Dependency_Type (Nbr : Natural); - type Quantity_Dependency_Acc is access Quantity_Dependency_Type; - - type Quantity_Dependency_Type (Nbr : Natural) is record - Quantities : Quantity_Index_Array (1 .. Nbr); - end record; - - type Ams_Term (Op : Ams_Operand) is record - Sign : Ams_Sign; - Next : Ams_Term_Acc; - - case Op is - when Op_Quantity => - Quantity : Quantity_Index_Type; - when Op_Vhdl_Expr => - Vhdl_Expr : Iir; - Vhdl_Instance : Block_Instance_Acc; - end case; - end record; - - type Characteristic_Expr is record - Kind : Characteristic_Expr_Kind; - Expr : Ams_Term_Acc; - Tolerance : Tolerance_Index_Type; - Dependencies : Quantity_Dependency_Acc; - end record; - - package Characteristic_Expressions is new Tables - (Table_Index_Type => Characteristic_Expressions_Index, - Table_Component_Type => Characteristic_Expr, - Table_Low_Bound => 1, - Table_Initial => 128); - - type Scalar_Quantity (Kind : Quantity_Kind := Quantity_Reference) is record - Value : Ghdl_F64; - -- The value of the quantity - - Decl : Iir; - Instance : Block_Instance_Acc; - -- Declaration for the quantity - - case Kind is - when Quantity_Reference => - Contribution : Characteristic_Expressions_Index; - when others => - null; - end case; - end record; - - package Scalar_Quantities is new Tables - (Table_Index_Type => Quantity_Index_Type, - Table_Component_Type => Scalar_Quantity, - Table_Low_Bound => 1, - Table_Initial => 128); -end Elaboration.AMS; diff --git a/src/vhdl/simulate/elaboration.adb b/src/vhdl/simulate/elaboration.adb deleted file mode 100644 index a2700cb6b..000000000 --- a/src/vhdl/simulate/elaboration.adb +++ /dev/null @@ -1,2979 +0,0 @@ --- Elaboration --- 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.Text_IO; -with Str_Table; -with Errorout; use Errorout; -with Evaluation; -with Execution; use Execution; -with Iirs_Utils; use Iirs_Utils; -with Libraries; -with Name_Table; -with File_Operation; -with Iir_Chains; use Iir_Chains; -with Elaboration.AMS; use Elaboration.AMS; -with Areapools; use Areapools; -with Grt.Errors; -with Grt.Options; - -package body Elaboration is - - procedure Elaborate_Dependence (Design_Unit: Iir_Design_Unit); - - procedure Elaborate_Statement_Part - (Instance : Block_Instance_Acc; Stmt_Chain: Iir); - procedure Elaborate_Type_Definition - (Instance : Block_Instance_Acc; Def : Iir); - procedure Elaborate_Nature_Definition - (Instance : Block_Instance_Acc; Def : Iir); - - function Elaborate_Default_Value - (Instance : Block_Instance_Acc; Decl : Iir) - return Iir_Value_Literal_Acc; - - procedure Elaborate_Generic_Clause - (Instance : Block_Instance_Acc; Generic_Chain : Iir); - procedure Elaborate_Generic_Map_Aspect - (Target_Instance : Block_Instance_Acc; - Local_Instance : Block_Instance_Acc; - Generics : Iir; - Map : Iir); - - -- CONF is the block_configuration for components of ARCH. - function Elaborate_Architecture (Arch : Iir_Architecture_Body; - Conf : Iir_Block_Configuration; - Parent_Instance : Block_Instance_Acc; - Stmt : Iir; - Generic_Map : Iir; - Port_Map : Iir) - return Block_Instance_Acc; - - procedure Create_Object - (Instance : Block_Instance_Acc; - Slot : Object_Slot_Type; - Num : Object_Slot_Type := 1) is - begin - -- Check elaboration order. - -- Note: this is not done for package since objects from package are - -- commons (same scope), and package annotation order can be different - -- from package elaboration order (eg: body). - if Slot /= Instance.Elab_Objects + 1 - or else Instance.Objects (Slot) /= null - then - Error_Msg_Elab ("bad elaboration order"); - raise Internal_Error; - end if; - Instance.Elab_Objects := Slot + Num - 1; - end Create_Object; - - procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir) - is - Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; - begin - Create_Object (Instance, Slot, 1); - end Create_Object; - - procedure Destroy_Object (Instance : Block_Instance_Acc; Decl : Iir) - is - Info : constant Sim_Info_Acc := Get_Info (Decl); - Slot : constant Object_Slot_Type := Info.Slot; - begin - if Slot /= Instance.Elab_Objects - or else Info.Obj_Scope /= Instance.Block_Scope - then - Error_Msg_Elab ("bad destroy order"); - raise Internal_Error; - end if; - -- Clear the slot (this is necessary for ranges). - Instance.Objects (Slot) := null; - Instance.Elab_Objects := Slot - 1; - end Destroy_Object; - - procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir) - is - Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; - begin - Create_Object (Instance, Slot, 2); - end Create_Signal; - - -- Create a new signal, using DEFAULT as initial value. - -- Set its number. - procedure Elaborate_Signal (Block: Block_Instance_Acc; - Signal: Iir; - Default : Iir_Value_Literal_Acc) - is - function Create_Signal (Lit: Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Lit.Kind is - when Iir_Value_Array => - Res := Create_Array_Value (Lit.Val_Array.Len, - Lit.Bounds.Nbr_Dims); - Res.Bounds.D := Lit.Bounds.D; - Res := Unshare_Bounds (Res, Global_Pool'Access); - - for I in Lit.Val_Array.V'Range loop - Res.Val_Array.V (I) := Create_Signal (Lit.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - Res := Create_Record_Value - (Lit.Val_Record.Len, Instance_Pool); - for I in Lit.Val_Record.V'Range loop - Res.Val_Record.V (I) := Create_Signal (Lit.Val_Record.V (I)); - end loop; - - when Iir_Value_Scalars => - Res := Create_Signal_Value (null); - - when Iir_Value_Signal - | Iir_Value_Range - | Iir_Value_File - | Iir_Value_Access - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - return Res; - end Create_Signal; - - Sig : Iir_Value_Literal_Acc; - Def : Iir_Value_Literal_Acc; - Slot : constant Object_Slot_Type := Get_Info (Signal).Slot; - begin - Sig := Create_Signal (Default); - Def := Unshare (Default, Global_Pool'Access); - Block.Objects (Slot) := Sig; - Block.Objects (Slot + 1) := Def; - - case Get_Kind (Signal) is - when Iir_Kind_Interface_Signal_Declaration => - case Get_Mode (Signal) is - when Iir_Unknown_Mode => - raise Internal_Error; - when Iir_Linkage_Mode => - Signals_Table.Append ((Mode_Linkage, - Signal, Sig, Def, Block)); - when Iir_Buffer_Mode => - Signals_Table.Append ((Mode_Buffer, - Signal, Sig, Def, Block)); - when Iir_Out_Mode => - Signals_Table.Append ((Mode_Out, - Signal, Sig, Def, Block)); - when Iir_Inout_Mode => - Signals_Table.Append ((Mode_Inout, - Signal, Sig, Def, Block)); - when Iir_In_Mode => - Signals_Table.Append ((Mode_In, - Signal, Sig, Def, Block)); - end case; - when Iir_Kind_Signal_Declaration => - Signals_Table.Append ((Mode_Signal, Signal, Sig, Def, Block)); - when others => - Error_Kind ("elaborate_signal", Signal); - end case; - end Elaborate_Signal; - - function Execute_Time_Attribute (Instance : Block_Instance_Acc; Attr : Iir) - return Ghdl_I64 - is - Param : constant Iir := Get_Parameter (Attr); - Res : Ghdl_I64; - Val : Iir_Value_Literal_Acc; - begin - if Param = Null_Iir then - Res := 0; - else - Val := Execute_Expression (Instance, Param); - Res := Val.I64; - end if; - return Res; - end Execute_Time_Attribute; - - procedure Elaborate_Implicit_Signal - (Instance: Block_Instance_Acc; Signal: Iir; Kind : Mode_Signal_Type) - is - Info : constant Sim_Info_Acc := Get_Info (Signal); - Prefix : Iir_Value_Literal_Acc; - T : Ghdl_I64; - Sig : Iir_Value_Literal_Acc; - Init : Iir_Value_Literal_Acc; - begin - if Kind = Mode_Transaction then - T := 0; - Init := Create_B1_Value (False); - else - T := Execute_Time_Attribute (Instance, Signal); - Init := Create_B1_Value (False); - end if; - Create_Signal (Instance, Signal); - Sig := Create_Signal_Value (null); - Init := Unshare (Init, Global_Pool'Access); - Instance.Objects (Info.Slot) := Sig; - Instance.Objects (Info.Slot + 1) := Init; - - Prefix := Execute_Name (Instance, Get_Prefix (Signal), True); - Prefix := Unshare_Bounds (Prefix, Global_Pool'Access); - case Kind is - when Mode_Stable => - Signals_Table.Append ((Kind => Mode_Stable, - Decl => Signal, - Sig => Sig, - Val => Init, - Instance => Instance, - Time => Std_Time (T), - Prefix => Prefix)); - when Mode_Quiet => - Signals_Table.Append ((Kind => Mode_Quiet, - Decl => Signal, - Sig => Sig, - Val => Init, - Instance => Instance, - Time => Std_Time (T), - Prefix => Prefix)); - when Mode_Transaction => - Signals_Table.Append ((Kind => Mode_Transaction, - Decl => Signal, - Sig => Sig, - Val => Init, - Instance => Instance, - Time => 0, - Prefix => Prefix)); - when others => - raise Internal_Error; - end case; - end Elaborate_Implicit_Signal; - - function Create_Delayed_Signal (Pfx : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Pfx.Kind is - when Iir_Value_Array => - Res := Create_Array_Value (Pfx.Val_Array.Len, - Pfx.Bounds.Nbr_Dims, - Global_Pool'Access); - Res.Bounds.D := Pfx.Bounds.D; - - for I in Pfx.Val_Array.V'Range loop - Res.Val_Array.V (I) := Create_Delayed_Signal - (Pfx.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - Res := Create_Record_Value (Pfx.Val_Record.Len, - Global_Pool'Access); - for I in Pfx.Val_Record.V'Range loop - Res.Val_Record.V (I) := Create_Delayed_Signal - (Pfx.Val_Record.V (I)); - end loop; - when Iir_Value_Signal => - Res := Create_Signal_Value (null); - when others => - raise Internal_Error; - end case; - return Res; - end Create_Delayed_Signal; - - procedure Elaborate_Delayed_Signal - (Instance: Block_Instance_Acc; Signal: Iir) - is - Info : constant Sim_Info_Acc := Get_Info (Signal); - Prefix : Iir_Value_Literal_Acc; - Sig : Iir_Value_Literal_Acc; - Init : Iir_Value_Literal_Acc; - T : Ghdl_I64; - begin - Prefix := Execute_Name (Instance, Get_Prefix (Signal), True); - Prefix := Unshare_Bounds (Prefix, Global_Pool'Access); - - T := Execute_Time_Attribute (Instance, Signal); - - Sig := Create_Delayed_Signal (Prefix); - Create_Signal (Instance, Signal); - Instance.Objects (Info.Slot) := Sig; - - Init := Execute_Signal_Init_Value (Instance, Get_Prefix (Signal)); - Init := Unshare (Init, Global_Pool'Access); -- Create a full copy. - Instance.Objects (Info.Slot + 1) := Init; - - Signals_Table.Append ((Kind => Mode_Delayed, - Decl => Signal, - Sig => Sig, - Val => Init, - Instance => Instance, - Time => Std_Time (T), - Prefix => Prefix)); - end Elaborate_Delayed_Signal; - - -- Create a block instance to instantiate OBJ (block, component, - -- architecture, generate) in FATHER. STMT is the statement/declaration - -- at the origin of the instantiation (it is generally the same as OBJ, - -- except for component where STMT is the component instantation - -- statement). - function Create_Block_Instance - (Father : Block_Instance_Acc; - Obj : Iir; - Stmt : Iir) - return Block_Instance_Acc - is - Obj_Info : constant Sim_Info_Acc := Get_Info (Obj); - Res : Block_Instance_Acc; - begin - Nbr_Block_Instances := Nbr_Block_Instances + 1; - - Res := new Block_Instance_Type' - (Max_Objs => Obj_Info.Nbr_Objects, - Id => Nbr_Block_Instances, - Block_Scope => Obj_Info.Frame_Scope, - Up_Block => Father, - Label => Stmt, - Stmt => Obj, - Parent => Father, - Children => null, - Brother => null, - Ports_Map => Null_Iir, - Marker => Empty_Marker, - Objects => (others => null), - Elab_Objects => 0, - In_Wait_Flag => False, - Actuals_Ref => null, - Result => null); - - if Father /= null then - case Obj_Info.Kind is - when Kind_Block - | Kind_Process => - Res.Brother := Father.Children; - Father.Children := Res; - when others => - null; - end case; - end if; - - return Res; - end Create_Block_Instance; - - procedure Elaborate_Package (Decl: Iir) - is - Package_Info : constant Sim_Info_Acc := Get_Info (Decl); - Instance : Block_Instance_Acc; - begin - Instance := Create_Block_Instance (null, Decl, Decl); - - Package_Instances (Package_Info.Frame_Scope.Pkg_Index) := Instance; - - if Trace_Elaboration then - Report_Msg (Msgid_Note, Errorout.Elaboration, No_Location, - "elaborating %n", (1 => +Decl)); - end if; - - if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then - Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Decl)); - Elaborate_Generic_Map_Aspect - (Instance, Instance, - Get_Generic_Chain (Decl), - Get_Generic_Map_Aspect_Chain (Decl)); - end if; - - -- Elaborate objects declarations. - Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); - - if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then - -- Elaborate the body now. - declare - Uninst : constant Iir := Get_Uninstantiated_Package_Decl (Decl); - begin - Elaborate_Declarative_Part - (Instance, Get_Declaration_Chain (Get_Package_Body (Uninst))); - end; - end if; - end Elaborate_Package; - - procedure Elaborate_Package_Body (Decl: Iir) - is - Package_Info : constant Sim_Info_Acc := Get_Info (Decl); - Instance : Block_Instance_Acc; - begin - Instance := Package_Instances (Package_Info.Frame_Scope.Pkg_Index); - - if Trace_Elaboration then - Report_Msg (Msgid_Note, Errorout.Elaboration, No_Location, - "elaborating %n", (1 => +Decl)); - end if; - - -- Elaborate objects declarations. - Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); - end Elaborate_Package_Body; - - procedure Elaborate_Configuration_Declaration (Decl : Iir) - is - Config_Info : constant Sim_Info_Acc := Get_Info (Decl); - Instance : Block_Instance_Acc; - begin - if Config_Info = null then - -- Not a user defined configuration. No objects. - pragma Assert (Get_Identifier (Decl) = Null_Identifier); - return; - end if; - - Instance := Create_Block_Instance (null, Decl, Decl); - - Package_Instances (Config_Info.Frame_Scope.Pkg_Index) := Instance; - - -- Elaborate objects declarations. - Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); - end Elaborate_Configuration_Declaration; - - -- Elaborate all packages which DESIGN_UNIT depends on. - -- The packages are elaborated only once. The body, if the package needs - -- one, can be loaded during the elaboration. - -- Recursive function. - -- FIXME: handle pathological cases of recursion. - -- Due to the rules of analysis, it is not possible to have a circulare - -- dependence. - procedure Elaborate_Dependence (Design_Unit: Iir_Design_Unit) - is - Depend_List : constant Iir_List := Get_Dependence_List (Design_Unit); - Depend_It : List_Iterator; - Design: Iir; - Library_Unit: Iir; - begin - Depend_It := List_Iterate_Safe (Depend_List); - while Is_Valid (Depend_It) loop - Design := Get_Element (Depend_It); - if Get_Kind (Design) = Iir_Kind_Entity_Aspect_Entity then - -- During Sem, the architecture may be still unknown, and the - -- dependency is therefore the aspect. - Library_Unit := Strip_Denoting_Name (Get_Architecture (Design)); - case Get_Kind (Library_Unit) is - when Iir_Kind_Architecture_Body => - Design := Get_Design_Unit (Library_Unit); - when Iir_Kind_Design_Unit => - Design := Library_Unit; - Library_Unit := Get_Library_Unit (Design); - when others => - Error_Kind ("elaborate_dependence(1)", Library_Unit); - end case; - else - Library_Unit := Get_Library_Unit (Design); - end if; - -- Elaborates only non-elaborated packages. - case Get_Kind (Library_Unit) is - when Iir_Kind_Package_Declaration => - declare - Info : constant Sim_Info_Acc := Get_Info (Library_Unit); - Body_Design: Iir_Design_Unit; - begin - if not Is_Uninstantiated_Package (Library_Unit) - and then - Package_Instances (Info.Frame_Scope.Pkg_Index) = null - then - -- Package not yet elaborated. - - -- Load the body now, as it can add objects in the - -- package instance. - -- Don't try to load optionnal but obsolete package body. - Body_Design := Libraries.Find_Secondary_Unit - (Design, Null_Identifier); - if Body_Design /= Null_Iir - and then - (Get_Need_Body (Library_Unit) - or else Get_Date (Body_Design) /= Date_Obsolete) - then - Libraries.Load_Design_Unit (Body_Design, Design_Unit); - else - Body_Design := Null_Iir; - end if; - - -- First the packages on which DESIGN depends. - Elaborate_Dependence (Design); - - -- Then the declaration. - Elaborate_Package (Library_Unit); - - -- And then the body (if any). - if Body_Design = Null_Iir then - if Get_Need_Body (Library_Unit) then - Error_Msg_Elab - ("no package body for `" & - Image_Identifier (Library_Unit) & '''); - end if; - else - -- Note: the body can elaborate some packages. - Elaborate_Dependence (Body_Design); - - Elaborate_Package_Body - (Get_Library_Unit (Body_Design)); - end if; - end if; - end; - when Iir_Kind_Package_Instantiation_Declaration => - declare - Info : constant Sim_Info_Acc := Get_Info (Library_Unit); - begin - if Package_Instances (Info.Frame_Scope.Pkg_Index) = null - then - -- Package not yet elaborated. - - -- First the packages on which DESIGN depends. - Elaborate_Dependence (Design); - - -- Then the declaration. - Elaborate_Package (Library_Unit); - end if; - end; - when Iir_Kind_Entity_Declaration - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Architecture_Body => - Elaborate_Dependence (Design); - when Iir_Kind_Package_Body => - -- For package instantiation. - Elaborate_Dependence (Design); - when Iir_Kind_Context_Declaration => - Elaborate_Dependence (Design); - when others => - Error_Kind ("elaborate_dependence", Library_Unit); - end case; - Next (Depend_It); - end loop; - end Elaborate_Dependence; - - function Create_Protected_Object (Block: Block_Instance_Acc; Decl: Iir) - return Iir_Value_Literal_Acc - is - Bod : constant Iir := Get_Protected_Type_Body (Decl); - Inst : Block_Instance_Acc; - Res : Iir_Value_Literal_Acc; - begin - Protected_Table.Increment_Last; - Res := Create_Protected_Value (Protected_Table.Last); - - Inst := Create_Subprogram_Instance (Block, null, Bod); - Protected_Table.Table (Res.Prot) := Inst; - - -- Temporary put the instancce on the stack in case of function calls - -- during the elaboration of the protected object. - Current_Process.Instance := Inst; - - Elaborate_Declarative_Part (Inst, Get_Declaration_Chain (Bod)); - - Current_Process.Instance := Block; - - return Res; - end Create_Protected_Object; - - -- Create an value_literal for DECL (defined in BLOCK) and set it with - -- its default values. Nodes are shared. - function Create_Value_For_Type - (Block: Block_Instance_Acc; Decl: Iir; Init : Init_Value_Kind) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - Bounds : Iir_Value_Literal_Acc; - begin - case Get_Kind (Decl) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Integer_Type_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Floating_Type_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Physical_Type_Definition => - case Init is - when Init_Value_Default => - Bounds := Execute_Bounds (Block, Decl); - Res := Bounds.Left; - when Init_Value_Any => - case Iir_Value_Scalars - (Get_Info (Get_Base_Type (Decl)).Scalar_Mode) - is - when Iir_Value_B1 => - Res := Create_B1_Value (False); - when Iir_Value_E8 => - Res := Create_E8_Value (0); - when Iir_Value_E32 => - Res := Create_E32_Value (0); - when Iir_Value_I64 => - Res := Create_I64_Value (0); - when Iir_Value_F64 => - Res := Create_F64_Value (0.0); - end case; - when Init_Value_Signal => - Res := Create_Signal_Value (null); - end case; - - when Iir_Kind_Array_Subtype_Definition => - Res := Create_Array_Bounds_From_Type (Block, Decl, True); - declare - El_Type : constant Iir := Get_Element_Subtype (Decl); - El_Val : Iir_Value_Literal_Acc; - begin - if Res.Val_Array.Len > 0 then - -- Aliases the elements, for speed. If modified, the - -- value will first be copied which will unalias it. - El_Val := Create_Value_For_Type (Block, El_Type, Init); - for I in 1 .. Res.Val_Array.Len loop - Res.Val_Array.V (I) := El_Val; - end loop; - end if; - end; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Decl)); - El : Iir_Element_Declaration; - begin - Res := Create_Record_Value - (Iir_Index32 (Get_Nbr_Elements (List))); - - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Res.Val_Record.V (1 + Get_Element_Position (El)) := - Create_Value_For_Type (Block, Get_Type (El), Init); - end loop; - end; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - return Create_Access_Value (null); - when Iir_Kind_Protected_Type_Declaration => - return Create_Protected_Object (Block, Decl); - when others => - Error_Kind ("create_value_for_type", Decl); - end case; - return Res; - end Create_Value_For_Type; - - procedure Init_To_Default - (Targ : Iir_Value_Literal_Acc; Block: Block_Instance_Acc; Atype : Iir) is - begin - case Get_Kind (Atype) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Integer_Type_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Floating_Type_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Physical_Type_Definition => - declare - Bounds : Iir_Value_Literal_Acc; - begin - Bounds := Execute_Bounds (Block, Atype); - Store (Targ, Bounds.Left); - end; - - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - declare - El_Type : constant Iir := Get_Element_Subtype (Atype); - begin - for I in 1 .. Targ.Val_Array.Len loop - Init_To_Default (Targ.Val_Array.V (I), Block, El_Type); - end loop; - end; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Atype)); - El : Iir_Element_Declaration; - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Init_To_Default (Targ.Val_Record.V (1 + Iir_Index32 (I)), - Block, Get_Type (El)); - end loop; - end; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - Store (Targ, Null_Lit); - when others => - Error_Kind ("Init_To_Default", Atype); - end case; - end Init_To_Default; - - function Create_Terminal_Object (Block: Block_Instance_Acc; - Decl : Iir; - Def: Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Get_Kind (Def) is - when Iir_Kind_Scalar_Nature_Definition => - Res := Create_Terminal_Value - (Create_Scalar_Terminal (Decl, Block)); - when others => - Error_Kind ("create_terminal_object", Def); - end case; - return Res; - end Create_Terminal_Object; - - procedure Create_Terminal (Instance : Block_Instance_Acc; Decl : Iir) - is - Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; - begin - if Slot + 1 = Instance.Elab_Objects then - -- Reference terminal of nature declaration may have already been - -- elaborated. - return; - end if; - if Slot /= Instance.Elab_Objects then - Error_Msg_Elab ("bad elaboration order"); - raise Internal_Error; - end if; - Instance.Objects (Slot) := - Create_Terminal_Object (Instance, Decl, Get_Nature (Decl)); - Instance.Elab_Objects := Slot + 1; - end Create_Terminal; - - function Create_Quantity_Object (Block: Block_Instance_Acc; - Decl : Iir; - Def: Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - Kind : Quantity_Kind; - begin - case Get_Kind (Def) is - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - case Iir_Kinds_Quantity_Declaration (Get_Kind (Decl)) is - when Iir_Kind_Across_Quantity_Declaration => - Kind := Quantity_Across; - when Iir_Kind_Through_Quantity_Declaration => - Kind := Quantity_Through; - when Iir_Kind_Free_Quantity_Declaration => - Kind := Quantity_Free; - end case; - Res := Create_Quantity_Value - (Create_Scalar_Quantity (Kind, Decl, Block)); - when others => - Error_Kind ("create_quantity_object", Def); - end case; - return Res; - end Create_Quantity_Object; - - function Create_Quantity (Instance : Block_Instance_Acc; Decl : Iir) - return Iir_Value_Literal_Acc - is - Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; - Res : Iir_Value_Literal_Acc; - begin - if Slot /= Instance.Elab_Objects then - Error_Msg_Elab ("bad elaboration order"); - raise Internal_Error; - end if; - Res := Create_Quantity_Object (Instance, Decl, Get_Type (Decl)); - Instance.Objects (Slot) := Res; - Instance.Elab_Objects := Slot + 1; - return Res; - end Create_Quantity; - - procedure Elaborate_Range_Expression - (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression) - is - Range_Info : constant Sim_Info_Acc := Get_Info (Rc); - Val : Iir_Value_Literal_Acc; - begin - if Range_Info.Obj_Scope /= Instance.Block_Scope - or else Instance.Objects (Range_Info.Slot) /= null - then - -- A range expression may have already been created, for example - -- when severals objects are created with the same subtype: - -- variable v, v1 : bit_vector (x to y); - return; - end if; - if False - and then (Range_Info.Obj_Scope /= Instance.Block_Scope - or else Range_Info.Slot < Instance.Elab_Objects) - then - -- FIXME: the test is wrong for packages. - -- The range was already elaborated. - -- ?? Is that possible - raise Internal_Error; - return; - end if; - Create_Object (Instance, Rc); - Val := Create_Range_Value - (Execute_Expression (Instance, Get_Left_Limit (Rc)), - Execute_Expression (Instance, Get_Right_Limit (Rc)), - Get_Direction (Rc)); - -- Check constraints. - if not Is_Null_Range (Val) then - Check_Constraints (Instance, Val.Left, Get_Type (Rc), Rc); - Check_Constraints (Instance, Val.Right, Get_Type (Rc), Rc); - end if; - Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool); - end Elaborate_Range_Expression; - - procedure Elaborate_Range_Constraint - (Instance : Block_Instance_Acc; Rc: Iir) is - begin - case Get_Kind (Rc) is - when Iir_Kind_Range_Expression => - Elaborate_Range_Expression (Instance, Rc); - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - null; - when others => - Error_Kind ("elaborate_range_constraint", Rc); - end case; - end Elaborate_Range_Constraint; - - -- Create the bounds of a scalar type definition. - -- Elaborate_Range_Constraint cannot be used, as it checks bounds (and - -- here we create the bounds). - procedure Elaborate_Type_Range - (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression) - is - Range_Info : Sim_Info_Acc; - Val : Iir_Value_Literal_Acc; - begin - Range_Info := Get_Info (Rc); - Create_Object (Instance, Rc); - Val := Create_Range_Value - (Execute_Expression (Instance, Get_Left_Limit (Rc)), - Execute_Expression (Instance, Get_Right_Limit (Rc)), - Get_Direction (Rc)); - Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool); - end Elaborate_Type_Range; - - -- DECL is a subtype indication. - -- Elaborate DECL only if it is anonymous. - procedure Elaborate_Subtype_Indication_If_Anonymous - (Instance : Block_Instance_Acc; Decl : Iir) is - begin - if Is_Anonymous_Type_Definition (Decl) then - Elaborate_Subtype_Indication (Instance, Decl); - end if; - end Elaborate_Subtype_Indication_If_Anonymous; - - -- LRM93 §12.3.1.3 Subtype Declarations - -- The elaboration of a subtype indication creates a subtype. - procedure Elaborate_Subtype_Indication - (Instance : Block_Instance_Acc; Ind : Iir) - is - begin - case Get_Kind (Ind) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_File_Type_Definition - | Iir_Kind_Access_Type_Definition - | Iir_Kind_Record_Type_Definition => - Elaborate_Type_Definition (Instance, Ind); - when Iir_Kind_Array_Subtype_Definition => - -- LRM93 12.3.1.3 - -- The elaboration of an index constraint consists of the - -- declaration of each of the discrete ranges in the index - -- constraint in some order that is not defined by the language. - declare - St_Indexes : constant Iir_Flist := Get_Index_Subtype_List (Ind); - St_El : Iir; - begin - for I in Flist_First .. Flist_Last (St_Indexes) loop - St_El := Get_Index_Type (St_Indexes, I); - Elaborate_Subtype_Indication_If_Anonymous (Instance, St_El); - end loop; - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Element_Subtype (Ind)); - end; - when Iir_Kind_Record_Subtype_Definition => - null; - when Iir_Kind_Access_Subtype_Definition => - null; - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind)); - when Iir_Kind_Physical_Subtype_Definition => - Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind)); - when others => - Error_Kind ("elaborate_subtype_indication", Ind); - end case; - end Elaborate_Subtype_Indication; - - -- LRM93 §12.3.1.2 Type Declarations. - procedure Elaborate_Type_Definition - (Instance : Block_Instance_Acc; Def : Iir) - is - begin - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition => - -- Elaboration of an enumeration type definition has not effect - -- other than the creation of the corresponding type. - Elaborate_Type_Range (Instance, Get_Range_Constraint (Def)); - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Floating_Type_Definition - | Iir_Kind_Physical_Type_Definition => - null; - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - -- Elaboration of an integer, floating point, or physical type - -- definition consists of the elaboration of the corresponding - -- range constraint. - Elaborate_Subtype_Indication_If_Anonymous (Instance, Def); - -- Elaboration of a physical unit declaration has no effect other - -- than to create the unit defined by the unit declaration. - null; - when Iir_Kind_Array_Type_Definition => - -- Elaboration of an unconstrained array type definition consists - -- of the elaboration of the element subtype indication of the - -- array type. - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Element_Subtype (Def)); - when Iir_Kind_Access_Type_Definition => - -- Elaboration of an access type definition consists of the - -- elaboration of the corresponding subtype indication. - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Designated_Type (Def)); - when Iir_Kind_File_Type_Definition => - -- GHDL: There is nothing about elaboration of a file type - -- definition. FIXME ?? - null; - when Iir_Kind_Record_Type_Definition => - -- Elaboration of a record type definition consists of the - -- elaboration of the equivalent single element declarations in - -- the given order. - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Def); - El : Iir_Element_Declaration; - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - -- Elaboration of an element declaration consists of - -- elaboration of the element subtype indication. - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (El)); - end loop; - end; - when Iir_Kind_Protected_Type_Declaration => - Elaborate_Declarative_Part - (Instance, Get_Declaration_Chain (Def)); - - when Iir_Kind_Incomplete_Type_Definition => - null; - when others => - Error_Kind ("elaborate_type_definition", Def); - end case; - end Elaborate_Type_Definition; - - -- LRM93 §12.3.1.2 Type Declarations. - procedure Elaborate_Type_Declaration - (Instance : Block_Instance_Acc; Decl : Iir_Type_Declaration) - is - Def : Iir; - Base_Type : Iir_Array_Type_Definition; - begin - -- Elaboration of a type declaration generally consists of the - -- elaboration of the definition of the type and the creation of that - -- type. - Def := Get_Type_Definition (Decl); - if Def = Null_Iir then - -- FIXME: can this happen ? - raise Program_Error; - end if; - if Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition then - Base_Type := Get_Base_Type (Def); - -- For a constrained array type declaration, however, - -- elaboration consists of the elaboration of the equivalent - -- anonymous unconstrained array type [...] - Elaborate_Subtype_Indication_If_Anonymous (Instance, Base_Type); - -- [...] followed by the elaboration of the named subtype - -- of that unconstrained type. - Elaborate_Subtype_Indication (Instance, Def); - else - Elaborate_Type_Definition (Instance, Def); - end if; - end Elaborate_Type_Declaration; - - procedure Elaborate_Nature_Definition - (Instance : Block_Instance_Acc; Def : Iir) - is - begin - case Get_Kind (Def) is - when Iir_Kind_Scalar_Nature_Definition => - Elaborate_Subtype_Indication (Instance, Get_Across_Type (Def)); - Elaborate_Subtype_Indication (Instance, Get_Through_Type (Def)); - when others => - Error_Kind ("elaborate_nature_definition", Def); - end case; - end Elaborate_Nature_Definition; - - -- LRM93 12.2.1 The Generic Clause - -- LRM08 14.3.2 Generic clause - procedure Elaborate_Generic_Clause - (Instance : Block_Instance_Acc; Generic_Chain : Iir) - is - Decl : Iir_Interface_Constant_Declaration; - begin - -- LRM08 14.3.2 Generic clause - -- Elaboration of a generic clause consists of the elaboration of each - -- of the equivalent single generic declarations contained in the - -- clause, in the order given. - Decl := Generic_Chain; - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Interface_Constant_Declaration => - -- LRM93 12.2.2 The generic clause - -- The elaboration of a generic declaration consists of - -- elaborating the subtype indication and then creating a - -- generic constant of that subtype. - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (Decl)); - Create_Object (Instance, Decl); - -- The value of a generic constant is not defined until a - -- subsequent generic map aspect is evaluated, or in the - -- absence of a generic map aspect, until the default - -- expression associated with the generic constant is evaluated - -- to determine the value of the constant. - when Iir_Kind_Interface_Package_Declaration => - Create_Object (Instance, Get_Info (Decl).Env_Slot); - when others => - Error_Kind ("elaborate_generic_clause", Decl); - end case; - Decl := Get_Chain (Decl); - end loop; - end Elaborate_Generic_Clause; - - -- LRM93 12.2.3 The Port Clause - procedure Elaborate_Port_Clause - (Instance : Block_Instance_Acc; Port_Chain : Iir) - is - Decl : Iir_Interface_Signal_Declaration; - begin - Decl := Port_Chain; - while Decl /= Null_Iir loop - -- LRM93 §12.2.3 - -- The elaboration of a port declaration consists of elaborating the - -- subtype indication and then creating a port of that subtype. - Elaborate_Subtype_Indication_If_Anonymous (Instance, Get_Type (Decl)); - - -- Simply increase an index to check that the port was created. - Create_Signal (Instance, Decl); - - Decl := Get_Chain (Decl); - end loop; - end Elaborate_Port_Clause; - - -- LRM93 §12.2.2 The generic Map Aspect - procedure Elaborate_Generic_Map_Aspect - (Target_Instance : Block_Instance_Acc; - Local_Instance : Block_Instance_Acc; - Generics : Iir; - Map : Iir) - is - Assoc : Iir; - Gen : Iir; - Inter : Iir_Interface_Constant_Declaration; - Value : Iir; - Val : Iir_Value_Literal_Acc; - Last_Individual : Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - -- Elaboration of a generic map aspect consists of elaborating the - -- generic association list. - - -- Elaboration of a generic association list consists of the - -- elaboration of each generic association element in the - -- association list. - Assoc := Map; - Gen := Generics; - Mark (Marker, Expr_Pool); - while Assoc /= Null_Iir loop - -- Elaboration of a generic association element consists of the - -- elaboration of the formal part and the evaluation of the actual - -- part. - -- FIXME: elaboration of the formal part. - Inter := Get_Association_Interface (Assoc, Gen); - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_Open => - -- The generic association list contains an implicit - -- association element for each generic constant that is not - -- explicitly associated with an actual [GHDL: done trought - -- annotations] or that is associated with the reserved word - -- OPEN; the actual part of such an implicit association - -- element is the default expression appearing in the - -- declaration of that generic constant. - Value := Get_Default_Value (Inter); - if Value /= Null_Iir then - Val := Execute_Expression (Target_Instance, Value); - else - Val := Create_Value_For_Type - (Target_Instance, Get_Type (Inter), - Init_Value_Default); - end if; - when Iir_Kind_Association_Element_By_Expression => - Value := Get_Actual (Assoc); - Val := Execute_Expression (Local_Instance, Value); - when Iir_Kind_Association_Element_By_Individual => - Val := Create_Value_For_Type - (Local_Instance, Get_Actual_Type (Assoc), Init_Value_Any); - - Last_Individual := Unshare (Val, Instance_Pool); - Target_Instance.Objects (Get_Info (Inter).Slot) := - Last_Individual; - goto Continue; - when Iir_Kind_Association_Element_Package => - declare - Actual : constant Iir := - Strip_Denoting_Name (Get_Actual (Assoc)); - Info : constant Sim_Info_Acc := Get_Info (Actual); - Pkg_Block : Block_Instance_Acc; - begin - Pkg_Block := Get_Instance_By_Scope - (Local_Instance, Info.Frame_Scope); - Environment_Table.Append (Pkg_Block); - Val := Create_Environment_Value (Environment_Table.Last); - Target_Instance.Objects (Get_Info (Inter).Env_Slot) := - Unshare (Val, Instance_Pool); - end; - - goto Continue; - when others => - Error_Kind ("elaborate_generic_map_aspect", Assoc); - end case; - - if Get_Whole_Association_Flag (Assoc) then - -- It is an error if the value of the actual does not belong to - -- the subtype denoted by the subtype indication of the formal. - -- If the subtype denoted by the subtype indication of the - -- declaration of the formal is a constrained array subtype, then - -- an implicit subtype conversion is performed prior to this - -- check. - -- It is also an error if the type of the formal is an array type - -- and the value of each element of the actual does not belong to - -- the element subtype of the formal. - Implicit_Array_Conversion - (Target_Instance, Val, Get_Type (Inter), Inter); - Check_Constraints (Target_Instance, Val, Get_Type (Inter), Inter); - - -- The generic constant or subelement or slice thereof designated - -- by the formal part is then initialized with the value - -- resulting from the evaluation of the corresponding actual part. - Target_Instance.Objects (Get_Info (Inter).Slot) := - Unshare (Val, Instance_Pool); - else - declare - Targ : Iir_Value_Literal_Acc; - Is_Sig : Boolean; - begin - Execute_Name_With_Base - (Target_Instance, Get_Formal (Assoc), - Last_Individual, Targ, Is_Sig); - Store (Targ, Val); - end; - end if; - - <> null; - Release (Marker, Expr_Pool); - Next_Association_Interface (Assoc, Gen); - end loop; - end Elaborate_Generic_Map_Aspect; - - -- LRM93 12.2.3 The Port Clause - procedure Elaborate_Port_Declaration - (Instance : Block_Instance_Acc; - Decl : Iir_Interface_Signal_Declaration; - Default_Value : Iir_Value_Literal_Acc) - is - Val : Iir_Value_Literal_Acc; - begin - if Default_Value = null then - Val := Elaborate_Default_Value (Instance, Decl); - else - Val := Default_Value; - end if; - Elaborate_Signal (Instance, Decl, Val); - end Elaborate_Port_Declaration; - - procedure Elab_Connect - (Formal_Instance : Block_Instance_Acc; - Local_Instance : Block_Instance_Acc; - Actual_Expr : Iir_Value_Literal_Acc; - Assoc : Iir_Association_Element_By_Expression; - Inter : Iir) - is - Formal : Iir; - Actual : Iir; - Local_Expr : Iir_Value_Literal_Acc; - Formal_Expr : Iir_Value_Literal_Acc; - begin - Formal := Get_Association_Formal (Assoc, Inter); - Actual := Get_Actual (Assoc); - Formal_Expr := Execute_Name (Formal_Instance, Formal, True); - Formal_Expr := Unshare_Bounds (Formal_Expr, Global_Pool'Access); - if Actual_Expr = null then - Local_Expr := Execute_Name (Local_Instance, Actual, True); - Local_Expr := Unshare_Bounds (Local_Expr, Global_Pool'Access); - else - Local_Expr := Actual_Expr; - end if; - - Connect_Table.Append ((Formal => Formal_Expr, - Formal_Instance => Formal_Instance, - Actual => Local_Expr, - Actual_Instance => Local_Instance, - Inter => Inter, - Assoc => Assoc)); - end Elab_Connect; - - -- LRM93 12.2.3 The Port Clause - -- LRM93 §12.2.4 The Port Map Aspect - procedure Elaborate_Port_Map_Aspect - (Formal_Instance : Block_Instance_Acc; - Actual_Instance : Block_Instance_Acc; - Ports : Iir; - Map : Iir) - is - Assoc : Iir; - Port : Iir; - Inter : Iir_Interface_Signal_Declaration; - Actual_Expr : Iir_Value_Literal_Acc; - Init_Expr : Iir_Value_Literal_Acc; - Actual : Iir; - Formal : Iir; - begin - pragma Assert (Formal_Instance.Ports_Map = Null_Iir); - Formal_Instance.Ports_Map := Map; - - if Ports = Null_Iir then - return; - end if; - - -- Elaboration of a port map aspect consists of elaborating the port - -- association list. - if Map = Null_Iir then - -- No port association, elaborate the port clause. - -- Elaboration of a port clause consists of the elaboration of each - -- of the equivalent signal port declaration in the clause, in the - -- order given. - Inter := Ports; - while Inter /= Null_Iir loop - Elaborate_Port_Declaration (Formal_Instance, Inter, null); - Inter := Get_Chain (Inter); - end loop; - return; - end if; - - Assoc := Map; - Port := Ports; - while Assoc /= Null_Iir loop - -- Elaboration of a port association list consists of the elaboration - -- of each port association element in the association list whose - -- actual is not the reserved word OPEN. - Inter := Get_Association_Interface (Assoc, Port); - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Expression => - if Get_Actual_Conversion (Assoc) = Null_Iir - and then Get_Formal_Conversion (Assoc) = Null_Iir - then - Actual := Get_Actual (Assoc); - Formal := Get_Association_Formal (Assoc, Inter); - if Is_Signal_Name (Actual) then - -- Association with a signal - Init_Expr := Execute_Signal_Init_Value - (Actual_Instance, Actual); - Implicit_Array_Conversion - (Formal_Instance, Init_Expr, Get_Type (Formal), Actual); - Init_Expr := Unshare_Bounds - (Init_Expr, Global_Pool'Access); - Actual_Expr := null; - else - -- Association with an expression - Init_Expr := Execute_Expression - (Actual_Instance, Actual); - Implicit_Array_Conversion - (Formal_Instance, Init_Expr, Get_Type (Formal), Actual); - Init_Expr := Unshare (Init_Expr, Global_Pool'Access); - Actual_Expr := Init_Expr; - end if; - else - -- The actual doesn't define the constraints of the formal. - if Get_Whole_Association_Flag (Assoc) then - Init_Expr := Elaborate_Default_Value - (Formal_Instance, Inter); - Actual_Expr := null; - end if; - end if; - - if Get_Whole_Association_Flag (Assoc) - and then Get_Collapse_Signal_Flag (Assoc) - then - pragma Assert (Get_Actual_Conversion (Assoc) = Null_Iir); - pragma Assert (Get_Formal_Conversion (Assoc) = Null_Iir); - pragma Assert (Is_Signal_Name (Get_Actual (Assoc))); - declare - Slot : constant Object_Slot_Type := - Get_Info (Inter).Slot; - Actual_Sig : Iir_Value_Literal_Acc; - Default_Value : Iir; - Val : Iir_Value_Literal_Acc; - begin - Actual_Sig := - Execute_Name (Actual_Instance, Actual, True); - Implicit_Array_Conversion - (Formal_Instance, Actual_Sig, - Get_Type (Inter), Actual); - Formal_Instance.Objects (Slot) := Unshare_Bounds - (Actual_Sig, Global_Pool'Access); - Formal_Instance.Objects (Slot + 1) := Init_Expr; - if Get_Mode (Inter) = Iir_Out_Mode then - Default_Value := Get_Default_Value (Inter); - if Default_Value /= Null_Iir then - Val := Execute_Expression_With_Type - (Formal_Instance, Default_Value, - Get_Type (Inter)); - Store (Formal_Instance.Objects (Slot + 1), Val); - else - Init_To_Default - (Formal_Instance.Objects (Slot + 1), - Formal_Instance, Get_Type (Inter)); - end if; - end if; - end; - else - if Get_Whole_Association_Flag (Assoc) then - Elaborate_Signal (Formal_Instance, Inter, Init_Expr); - end if; - - -- Elaboration of a port association element consists of the - -- elaboration of the formal part; the port or subelement - -- or slice thereof designated by the formal part is then - -- associated with the signal or expression designated - -- by the actual part. - Elab_Connect (Formal_Instance, Actual_Instance, Actual_Expr, - Assoc, Inter); - end if; - - when Iir_Kind_Association_Element_Open => - -- Note that an open cannot be associated with a formal that - -- is associated individually. - Elaborate_Port_Declaration (Formal_Instance, Inter, null); - - when Iir_Kind_Association_Element_By_Individual => - Init_Expr := Create_Value_For_Type - (Formal_Instance, Get_Actual_Type (Assoc), Init_Value_Any); - Elaborate_Signal (Formal_Instance, Inter, Init_Expr); - - when others => - Error_Kind ("elaborate_port_map_aspect", Assoc); - end case; - Next_Association_Interface (Assoc, Port); - end loop; - end Elaborate_Port_Map_Aspect; - - -- LRM93 §12.2 Elaboration of a block header - -- Elaboration of a block header consists of the elaboration of the - -- generic clause, the generic map aspect, the port clause, and the port - -- map aspect, in that order. - procedure Elaborate_Block_Header - (Instance : Block_Instance_Acc; Header : Iir_Block_Header) - is - begin - Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Header)); - Elaborate_Generic_Map_Aspect - (Instance, Instance, - Get_Generic_Chain (Header), - Get_Generic_Map_Aspect_Chain (Header)); - Elaborate_Port_Clause (Instance, Get_Port_Chain (Header)); - Elaborate_Port_Map_Aspect - (Instance, Instance, - Get_Port_Chain (Header), Get_Port_Map_Aspect_Chain (Header)); - end Elaborate_Block_Header; - - procedure Elaborate_Guard_Signal - (Instance : Block_Instance_Acc; Guard : Iir) - is - Sig, Val : Iir_Value_Literal_Acc; - Info : constant Sim_Info_Acc := Get_Info (Guard); - begin - Create_Signal (Instance, Guard); - - Sig := Create_Signal_Value (null); - Val := Unshare (Create_B1_Value (False), Instance_Pool); - Instance.Objects (Info.Slot) := Sig; - Instance.Objects (Info.Slot + 1) := Val; - - Signals_Table.Append ((Kind => Mode_Guard, - Decl => Guard, - Sig => Sig, - Val => Val, - Instance => Instance)); - end Elaborate_Guard_Signal; - - -- LRM93 §12.4.1 Block statements. - procedure Elaborate_Block_Statement - (Instance : Block_Instance_Acc; Block : Iir_Block_Statement) - is - Header : Iir_Block_Header; - Ninstance : Block_Instance_Acc; -- FIXME - Guard : Iir; - begin - Ninstance := Create_Block_Instance (Instance, Block, Block); - - Guard := Get_Guard_Decl (Block); - if Guard /= Null_Iir then - -- LRM93 12.6.4 (3) - -- The value of each implicit GUARD signal is set to the result of - -- evaluating the corresponding guard expression. - -- GHDL: done by grt when the guard signal is created. - Elaborate_Guard_Signal (Ninstance, Guard); - end if; - - -- Elaboration of a block statement consists of the elaboration of the - -- block header, if present [...] - Header := Get_Block_Header (Block); - if Header /= Null_Iir then - Elaborate_Block_Header (Ninstance, Header); - end if; - - -- [...] followed by the elaboration of the block declarative part [...] - Elaborate_Declarative_Part (Ninstance, - Get_Declaration_Chain (Block)); - -- [...] followed by the elaboration of the block statement part. - Elaborate_Statement_Part - (Ninstance, Get_Concurrent_Statement_Chain (Block)); - -- Elaboration of a block statement may occur under the control of a - -- configuration declaration. - -- In particular, a block configuration, wether implicit or explicit, - -- within a configuration declaration may supply a sequence of - -- additionnal implicit configuration specification to be applied - -- during the elaboration of the corresponding block statement. - -- If a block statement is being elaborated under the control of a - -- configuration declaration, then the sequence of implicit - -- configuration specifications supplied by the block configuration - -- is elaborated as part of the block declarative part, following all - -- other declarative items in that part. - -- The sequence of implicit configuration specifications supplied by a - -- block configuration, wether implicit or explicit, consists of each of - -- the configuration specifications implied by component configurations - -- occurring immediatly within the block configuration, and in the - -- order in which the component configurations themselves appear. - -- FIXME. - end Elaborate_Block_Statement; - - function Create_Default_Association (Formal_Chain : Iir; - Local_Chain : Iir; - Node : Iir) - return Iir - is - Nbr_Formals : Natural; - begin - -- LRM93 5.2.2 - -- The default binding indication includes a default generic map - -- aspect if the design entity implied by the entity aspect contains - -- formal generic. - -- - -- LRM93 5.2.2 - -- The default binding indication includes a default port map aspect if - -- the design entity implied by the entity aspect contains formal ports. - if Formal_Chain = Null_Iir then - if Local_Chain /= Null_Iir then - Error_Msg_Sem (+Node, "cannot create default map aspect"); - end if; - return Null_Iir; - end if; - Nbr_Formals := Get_Chain_Length (Formal_Chain); - declare - Assoc_List : Iir_Array (0 .. Nbr_Formals - 1) := (others => Null_Iir); - Assoc : Iir; - Local : Iir; - Formal : Iir; - Pos : Natural; - First, Last : Iir; - begin - -- LRM93 5.2.2 - -- The default generic map aspect associates each local generic in - -- the corresponding component instantiation (if any) with a formal - -- of the same simple name. - Local := Local_Chain; - while Local /= Null_Iir loop - Formal := Formal_Chain; - Pos := 0; - while Formal /= Null_Iir loop - exit when Get_Identifier (Formal) = Get_Identifier (Local); - Formal := Get_Chain (Formal); - Pos := Pos + 1; - end loop; - if Formal = Null_Iir then - -- LRM93 5.2.2 - -- It is an error if such a formal does not exist, or if - -- its mode and type are not appropriate for such an - -- association. - -- FIXME: mode/type check. - Error_Msg_Sem (+Node, "cannot associate local %n", +Local); - exit; - end if; - if Assoc_List (Pos) /= Null_Iir then - raise Internal_Error; - end if; - Assoc_List (Pos) := Local; - - Local := Get_Chain (Local); - end loop; - - Sub_Chain_Init (First, Last); - Formal := Formal_Chain; - for I in Assoc_List'Range loop - if Assoc_List (I) = Null_Iir then - -- LRM93 5.2.2 - -- Any remaining unassociated formals are associated with the - -- actual designator any. - Assoc := Create_Iir (Iir_Kind_Association_Element_Open); - else - Assoc := - Create_Iir (Iir_Kind_Association_Element_By_Expression); - Set_Actual (Assoc, Assoc_List (I)); - end if; - Set_Whole_Association_Flag (Assoc, True); - Set_Formal (Assoc, Formal); - Sub_Chain_Append (First, Last, Assoc); - - Formal := Get_Chain (Formal); - end loop; - return First; - end; - end Create_Default_Association; - - -- LRM93 §12.4.3 - function Is_Fully_Bound (Conf : Iir) return Boolean - is - Binding : Iir; - begin - if Conf = Null_Iir then - return False; - end if; - case Get_Kind (Conf) is - when Iir_Kind_Configuration_Specification - | Iir_Kind_Component_Configuration => - Binding := Get_Binding_Indication (Conf); - if Binding = Null_Iir then - return False; - end if; - if Get_Kind (Get_Entity_Aspect (Binding)) - = Iir_Kind_Entity_Aspect_Open - then - return False; - end if; - when others => - null; - end case; - return True; - end Is_Fully_Bound; - - procedure Elaborate_Component_Instantiation - (Instance : Block_Instance_Acc; - Stmt : Iir_Component_Instantiation_Statement) - is - Frame : Block_Instance_Acc; - begin - if Is_Component_Instantiation (Stmt) then - declare - Component : constant Iir := - Get_Named_Entity (Get_Instantiated_Unit (Stmt)); - begin - -- Elaboration of a component instantiation statement that - -- instanciates a component declaration has no effect unless the - -- component instance is either fully bound to a design entity - -- defined by an entity declaration and architecture body or is - -- bound to a configuration of such a design entity. - -- FIXME: in fact the component is created. - - -- If a component instance is so bound, then elaboration of the - -- corresponding component instantiation statement consists of the - -- elaboration of the implied block statement representing the - -- component instance and [...] - Frame := Create_Block_Instance (Instance, Component, Stmt); - - Current_Component := Frame; - Elaborate_Generic_Clause (Frame, Get_Generic_Chain (Component)); - Elaborate_Generic_Map_Aspect - (Frame, Instance, - Get_Generic_Chain (Component), - Get_Generic_Map_Aspect_Chain (Stmt)); - Elaborate_Port_Clause (Frame, Get_Port_Chain (Component)); - Elaborate_Port_Map_Aspect - (Frame, Instance, - Get_Port_Chain (Component), Get_Port_Map_Aspect_Chain (Stmt)); - Current_Component := null; - end; - else - -- Direct instantiation - declare - Aspect : constant Iir := Get_Instantiated_Unit (Stmt); - Arch : Iir; - Config : Iir; - begin - case Get_Kind (Aspect) is - when Iir_Kind_Entity_Aspect_Entity => - Arch := Get_Architecture (Aspect); - if Arch = Null_Iir then - Arch := Libraries.Get_Latest_Architecture - (Get_Entity (Aspect)); - else - Arch := Strip_Denoting_Name (Arch); - end if; - Config := Get_Library_Unit - (Get_Default_Configuration_Declaration (Arch)); - when Iir_Kind_Entity_Aspect_Configuration => - Config := Get_Configuration (Aspect); - Arch := Get_Block_Specification - (Get_Block_Configuration (Config)); - when Iir_Kind_Entity_Aspect_Open => - return; - when others => - raise Internal_Error; - end case; - Config := Get_Block_Configuration (Config); - - Frame := Elaborate_Architecture - (Arch, Config, Instance, Stmt, - Get_Generic_Map_Aspect_Chain (Stmt), - Get_Port_Map_Aspect_Chain (Stmt)); - end; - end if; - end Elaborate_Component_Instantiation; - - -- LRM93 12.4.2 Generate Statements - procedure Elaborate_If_Generate_Statement - (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement) - is - Clause : Iir; - Cond : Iir; - Bod : Iir; - Ninstance : Block_Instance_Acc; - Lit : Iir_Value_Literal_Acc; - begin - -- LRM93 12.4.2 - -- For a generate statement with an if generation scheme, elaboration - -- consists of the evaluation of the boolean expression, followed by - -- the generation of exactly one block statement if the expression - -- evaluates to TRUE, and no block statement otherwise. - Clause := Generate; - while Clause /= Null_Iir loop - Cond := Get_Condition (Clause); - if Cond /= Null_Iir then - Lit := Execute_Expression (Instance, Cond); - end if; - if Cond = Null_Iir or else Lit.B1 = True then - -- LRM93 12.4.2 - -- If generated, the block statement has the following form: - -- 1. The block label is the same as the label of the generate - -- statement. - -- 2. The block declarative part consists of a copy of the - -- declarative items contained within the generate statement. - -- 3. The block statement part consists of a copy of the - -- concurrent statement contained within the generate - -- statement. - Bod := Get_Generate_Statement_Body (Clause); - Ninstance := Create_Block_Instance (Instance, Bod, Bod); - Elaborate_Declarative_Part - (Ninstance, Get_Declaration_Chain (Bod)); - Elaborate_Statement_Part - (Ninstance, Get_Concurrent_Statement_Chain (Bod)); - - exit; - end if; - Clause := Get_Generate_Else_Clause (Clause); - end loop; - end Elaborate_If_Generate_Statement; - - -- LRM93 12.4.2 Generate Statements - procedure Elaborate_For_Generate_Statement - (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement) - is - Iter : constant Iir := Get_Parameter_Specification (Generate); - Bod : constant Iir := Get_Generate_Statement_Body (Generate); - Ninstance : Block_Instance_Acc; - Sub_Instance : Block_Instance_Acc; - Bound, Index : Iir_Value_Literal_Acc; - begin - -- LRM93 12.4.2 - -- For a generate statement with a for generation scheme, elaboration - -- consists of the elaboration of the discrete range - - Ninstance := Create_Block_Instance (Instance, Bod, Bod); - Elaborate_Declaration (Ninstance, Iter); - Bound := Execute_Bounds (Ninstance, Get_Type (Iter)); - - -- Index is the iterator value. - Index := Unshare (Ninstance.Objects (Get_Info (Iter).Slot), - Current_Pool); - - -- Initialize the iterator. - Store (Index, Bound.Left); - - if not Is_In_Range (Index, Bound) then - -- Well, this instance should have never been built. - -- Should be destroyed ?? - return; - end if; - - loop - Sub_Instance := Create_Block_Instance (Ninstance, Bod, Iter); - - -- FIXME: this is needed to copy iterator type (if any). But this - -- elaborates the subtype several times (what about side effects). - Elaborate_Declaration (Sub_Instance, Iter); - - -- Store index. - Store (Sub_Instance.Objects (Get_Info (Iter).Slot), Index); - - Elaborate_Declarative_Part - (Sub_Instance, Get_Declaration_Chain (Bod)); - Elaborate_Statement_Part - (Sub_Instance, Get_Concurrent_Statement_Chain (Bod)); - - exit when Is_Equal (Index, Bound.Right); - Update_Loop_Index (Index, Bound); - end loop; - -- FIXME: destroy index ? - end Elaborate_For_Generate_Statement; - - procedure Elaborate_Process_Statement - (Instance : Block_Instance_Acc; Stmt : Iir) - is - Proc_Instance : Block_Instance_Acc; - begin - Proc_Instance := Create_Block_Instance (Instance, Stmt, Stmt); - - Processes_Table.Append (Proc_Instance); - - -- Processes aren't elaborated here. They are elaborated - -- just before simulation. - end Elaborate_Process_Statement; - - procedure Elaborate_Psl_Directive - (Instance : Block_Instance_Acc; Stmt : Iir) - is - begin - -- Create the state vector (and initialize it). - -- Create the bool flag (for cover) - -- Create the process - -- Create the finalizer - PSL_Table.Append (PSL_Entry'(Instance, Stmt, null, False)); - end Elaborate_Psl_Directive; - - -- LRM93 §12.4 Elaboration of a Statement Part. - procedure Elaborate_Statement_Part - (Instance : Block_Instance_Acc; Stmt_Chain: Iir) - is - Stmt : Iir; - begin - -- Concurrent statements appearing in the statement part of a block - -- must be elaborated before execution begins. - -- Elaboration of the statement part of a block consists of the - -- elaboration of each concurrent statement in the order given. - Stmt := Stmt_Chain; - while Stmt /= Null_Iir loop - case Get_Kind (Stmt) is - when Iir_Kind_Block_Statement => - Elaborate_Block_Statement (Instance, Stmt); - - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement => - Elaborate_Process_Statement (Instance, Stmt); - - when Iir_Kind_Component_Instantiation_Statement => - Elaborate_Component_Instantiation (Instance, Stmt); - - when Iir_Kind_If_Generate_Statement => - Elaborate_If_Generate_Statement (Instance, Stmt); - - when Iir_Kind_For_Generate_Statement => - Elaborate_For_Generate_Statement (Instance, Stmt); - - when Iir_Kind_Simple_Simultaneous_Statement => - Add_Characteristic_Expression - (Explicit, - Build (Op_Plus, - Instance, Get_Simultaneous_Right (Stmt), - Build (Op_Minus, - Instance, Get_Simultaneous_Left (Stmt)))); - - when Iir_Kind_Psl_Default_Clock - | Iir_Kind_Psl_Declaration => - null; - - when Iir_Kind_Psl_Cover_Statement - | Iir_Kind_Psl_Assert_Statement => - Elaborate_Psl_Directive (Instance, Stmt); - - when Iir_Kind_Concurrent_Simple_Signal_Assignment => - -- In case concurrent signal assignemnts were not - -- canonicalized. - null; - - when others => - Error_Kind ("elaborate_statement_part", Stmt); - end case; - Stmt := Get_Chain (Stmt); - end loop; - - -- Put children in order (were prepended, so in reverse order). - declare - Last, Child : Block_Instance_Acc; - Next_Child : Block_Instance_Acc; - begin - Child := Instance.Children; - Last := null; - while Child /= null loop - Next_Child := Child.Brother; - Child.Brother := Last; - Last := Child; - Child := Next_Child; - end loop; - Instance.Children := Last; - end; - end Elaborate_Statement_Part; - - -- Compute the default value for declaration DECL, using either - -- DEFAULT_VALUE if not null, or the implicit default value for DECL. - -- DECL must have a type. - function Elaborate_Default_Value (Instance : Block_Instance_Acc; Decl : Iir) - return Iir_Value_Literal_Acc - is - Default_Value : constant Iir := Get_Default_Value (Decl); - Val : Iir_Value_Literal_Acc; - begin - if Default_Value /= Null_Iir then - Val := Execute_Expression_With_Type - (Instance, Default_Value, Get_Type (Decl)); - else - Val := Create_Value_For_Type - (Instance, Get_Type (Decl), Init_Value_Default); - end if; - return Val; - end Elaborate_Default_Value; - - -- LRM93 §12.3.1.1 Subprogram Declaration and Bodies - procedure Elaborate_Interface_List - (Instance : Block_Instance_Acc; Inter_Chain : Iir) - is - Inter : Iir; - begin - -- elaboration of the parameter interface list - -- this in turn involves the elaboration of the subtype indication of - -- each interface element to determine the subtype of each formal - -- parameter of the subprogram. - Inter := Inter_Chain; - while Inter /= Null_Iir loop - case Get_Kind (Inter) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (Inter)); - when others => - Error_Kind ("elaborate_interface_list", Inter); - end case; - Inter := Get_Chain (Inter); - end loop; - end Elaborate_Interface_List; - - -- LRM93 §12.3.1.1 Subprogram Declaration and Bodies - procedure Elaborate_Subprogram_Declaration - (Instance : Block_Instance_Acc; Decl : Iir) - is - begin - -- Elaboration of a subprogram declaration involves the elaboration - -- of the parameter interface list of the subprogram declaration; [...] - Elaborate_Interface_List - (Instance, Get_Interface_Declaration_Chain (Decl)); - - -- Elaboration of a subprogram body has no effect other than to - -- establish that the body can, from then on, be used for the - -- execution of calls of the subprogram. - -- FIXME - null; - end Elaborate_Subprogram_Declaration; - - procedure Elaborate_Component_Configuration - (Stmt : Iir_Component_Instantiation_Statement; - Comp_Instance : Block_Instance_Acc; - Conf : Iir_Component_Configuration) - is - Component : constant Iir_Component_Declaration := - Get_Named_Entity (Get_Instantiated_Unit (Stmt)); - Entity : Iir_Entity_Declaration; - Arch_Name : Name_Id; - Arch_Design : Iir_Design_Unit; - Arch : Iir_Architecture_Body; - Arch_Frame : Block_Instance_Acc; - pragma Unreferenced (Arch_Frame); - Generic_Map_Aspect_Chain : Iir; - Port_Map_Aspect_Chain : Iir; - Binding : Iir_Binding_Indication; - Aspect : Iir; - Sub_Conf : Iir; - begin - if Trace_Elaboration then - Ada.Text_IO.Put ("configure component "); - Ada.Text_IO.Put (Name_Table.Image (Get_Label (Stmt))); - Ada.Text_IO.Put (": "); - Ada.Text_IO.Put_Line (Image_Identifier (Component)); - end if; - - -- Elaboration of a component instantiation statement that instanciates - -- a component declaration has no effect unless the component instance - -- is either fully bound to a design entity defined by an entity - -- declaration and architecture body or is bound to a configuration of - -- such a design entity. - if not Is_Fully_Bound (Conf) then - Warning_Msg_Elab - (Warnid_Binding, Stmt, "%n not bound", +Stmt); - return; - end if; - - if Trace_Elaboration then - Ada.Text_IO.Put_Line - (" using " & Disp_Node (Conf) & " from " & Disp_Location (Conf)); - end if; - - -- If a component instance is so bound, then elaboration of the - -- corresponding component instantiation statement consists of the - -- elaboration of the implied block statement representing the - -- component instance and [...] - -- FIXME: extract frame. - - -- and (within that block) the implied block statement representing the - -- design entity to which the component instance is so bound. - Arch := Null_Iir; - Arch_Name := Null_Identifier; - Binding := Get_Binding_Indication (Conf); - Aspect := Get_Entity_Aspect (Binding); - - case Get_Kind (Conf) is - when Iir_Kind_Component_Configuration => - Sub_Conf := Get_Block_Configuration (Conf); - when Iir_Kind_Configuration_Specification => - Sub_Conf := Null_Iir; - when others => - raise Internal_Error; - end case; - - case Get_Kind (Aspect) is - when Iir_Kind_Design_Unit => - raise Internal_Error; - when Iir_Kind_Entity_Aspect_Entity => - Entity := Get_Entity (Aspect); - if Get_Architecture (Aspect) /= Null_Iir then - Arch_Name := Get_Identifier - (Strip_Denoting_Name (Get_Architecture (Aspect))); - end if; - when Iir_Kind_Entity_Aspect_Configuration => - if Sub_Conf /= Null_Iir then - raise Internal_Error; - end if; - declare - Conf : constant Iir := Get_Configuration (Aspect); - begin - Entity := Get_Entity (Conf); - Sub_Conf := Get_Block_Configuration (Conf); - Arch := Get_Named_Entity (Get_Block_Specification (Sub_Conf)); - end; - when others => - Error_Kind ("elaborate_component_declaration0", Aspect); - end case; - - if Arch = Null_Iir then - if Arch_Name = Null_Identifier then - Arch := Libraries.Get_Latest_Architecture (Entity); - if Arch = Null_Iir then - Error_Msg_Elab - (Stmt, "no architecture analysed for %n", +Entity); - end if; - Arch_Name := Get_Identifier (Arch); - end if; - Arch_Design := Libraries.Load_Secondary_Unit - (Get_Design_Unit (Entity), Arch_Name, Stmt); - if Arch_Design = Null_Iir then - Error_Msg_Elab - (Stmt, "no architecture %i for %n", (+Arch_Name, +Entity)); - end if; - Arch := Get_Library_Unit (Arch_Design); - end if; - - Generic_Map_Aspect_Chain := Get_Generic_Map_Aspect_Chain (Binding); - Port_Map_Aspect_Chain := Get_Port_Map_Aspect_Chain (Binding); - - if Generic_Map_Aspect_Chain = Null_Iir then - -- LRM93 5.2.2 - -- The default binding indication includes a default generic map - -- aspect if the design entity implied by the entity aspect contains - -- formal generic - -- GHDL: this condition is checked by create_default_association. - Generic_Map_Aspect_Chain := - Create_Default_Association (Get_Generic_Chain (Entity), - Get_Generic_Chain (Component), - Stmt); - end if; - - if Port_Map_Aspect_Chain = Null_Iir then - Port_Map_Aspect_Chain := - Create_Default_Association (Get_Port_Chain (Entity), - Get_Port_Chain (Component), - Stmt); - end if; - - if Sub_Conf = Null_Iir then - Sub_Conf := Get_Default_Configuration_Declaration (Arch); - Sub_Conf := Get_Block_Configuration (Get_Library_Unit (Sub_Conf)); - end if; - - -- FIXME: Use Sub_Conf instead of Arch for Stmt ? (But need to add - -- info for block configuration). - Arch_Frame := Elaborate_Architecture - (Arch, Sub_Conf, Comp_Instance, Arch, - Generic_Map_Aspect_Chain, Port_Map_Aspect_Chain); - end Elaborate_Component_Configuration; - - procedure Elaborate_Block_Configuration - (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc); - - procedure Apply_Block_Configuration_To_Iterative_Generate - (Stmt : Iir; Conf_Chain : Iir; Instance : Block_Instance_Acc) - is - Scheme : constant Iir := Get_Parameter_Specification (Stmt); - Bounds : constant Iir_Value_Literal_Acc := - Execute_Bounds (Instance, Get_Type (Scheme)); - - Sub_Instances : Block_Instance_Acc_Array - (0 .. Instance_Slot_Type (Bounds.Length - 1)); - - type Sub_Conf_Type is array (0 .. Instance_Slot_Type (Bounds.Length - 1)) - of Boolean; - Sub_Conf : Sub_Conf_Type := (others => False); - - Child : Block_Instance_Acc; - - Item : Iir; - Prev_Item : Iir; - Default_Item : Iir := Null_Iir; - Spec : Iir; - Expr : Iir_Value_Literal_Acc; - Ind : Instance_Slot_Type; - begin - -- Gather children. - Child := Instance.Children; - for I in Sub_Instances'Range loop - Sub_Instances (I) := Child; - Child := Child.Brother; - end loop; - -- All children must have been handled. - pragma Assert (Child = null); - - -- Apply configuration items - Item := Conf_Chain; - while Item /= Null_Iir loop - Spec := Strip_Denoting_Name (Get_Block_Specification (Item)); - Prev_Item := Get_Prev_Block_Configuration (Item); - - case Get_Kind (Spec) is - when Iir_Kind_Slice_Name => - Expr := Execute_Bounds (Instance, Get_Suffix (Spec)); - Ind := Instance_Slot_Type - (Get_Index_Offset (Execute_Low_Limit (Expr), Bounds, Spec)); - for I in 1 .. Instance_Slot_Type (Expr.Length) loop - Sub_Conf (Ind + I - 1) := True; - Elaborate_Block_Configuration - (Item, Sub_Instances (Ind + I - 1)); - end loop; - when Iir_Kind_Indexed_Name => - if Get_Index_List (Spec) = Iir_Flist_Others then - -- Must be the only default block configuration - pragma Assert (Default_Item = Null_Iir); - Default_Item := Item; - else - Expr := Execute_Expression - (Instance, Get_Nth_Element (Get_Index_List (Spec), 0)); - Ind := Instance_Slot_Type - (Get_Index_Offset (Expr, Bounds, Spec)); - Sub_Conf (Ind) := True; - Elaborate_Block_Configuration (Item, Sub_Instances (Ind)); - end if; - when Iir_Kind_Generate_Statement_Body => - -- Must be the only block configuration - pragma Assert (Item = Conf_Chain); - pragma Assert (Prev_Item = Null_Iir); - for I in Sub_Instances'Range loop - Sub_Conf (I) := True; - Elaborate_Block_Configuration (Item, Sub_Instances (I)); - end loop; - when others => - raise Internal_Error; - end case; - Item := Prev_Item; - end loop; - - -- Default configuration. - if Default_Item /= Null_Iir then - for I in Sub_Instances'Range loop - if not Sub_Conf (I) then - Elaborate_Block_Configuration - (Default_Item, Sub_Instances (I)); - end if; - end loop; - end if; - end Apply_Block_Configuration_To_Iterative_Generate; - - procedure Elaborate_Block_Configuration - (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc) - is - Blk_Info : constant Sim_Info_Acc := Get_Info (Instance.Stmt); - Sub_Instances : Block_Instance_Acc_Array - (0 .. Blk_Info.Nbr_Instances - 1); - type Iir_Array is array (Instance_Slot_Type range <>) of Iir; - Sub_Conf : Iir_Array (0 .. Blk_Info.Nbr_Instances - 1) := - (others => Null_Iir); - - Item : Iir; - begin - -- Gather children and reverse the list. - declare - Child, Prev, First : Block_Instance_Acc; - Info : Sim_Info_Acc; - begin - Child := Instance.Children; - First := null; - while Child /= null loop - Info := Get_Info (Child.Label); - if Info.Kind = Kind_Block then - pragma Assert (Info.Inst_Slot /= Invalid_Instance_Slot); - pragma Assert (Sub_Instances (Info.Inst_Slot) = null); - Sub_Instances (Info.Inst_Slot) := Child; - end if; - - -- Reverse - Prev := Child.Brother; - Child.Brother := First; - First := Child; - - Child := Prev; - end loop; - Instance.Children := First; - end; - - -- Associate configuration items with subinstance. Gather items for - -- for-generate statements. - Item := Get_Configuration_Item_Chain (Conf); - while Item /= Null_Iir loop - case Get_Kind (Item) is - when Iir_Kind_Block_Configuration => - declare - Spec : Iir; - Gen : Iir_Generate_Statement; - Info : Sim_Info_Acc; - begin - Spec := Strip_Denoting_Name (Get_Block_Specification (Item)); - case Get_Kind (Spec) is - when Iir_Kind_Slice_Name - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Name => - -- Block configuration for a generate statement. - Gen := Get_Named_Entity (Get_Prefix (Spec)); - Info := Get_Info (Gen); - Set_Prev_Block_Configuration - (Item, Sub_Conf (Info.Inst_Slot)); - Sub_Conf (Info.Inst_Slot) := Item; - when Iir_Kind_Parenthesis_Name => - Gen := Get_Named_Entity (Spec); - Info := Get_Info (Gen); - if Sub_Instances (Info.Inst_Slot) /= null - and then Sub_Instances (Info.Inst_Slot).Label = Gen - then - pragma Assert - (Sub_Conf (Info.Inst_Slot) = Null_Iir); - Sub_Conf (Info.Inst_Slot) := Item; - end if; - when Iir_Kind_Generate_Statement_Body => - Info := Get_Info (Spec); - pragma Assert (Sub_Conf (Info.Inst_Slot) = Null_Iir); - Sub_Conf (Info.Inst_Slot) := Item; - when Iir_Kind_Block_Statement => - -- Block configuration for a block statement. - Info := Get_Info (Spec); - pragma Assert (Sub_Conf (Info.Inst_Slot) = Null_Iir); - Sub_Conf (Info.Inst_Slot) := Item; - when others => - Error_Kind ("elaborate_block_configuration1", Spec); - end case; - end; - - when Iir_Kind_Component_Configuration => - declare - List : constant Iir_Flist := - Get_Instantiation_List (Item); - El : Iir; - Info : Sim_Info_Acc; - begin - if List = Iir_Flist_All or else List = Iir_Flist_Others then - raise Internal_Error; - end if; - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Info := Get_Info (Get_Named_Entity (El)); - pragma Assert (Sub_Conf (Info.Inst_Slot) = Null_Iir); - Sub_Conf (Info.Inst_Slot) := Item; - end loop; - end; - - when others => - Error_Kind ("elaborate_block_configuration", Item); - end case; - Item := Get_Chain (Item); - end loop; - - -- Configure sub instances. - for I in Sub_Instances'Range loop - declare - Sub_Inst : constant Block_Instance_Acc := Sub_Instances (I); - Stmt : Iir; - begin - if Sub_Inst /= null then - Stmt := Sub_Inst.Label; - case Get_Kind (Stmt) is - when Iir_Kind_Generate_Statement_Body => - Stmt := Get_Parent (Stmt); - case Get_Kind (Stmt) is - when Iir_Kind_For_Generate_Statement => - Apply_Block_Configuration_To_Iterative_Generate - (Stmt, Sub_Conf (I), Sub_Inst); - when Iir_Kind_If_Generate_Statement - | Iir_Kind_If_Generate_Else_Clause => - Elaborate_Block_Configuration - (Sub_Conf (I), Sub_Inst); - when others => - raise Internal_Error; - end case; - when Iir_Kind_Block_Statement => - Elaborate_Block_Configuration (Sub_Conf (I), Sub_Inst); - when Iir_Kind_Component_Instantiation_Statement => - if Is_Component_Instantiation (Stmt) then - Elaborate_Component_Configuration - (Stmt, Sub_Inst, Sub_Conf (I)); - else - -- Nothing to do for entity instantiation, will be - -- done during elaboration of statements. - null; - end if; - when others => - Error_Kind ("elaborate_block_configuration", Stmt); - end case; - end if; - end; - end loop; - end Elaborate_Block_Configuration; - - procedure Elaborate_Alias_Declaration - (Instance : Block_Instance_Acc; Decl : Iir_Object_Alias_Declaration) - is - Alias_Type : Iir; - Res : Iir_Value_Literal_Acc; - begin - -- LRM93 12.3.1.5 - -- Elaboration of an alias declaration consists of the elaboration - -- of the subtype indication to establish the subtype associated - -- with the alias, folloed by the creation of the alias as an - -- alternative name for the named entity. - -- The creation of an alias for an array object involves a check - -- that the subtype associated with the alias includes a matching - -- element for each element of the named object. - -- It is an error if this check fails. - Alias_Type := Get_Type (Decl); - Elaborate_Subtype_Indication_If_Anonymous (Instance, Alias_Type); - Create_Object (Instance, Decl); - Res := Execute_Name (Instance, Get_Name (Decl), True); - Implicit_Array_Conversion (Instance, Res, Alias_Type, Get_Name (Decl)); - Instance.Objects (Get_Info (Decl).Slot) := - Unshare_Bounds (Res, Instance_Pool); - end Elaborate_Alias_Declaration; - - -- LRM93 §12.3.2.3 Disconnection Specifications - procedure Elaborate_Disconnection_Specification - (Instance : Block_Instance_Acc; - Decl : Iir_Disconnection_Specification) - is - Time_Val : Iir_Value_Literal_Acc; - Time : Iir_Value_Time; - List : Iir_Flist; - Sig : Iir; - Val : Iir_Value_Literal_Acc; - begin - -- LRM93 §12.3.2.3 - -- Elaboration of a disconnection specification proceeds as follows: - -- 2. The time expression is evaluated to determine the disconnection - -- time for drivers of the affected signals. - Time_Val := Execute_Expression (Instance, Get_Expression (Decl)); - Time := Time_Val.I64; - - -- LRM93 5.3 - -- The time expression in a disconnection specification must be static - -- and must evaluate to a non-negative value. - - if Time < 0 then - Error_Msg_Sem (+Decl, "time must be non-negative"); - end if; - - -- LRM93 §12.3.2.3 - -- 1. The guarded signal specification is elaborated in order to - -- identify the signals affected by the disconnection specification. - -- - -- 3. The diconnection time is associated with each affected signal for - -- later use in constructing disconnection statements in the - -- equivalent processes for guarded assignments to the affected - -- signals. - List := Get_Signal_List (Decl); - case List is - when Iir_Flist_All - | Iir_Flist_Others => - Error_Kind ("elaborate_disconnection_specification", Decl); - when others => - for I in Flist_First .. Flist_Last (List) loop - Sig := Get_Nth_Element (List, I); - Val := Execute_Name (Instance, Sig, True); - Disconnection_Table.Append ((Sig => Val, Time => Time)); - end loop; - end case; - end Elaborate_Disconnection_Specification; - - procedure Elaborate_Branch_Quantity_Declaration - (Instance : Block_Instance_Acc; Decl : Iir) - is - Terminal_Plus, Terminal_Minus : Iir; - Plus, Minus : Iir_Value_Literal_Acc; - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Quantity (Instance, Decl); - - Terminal_Plus := Get_Plus_Terminal (Decl); - Plus := Execute_Name (Instance, Terminal_Plus, True); - Terminal_Minus := Get_Minus_Terminal (Decl); - if Terminal_Minus = Null_Iir then - -- Get the reference of the nature - -- FIXME: select/index - Terminal_Minus := Get_Reference (Get_Nature (Terminal_Plus)); - end if; - Minus := Execute_Name (Instance, Terminal_Minus, True); - - case Iir_Kinds_Branch_Quantity_Declaration (Get_Kind (Decl)) is - when Iir_Kind_Across_Quantity_Declaration => - -- Expr: q - P'ref + M'ref - Add_Characteristic_Expression - (Structural, - Build - (Op_Plus, Res.Quantity, - Build (Op_Minus, - Get_Terminal_Reference (Plus.Terminal), - Build (Op_Plus, - Get_Terminal_Reference (Minus.Terminal))))); - when Iir_Kind_Through_Quantity_Declaration => - -- P'Contrib <- P'Contrib + q - -- M'Contrib <- M'Contrib - q - Append_Characteristic_Expression - (Plus.Terminal, Build (Op_Plus, Res.Quantity)); - Append_Characteristic_Expression - (Minus.Terminal, Build (Op_Minus, Res.Quantity)); - end case; - end Elaborate_Branch_Quantity_Declaration; - - -- LRM93 §12.3.1 Elaboration of a declaration - procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir) - is - Expr_Mark : Mark_Type; - Val : Iir_Value_Literal_Acc; - begin - Mark (Expr_Mark, Expr_Pool); - - -- Elaboration of a declaration has the effect of creating the declared - -- item. For each declaration, the language rules (in particular scope - -- and visibility rules) are such that it is either impossible or - -- illegal to use a given item before the elaboration of its - -- corresponding declaration. - -- Similarly, it is illegal to call a subprogram before its - -- corresponding body is elaborated. - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Get_Implicit_Definition (Decl) in Iir_Predefined_Explicit - and then not Is_Second_Subprogram_Specification (Decl) - then - Elaborate_Subprogram_Declaration (Instance, Decl); - end if; - when Iir_Kind_Anonymous_Type_Declaration => - Elaborate_Type_Definition (Instance, Get_Type_Definition (Decl)); - when Iir_Kind_Type_Declaration => - Elaborate_Type_Declaration (Instance, Decl); - when Iir_Kind_Subtype_Declaration => - Elaborate_Subtype_Indication (Instance, Get_Type (Decl)); - when Iir_Kind_Iterator_Declaration => - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (Decl)); - Val := Create_Value_For_Type - (Instance, Get_Type (Decl), Init_Value_Default); - Create_Object (Instance, Decl); - Instance.Objects (Get_Info (Decl).Slot) := - Unshare (Val, Instance_Pool); - when Iir_Kind_Signal_Declaration => - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (Decl)); - Val := Elaborate_Default_Value (Instance, Decl); - Create_Signal (Instance, Decl); - Elaborate_Signal (Instance, Decl, Val); - when Iir_Kind_Variable_Declaration => - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (Decl)); - Val := Elaborate_Default_Value (Instance, Decl); - Create_Object (Instance, Decl); - Instance.Objects (Get_Info (Decl).Slot) := - Unshare (Val, Instance_Pool); - when Iir_Kind_Constant_Declaration => - declare - Deferred_Decl : constant Iir := Get_Deferred_Declaration (Decl); - First_Decl : Iir; - begin - if Deferred_Decl = Null_Iir - or else Get_Deferred_Declaration_Flag (Decl) - then - -- Create the object (except for full declaration of a - -- deferred constant). - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (Decl)); - Create_Object (Instance, Decl); - end if; - -- Initialize the value (except for a deferred declaration). - if Deferred_Decl = Null_Iir then - First_Decl := Decl; - elsif not Get_Deferred_Declaration_Flag (Decl) then - First_Decl := Deferred_Decl; - else - First_Decl := Null_Iir; - end if; - if First_Decl /= Null_Iir then - Val := Execute_Expression_With_Type - (Instance, Get_Default_Value (Decl), - Get_Type (First_Decl)); - Instance.Objects (Get_Info (First_Decl).Slot) := - Unshare (Val, Instance_Pool); - end if; - end; - when Iir_Kind_File_Declaration => - -- LRM93 12.3.1.4 - -- Elaboration of a file object declaration consists of the - -- elaboration of the subtype indication... - null; -- FIXME ?? - -- ...followed by the creation of object. - Create_Object (Instance, Decl); - -- If the file object declaration contains file_open_information, - -- then the implicit call to FILE_OPEN is then executed. - Instance.Objects (Get_Info (Decl).Slot) := Unshare - (File_Operation.Elaborate_File_Declaration (Instance, Decl), - Instance_Pool); - when Iir_Kind_Object_Alias_Declaration => - Elaborate_Alias_Declaration (Instance, Decl); - when Iir_Kind_Component_Declaration => - -- LRM93 12.3.1.7 - -- Elaboration of a component declaration has no effect other - -- than to create a template for instantiating component - -- instances. - null; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - null; - when Iir_Kind_Configuration_Specification => - -- Elaboration of a configuration specification proceeds as - -- follows: - -- 1. The component specification is elaborated in order to - -- determine which component instances are affected by the - -- configuration specification. - -- GHDL: this is done during sem. - - -- 2. The binding indication is elaborated to identify the design - -- entity to which the affected component instances will be - -- bound. - -- GHDL: this is already done during sem, according to rules - -- defined by section 5.3.1.1 - - -- 3. The binding information is associated with each affected - -- component instance label for later use in instantiating - -- those component instances. - -- GHDL: this is done during step 1. - - -- As part of this elaboration process, a check is made that both - -- the entity declaration and the corresponding architecture body - -- implied by the binding indication exist whithin the specified - -- library. - -- It is an error if this check fails. - -- GHDL: this is already done during sem, according to rules - -- defined by section 5.3.1.1 - null; - - when Iir_Kind_Attribute_Declaration => - -- LRM93 12.3.1.6 - -- Elaboration of an attribute declaration has no effect other - -- than to create a template for defining attributes of items. - null; - - when Iir_Kind_Attribute_Specification => - -- LRM93 12.3.2.1 - -- Elaboration of an attribute specification proceeds as follows: - -- 1. The entity specification is elaborated in order to - -- determine which items are affected by the attribute - -- specification. - -- GHDL: done by sem. - - declare - Attr_Decl : constant Iir := - Get_Named_Entity (Get_Attribute_Designator (Decl)); - Attr_Type : constant Iir := Get_Type (Attr_Decl); - Value : Iir_Attribute_Value; - Val : Iir_Value_Literal_Acc; - begin - Value := Get_Attribute_Value_Spec_Chain (Decl); - while Value /= Null_Iir loop - Elaborate_Subtype_Indication_If_Anonymous - (Instance, Get_Type (Value)); - -- 2. The expression is evaluated to determine the value - -- of the attribute. - -- It is an error if the value of the expression does not - -- belong to the subtype of the attribute; if the - -- attribute is of an array type, then an implicit - -- subtype conversion is first performed on the value, - -- unless the attribute's subtype indication denotes an - -- unconstrained array type. - Val := Execute_Expression (Instance, Get_Expression (Decl)); - Check_Constraints (Instance, Val, Attr_Type, Decl); - - -- 3. A new instance of the designated attribute is created - -- and associated with each of the affected items. - -- - -- 4. Each new attribute instance is assigned the value of - -- the expression. - Create_Object (Instance, Value); - Instance.Objects (Get_Info (Value).Slot) := - Unshare (Val, Instance_Pool); - - Value := Get_Spec_Chain (Value); - end loop; - end; - - when Iir_Kind_Disconnection_Specification => - Elaborate_Disconnection_Specification (Instance, Decl); - - when Iir_Kind_Use_Clause => - null; - - when Iir_Kind_Signal_Attribute_Declaration => - declare - Attr : Iir; - begin - Attr := Get_Signal_Attribute_Chain (Decl); - while Is_Valid (Attr) loop - case Iir_Kinds_Signal_Attribute (Get_Kind (Attr)) is - when Iir_Kind_Delayed_Attribute => - Elaborate_Delayed_Signal (Instance, Attr); - when Iir_Kind_Stable_Attribute => - Elaborate_Implicit_Signal - (Instance, Attr, Mode_Stable); - when Iir_Kind_Quiet_Attribute => - Elaborate_Implicit_Signal - (Instance, Attr, Mode_Quiet); - when Iir_Kind_Transaction_Attribute => - Elaborate_Implicit_Signal - (Instance, Attr, Mode_Transaction); - end case; - Attr := Get_Attr_Chain (Attr); - end loop; - end; - - when Iir_Kind_Non_Object_Alias_Declaration => - null; - when Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration => - null; - when Iir_Kind_Protected_Type_Body => - null; - - when Iir_Kind_Nature_Declaration => - Elaborate_Nature_Definition (Instance, Get_Nature (Decl)); - Create_Terminal (Instance, Get_Chain (Decl)); - - when Iir_Kind_Terminal_Declaration => - Create_Terminal (Instance, Decl); - - when Iir_Kinds_Branch_Quantity_Declaration => - Elaborate_Branch_Quantity_Declaration (Instance, Decl); - - when others => - Error_Kind ("elaborate_declaration", Decl); - end case; - - Release (Expr_Mark, Expr_Pool); - end Elaborate_Declaration; - - procedure Destroy_Iterator_Declaration - (Instance : Block_Instance_Acc; Decl : Iir) - is - Obj_Type : constant Iir := Get_Type (Decl); - Constraint : Iir; - Cons_Info : Sim_Info_Acc; - begin - if Get_Kind (Decl) /= Iir_Kind_Iterator_Declaration then - raise Internal_Error; - end if; - Destroy_Object (Instance, Decl); - - if Get_Kind (Obj_Type) = Iir_Kind_Range_Array_Attribute - or else not Is_Anonymous_Type_Definition (Obj_Type) - then - return; - end if; - - Constraint := Get_Range_Constraint (Obj_Type); - if Get_Kind (Constraint) /= Iir_Kind_Range_Expression then - return; - end if; - Cons_Info := Get_Info (Constraint); - if Cons_Info.Obj_Scope = Instance.Block_Scope - and then Cons_Info.Slot = Instance.Elab_Objects - then - Destroy_Object (Instance, Constraint); - end if; - end Destroy_Iterator_Declaration; - - procedure Finalize_Declarative_Part - (Instance : Block_Instance_Acc; Decl_Chain : Iir) - is - Decl : Iir; - Val : Iir_Value_Literal_Acc; - begin - Decl := Decl_Chain; - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_File_Declaration => - -- LRM93 3.4.1 - -- An implicit call to FILE_CLOSE exists in a subprogram body - -- for every file object declared in the corresponding - -- subprogram declarative part. - -- Each such call associates a unique file object with the - -- formal parameter F and is called whenever the corresponding - -- subprogram completes its execution. - Val := Instance.Objects (Get_Info (Decl).Slot); - if Get_Text_File_Flag (Get_Type (Decl)) then - File_Operation.File_Close_Text (Val, Null_Iir); - File_Operation.File_Destroy_Text (Val); - else - File_Operation.File_Close_Binary (Val, Null_Iir); - File_Operation.File_Destroy_Binary (Val); - end if; - when others => - null; - end case; - Decl := Get_Chain (Decl); - end loop; - end Finalize_Declarative_Part; - - -- LRM93 §12.3 Elaboration of a Declarative Part - procedure Elaborate_Declarative_Part - (Instance : Block_Instance_Acc; Decl_Chain : Iir) - is - Decl : Iir; - begin - -- The elaboration of a declarative part consists of the elaboration - -- of the declarative items, if any, in the order in which they are - -- given in the declarative part. - -- [Exception for 'foreign ] - Decl := Decl_Chain; - while Decl /= Null_Iir loop - -- In certain cases, the elaboration of a declarative item involves - -- the evaluation of expressions that appear within the declarative - -- item. - -- The value of any object denoted by a primary in such an expression - -- must be defined at the time the primary is read. - -- In addition, if a primary in such an expression is a function call - -- then the value of any object denoted or appearing as part of an - -- actual designator in the function call must be defined at the - -- time the expression is evaluated. - -- FIXME: check this. - Elaborate_Declaration (Instance, Decl); - Decl := Get_Chain (Decl); - end loop; - end Elaborate_Declarative_Part; - - function Elaborate_Architecture (Arch : Iir_Architecture_Body; - Conf : Iir_Block_Configuration; - Parent_Instance : Block_Instance_Acc; - Stmt : Iir; - Generic_Map : Iir; - Port_Map : Iir) - return Block_Instance_Acc - is - Entity : constant Iir_Entity_Declaration := Get_Entity (Arch); - Instance : Block_Instance_Acc; - Expr_Mark : Mark_Type; - begin - Mark (Expr_Mark, Expr_Pool); - - if Trace_Elaboration then - Ada.Text_IO.Put ("elaborating "); - Ada.Text_IO.Put (Image_Identifier (Arch)); - Ada.Text_IO.Put (" of "); - Ada.Text_IO.Put_Line (Image_Identifier (Entity)); - end if; - - Instance := Create_Block_Instance (Parent_Instance, Arch, Stmt); - Instance.Up_Block := null; -- Packages_Instance; - - -- LRM93 §12.1 - -- Elaboration of a block statement involves first elaborating each not - -- yet elaborated package containing declarations referenced by the - -- block. - Elaborate_Dependence (Get_Design_Unit (Arch)); - - Current_Component := Parent_Instance; - Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Entity)); - Elaborate_Generic_Map_Aspect (Instance, Parent_Instance, - Get_Generic_Chain (Entity), Generic_Map); - Elaborate_Port_Clause (Instance, Get_Port_Chain (Entity)); - Elaborate_Port_Map_Aspect (Instance, Parent_Instance, - Get_Port_Chain (Entity), Port_Map); - Current_Component := null; - - Elaborate_Declarative_Part - (Instance, Get_Declaration_Chain (Entity)); - Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Arch)); - Elaborate_Statement_Part - (Instance, Get_Concurrent_Statement_Chain (Entity)); - Elaborate_Statement_Part - (Instance, Get_Concurrent_Statement_Chain (Arch)); - - -- Configure the unit. This will create sub units. - Elaborate_Block_Configuration (Conf, Instance); - - Release (Expr_Mark, Expr_Pool); - - return Instance; - end Elaborate_Architecture; - - function Override_Generic (Formal : Iir; Str : String) return Iir - is - use Evaluation; - Formal_Type : constant Iir := Get_Type (Formal); - Formal_Btype : constant Iir := Get_Base_Type (Formal_Type); - Res : Iir; - begin - case Get_Kind (Formal_Btype) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Enumeration_Type_Definition => - Res := Eval_Value_Attribute (Str, Formal_Type, Formal); - if not Eval_Is_In_Bound (Res, Formal_Type) then - Error_Msg_Elab - ("override for %n is out of bounds", +Formal); - return Null_Iir; - end if; - return Res; - when Iir_Kind_Array_Type_Definition => - if Is_One_Dimensional_Array_Type (Formal_Btype) then - declare - use Str_Table; - Str8 : String8_Id; - Ntype : Iir; - begin - Str8 := Create_String8; - Append_String8_String (Str); - Res := Create_Iir (Iir_Kind_String_Literal8); - Set_String8_Id (Res, Str8); - -- FIXME: check characters are in the type. - Set_String_Length (Res, Str'Length); - Set_Expr_Staticness (Res, Locally); - Ntype := Create_Unidim_Array_By_Length - (Get_Base_Type (Formal_Type), Str'Length, Res); - Set_Type (Res, Ntype); - Set_Literal_Subtype (Res, Ntype); - return Res; - end; - end if; - when others => - null; - end case; - Error_Msg_Elab ("unhandled override for %n", +Formal); - return Null_Iir; - end Override_Generic; - - procedure Override_Generics - (Map : in out Iir; First : Grt.Options.Generic_Override_Acc) - is - use Grt.Options; - Over : Generic_Override_Acc; - Id : Name_Id; - Gen : Iir; - Prev : Iir; - Val : Iir; - Assoc : Iir; - begin - Over := First; - Prev := Null_Iir; - while Over /= null loop - Id := Name_Table.Get_Identifier (Over.Name.all); - - -- Find existing association in map. There should be one association - -- for each generic. - Gen := Map; - while Gen /= Null_Iir loop - exit when Get_Identifier (Get_Formal (Map)) = Id; - Prev := Gen; - Gen := Get_Chain (Gen); - end loop; - - if Gen = Null_Iir then - Error_Msg_Elab - ("no generic '" & Name_Table.Image (Id) & "' for -g"); - else - -- Replace the association with one for the override value. - Val := Override_Generic (Get_Formal (Map), Over.Value.all); - if Val /= Null_Iir then - Assoc := - Create_Iir (Iir_Kind_Association_Element_By_Expression); - Set_Actual (Assoc, Val); - Set_Whole_Association_Flag (Assoc, True); - Set_Formal (Assoc, Get_Formal (Map)); - - Set_Chain (Assoc, Get_Chain (Gen)); - if Prev = Null_Iir then - Map := Assoc; - else - Set_Chain (Prev, Assoc); - end if; - end if; - end if; - Over := Over.Next; - end loop; - end Override_Generics; - - procedure Check_No_Unconstrained (Ports : Iir; Map : Iir) - is - Assoc : Iir; - Port : Iir; - Formal : Iir; - begin - Assoc := Map; - Port := Ports; - while Assoc /= Null_Iir loop - if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then - Formal := Get_Association_Interface (Assoc, Port); - if Get_Default_Value (Formal) = Null_Iir - and then not Is_Fully_Constrained_Type (Get_Type (Formal)) - then - Error_Msg_Elab - (Formal, "top-level %n must have a value", +Formal); - end if; - end if; - Next_Association_Interface (Assoc, Port); - end loop; - end Check_No_Unconstrained; - - -- Elaborate a design. - procedure Elaborate_Design (Design: Iir_Design_Unit) - is - Unit : constant Iir := Get_Library_Unit (Design); - Conf_Unit : Iir_Design_Unit; - Conf : Iir_Block_Configuration; - Arch_Unit : Iir_Design_Unit; - Arch : Iir_Architecture_Body; - Entity : Iir_Entity_Declaration; - Generic_Map : Iir; - Port_Map : Iir; - begin - Package_Instances := new Package_Instances_Array (1 .. Nbr_Packages); - - -- Use a 'fake' process to execute code during elaboration. - Current_Process := No_Process; - - Instance_Pool := Global_Pool'Access; - - pragma Assert (Is_Empty (Expr_Pool)); - - -- Find architecture and configuration for the top unit - case Get_Kind (Unit) is - when Iir_Kind_Architecture_Body => - Arch := Unit; - Conf_Unit := Get_Default_Configuration_Declaration (Unit); - when Iir_Kind_Configuration_Declaration => - Conf_Unit := Design; - Arch := Get_Named_Entity - (Get_Block_Specification (Get_Block_Configuration (Unit))); - Elaborate_Dependence (Design); - Elaborate_Configuration_Declaration (Unit); - when others => - Error_Kind ("elaborate_design", Unit); - end case; - - Arch_Unit := Get_Design_Unit (Arch); - Entity := Get_Entity (Arch); - - pragma Assert (Is_Empty (Expr_Pool)); - - Elaborate_Dependence (Arch_Unit); - - -- Sanity check: memory area for expressions must be empty. - pragma Assert (Is_Empty (Expr_Pool)); - - -- Use default values for top entity generics and ports. - Generic_Map := Create_Default_Association - (Get_Generic_Chain (Entity), Null_Iir, Entity); - Port_Map := Create_Default_Association - (Get_Port_Chain (Entity), Null_Iir, Entity); - Override_Generics (Generic_Map, Grt.Options.First_Generic_Override); - - Check_No_Unconstrained (Get_Generic_Chain (Entity), Generic_Map); - Check_No_Unconstrained (Get_Port_Chain (Entity), Port_Map); - - -- Stop now in case of errors. - if Nbr_Errors /= 0 then - Grt.Errors.Fatal_Error; - end if; - - -- Elaborate from the top configuration. - Conf := Get_Block_Configuration (Get_Library_Unit (Conf_Unit)); - Top_Instance := Elaborate_Architecture - (Arch, Conf, null, Arch, Generic_Map, Port_Map); - - Current_Process := null; - - Instance_Pool := null; - - -- Stop now in case of errors. - if Nbr_Errors /= 0 then - Grt.Errors.Fatal_Error; - end if; - - -- Sanity check: memory area for expressions must be empty. - pragma Assert (Is_Empty (Expr_Pool)); - end Elaborate_Design; - -end Elaboration; diff --git a/src/vhdl/simulate/elaboration.ads b/src/vhdl/simulate/elaboration.ads deleted file mode 100644 index 6bbb91cc1..000000000 --- a/src/vhdl/simulate/elaboration.ads +++ /dev/null @@ -1,187 +0,0 @@ --- Elaboration for interpretation --- 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 Tables; -with Types; use Types; -with Iirs; use Iirs; -with Iir_Values; use Iir_Values; -with Grt.Types; use Grt.Types; -with Annotations; use Annotations; - --- This package elaborates design hierarchy. - -package Elaboration is - Trace_Elaboration : Boolean := False; - Trace_Drivers : Boolean := False; - - -- Number of block instances and also Id of the last one. - Nbr_Block_Instances : Block_Instance_Id := 0; - - -- A block instance with its architecture/entity declaration is an - -- instancied entity. - - procedure Elaborate_Design (Design: Iir_Design_Unit); - - procedure Elaborate_Declarative_Part - (Instance : Block_Instance_Acc; Decl_Chain : Iir); - - -- Reverse operation of Elaborate_Declarative_Part. - -- At least, finalize files. - procedure Finalize_Declarative_Part - (Instance : Block_Instance_Acc; Decl_Chain : Iir); - - procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir); - - procedure Destroy_Iterator_Declaration - (Instance : Block_Instance_Acc; Decl : Iir); - - -- How are created scalar values for Create_Value_For_Type. - type Init_Value_Kind is - (-- Use the default value for the type (lefmost value). - Init_Value_Default, - - -- Undefined. The caller doesn't care as it will overwrite the value. - Init_Value_Any, - - -- Create signal placeholder. Only for individual associations. - Init_Value_Signal); - - -- Create a value for type DECL. - function Create_Value_For_Type - (Block: Block_Instance_Acc; Decl: Iir; Init : Init_Value_Kind) - return Iir_Value_Literal_Acc; - - -- LRM93 §12.3.1.3 Subtype Declarations - -- The elaboration of a subtype indication creates a subtype. - -- Used for allocator. - procedure Elaborate_Subtype_Indication - (Instance : Block_Instance_Acc; Ind : Iir); - - -- Create object DECL. - -- This does nothing except marking DECL as elaborated. - -- Used by simulation to dynamically create subprograms interfaces. - procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir); - procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir); - - Top_Instance: Block_Instance_Acc; - - type Block_Instance_Acc_Array is array (Instance_Slot_Type range <>) of - Block_Instance_Acc; - - type Package_Instances_Array is array (Pkg_Index_Type range <>) of - Block_Instance_Acc; - type Package_Instances_Array_Acc is access Package_Instances_Array; - - Package_Instances : Package_Instances_Array_Acc; - - -- Disconnections. For each disconnection specification, the elaborator - -- adds an entry in the table. - type Disconnection_Entry is record - Sig : Iir_Value_Literal_Acc; - Time : Iir_Value_Time; - end record; - - package Disconnection_Table is new Tables - (Table_Component_Type => Disconnection_Entry, - Table_Index_Type => Integer, - Table_Low_Bound => 0, - Table_Initial => 16); - - -- Connections. For each associations (block/component/entry), the - -- elaborator adds an entry in that table. - type Connect_Entry is record - Formal : Iir_Value_Literal_Acc; - Formal_Instance : Block_Instance_Acc; - Actual : Iir_Value_Literal_Acc; - Actual_Instance : Block_Instance_Acc; - Inter : Iir; - Assoc : Iir; - end record; - - package Connect_Table is new Tables - (Table_Component_Type => Connect_Entry, - Table_Index_Type => Integer, - Table_Low_Bound => 0, - Table_Initial => 32); - - -- Signals. - - type Signal_Entry (Kind : Mode_Signal_Type := Mode_Signal) is record - Decl : Iir; - Sig : Iir_Value_Literal_Acc; - Val : Iir_Value_Literal_Acc; - Instance : Block_Instance_Acc; - case Kind is - when Mode_Signal_User => - null; - when Mode_Quiet | Mode_Stable | Mode_Delayed - | Mode_Transaction => - Time : Std_Time; - Prefix : Iir_Value_Literal_Acc; - when Mode_Guard => - null; - when Mode_Conv_In | Mode_Conv_Out | Mode_End => - -- Unused. - null; - end case; - end record; - - package Signals_Table is new Tables - (Table_Component_Type => Signal_Entry, - Table_Index_Type => Integer, - Table_Low_Bound => 0, - Table_Initial => 128); - - type Process_Index_Type is new Natural; - - package Processes_Table is new Tables - (Table_Component_Type => Block_Instance_Acc, - Table_Index_Type => Process_Index_Type, - Table_Low_Bound => 1, - Table_Initial => 128); - - package Protected_Table is new Tables - (Table_Component_Type => Block_Instance_Acc, - Table_Index_Type => Protected_Index_Type, - Table_Low_Bound => 1, - Table_Initial => 2); - - package Environment_Table is new Tables - (Table_Component_Type => Block_Instance_Acc, - Table_Index_Type => Environment_Index_Type, - Table_Low_Bound => 1, - Table_Initial => 2); - - type Boolean_Vector is array (Nat32 range <>) of Boolean; - type Boolean_Vector_Acc is access Boolean_Vector; - - type PSL_Entry is record - Instance : Block_Instance_Acc; - Stmt : Iir; - States : Boolean_Vector_Acc; - Done : Boolean; - end record; - - type PSL_Index_Type is new Natural; - - package PSL_Table is new Tables - (Table_Component_Type => PSL_Entry, - Table_Index_Type => PSL_Index_Type, - Table_Low_Bound => 1, - Table_Initial => 2); -end Elaboration; diff --git a/src/vhdl/simulate/execution.adb b/src/vhdl/simulate/execution.adb deleted file mode 100644 index dc4792490..000000000 --- a/src/vhdl/simulate/execution.adb +++ /dev/null @@ -1,4831 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Unchecked_Conversion; -with Ada.Text_IO; use Ada.Text_IO; -with System; -with Grt.Types; use Grt.Types; -with Flags; use Flags; -with Errorout; use Errorout; -with Std_Package; -with Evaluation; -with Iirs_Utils; use Iirs_Utils; -with Annotations; use Annotations; -with Name_Table; -with File_Operation; -with Debugger; use Debugger; -with Std_Names; -with Str_Table; -with Files_Map; -with Iir_Chains; use Iir_Chains; -with Simulation; use Simulation; -with Grt.Astdio; -with Grt.Stdio; -with Grt.Options; -with Grt.Vstrings; -with Grt_Interface; -with Grt.Values; -with Grt.Errors; -with Grt.Std_Logic_1164; -with Grt.Lib; -with Grt.Strings; -with Sem_Inst; - -package body Execution is - - function Execute_Function_Call - (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) - return Iir_Value_Literal_Acc; - - procedure Finish_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir); - procedure Init_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir); - procedure Update_Next_Statement (Proc : Process_State_Acc); - - -- Display a message when an assertion has failed. - procedure Execute_Failed_Assertion (Msg : String; - Report : String; - Severity : Natural; - Stmt: Iir); - - function Get_Instance_By_Scope - (Instance: Block_Instance_Acc; Scope: Scope_Type) - return Block_Instance_Acc is - begin - case Scope.Kind is - when Scope_Kind_Frame => - declare - Current : Block_Instance_Acc; - Last : Block_Instance_Acc; - begin - Current := Instance; - while Current /= null loop - if Current.Block_Scope = Scope then - return Current; - end if; - Last := Current; - Current := Current.Up_Block; - end loop; - if Scope.Depth = 0 - and then Last.Block_Scope.Kind = Scope_Kind_Package - then - -- For instantiated packages. - return Last; - end if; - raise Internal_Error; - end; - when Scope_Kind_Package => - -- Global scope (packages) - return Package_Instances (Scope.Pkg_Index); - when Scope_Kind_Component => - pragma Assert (Current_Component /= null); - return Current_Component; - when Scope_Kind_None => - raise Internal_Error; - when Scope_Kind_Pkg_Inst => - raise Internal_Error; - end case; - end Get_Instance_By_Scope; - - function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) - return Block_Instance_Acc is - begin - return Get_Instance_By_Scope (Instance, Get_Info (Decl).Obj_Scope); - end Get_Instance_For_Slot; - - procedure Create_Right_Bound_From_Length - (Bounds : Iir_Value_Literal_Acc; Len : Iir_Index32) - is - begin - pragma Assert (Bounds.Right = null); - - case Bounds.Left.Kind is - when Iir_Value_E32 => - declare - R : Ghdl_E32; - begin - case Bounds.Dir is - when Iir_To => - R := Bounds.Left.E32 + Ghdl_E32 (Len - 1); - when Iir_Downto => - R := Bounds.Left.E32 - Ghdl_E32 (Len - 1); - end case; - Bounds.Right := Create_E32_Value (R); - end; - when Iir_Value_I64 => - declare - R : Ghdl_I64; - begin - case Bounds.Dir is - when Iir_To => - R := Bounds.Left.I64 + Ghdl_I64 (Len - 1); - when Iir_Downto => - R := Bounds.Left.I64 - Ghdl_I64 (Len - 1); - end case; - Bounds.Right := Create_I64_Value (R); - end; - when others => - raise Internal_Error; - end case; - end Create_Right_Bound_From_Length; - - function Create_Bounds_From_Length (Block : Block_Instance_Acc; - Atype : Iir; - Len : Iir_Index32) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - Index_Bounds : Iir_Value_Literal_Acc; - begin - Index_Bounds := Execute_Bounds (Block, Atype); - - Res := Create_Range_Value (Left => Index_Bounds.Left, - Right => null, - Dir => Index_Bounds.Dir, - Length => Len); - - if Len = 0 then - -- Special case. - Res.Right := Res.Left; - case Res.Left.Kind is - when Iir_Value_I64 => - case Index_Bounds.Dir is - when Iir_To => - Res.Left := Create_I64_Value (Res.Right.I64 + 1); - when Iir_Downto => - Res.Left := Create_I64_Value (Res.Right.I64 - 1); - end case; - when others => - raise Internal_Error; - end case; - else - Create_Right_Bound_From_Length (Res, Len); - end if; - return Res; - end Create_Bounds_From_Length; - - function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - if Bounds.Dir = Iir_To then - return Bounds.Right; - else - return Bounds.Left; - end if; - end Execute_High_Limit; - - function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - if Bounds.Dir = Iir_To then - return Bounds.Left; - else - return Bounds.Right; - end if; - end Execute_Low_Limit; - - function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Bounds.Left; - end Execute_Left_Limit; - - function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Bounds.Right; - end Execute_Right_Limit; - - function Execute_Length (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Create_I64_Value (Ghdl_I64 (Bounds.Length)); - end Execute_Length; - - function Create_Enum_Value (Pos : Natural; Etype : Iir) - return Iir_Value_Literal_Acc - is - Base_Type : constant Iir := Get_Base_Type (Etype); - Mode : constant Iir_Value_Kind := - Get_Info (Base_Type).Scalar_Mode; - begin - case Iir_Value_Enums (Mode) is - when Iir_Value_E8 => - return Create_E8_Value (Ghdl_E8 (Pos)); - when Iir_Value_E32 => - return Create_E32_Value (Ghdl_E32 (Pos)); - when Iir_Value_B1 => - return Create_B1_Value (Ghdl_B1'Val (Pos)); - end case; - end Create_Enum_Value; - - function String_To_Iir_Value (Str : String) return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value (Str'Length, 1); - Res.Bounds.D (1) := Create_Range_Value - (Create_I64_Value (1), - Create_I64_Value (Str'Length), - Iir_To); - for I in Str'Range loop - Res.Val_Array.V (1 + Iir_Index32 (I - Str'First)) := - Create_E8_Value (Character'Pos (Str (I))); - end loop; - return Res; - end String_To_Iir_Value; - - function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; - Expr_Type : Iir) - return String - is - begin - case Get_Kind (Expr_Type) is - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - declare - Str : String (1 .. 24); - Last : Natural; - begin - Grt.Vstrings.To_String (Str, Last, Val.F64); - return Str (Str'First .. Last); - end; - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - declare - Str : String (1 .. 21); - First : Natural; - begin - Grt.Vstrings.To_String (Str, First, Val.I64); - return Str (First .. Str'Last); - end; - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - declare - Lits : constant Iir_Flist := - Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); - Pos : Natural; - begin - case Iir_Value_Enums (Val.Kind) is - when Iir_Value_B1 => - Pos := Ghdl_B1'Pos (Val.B1); - when Iir_Value_E8 => - Pos := Ghdl_E8'Pos (Val.E8); - when Iir_Value_E32 => - Pos := Ghdl_E32'Pos (Val.E32); - end case; - return Name_Table.Image - (Get_Identifier (Get_Nth_Element (Lits, Pos))); - end; - when Iir_Kind_Physical_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - declare - Str : String (1 .. 21); - First : Natural; - Id : constant Name_Id := - Get_Identifier (Get_Primary_Unit (Get_Base_Type (Expr_Type))); - begin - Grt.Vstrings.To_String (Str, First, Val.I64); - return Str (First .. Str'Last) & ' ' & Name_Table.Image (Id); - end; - when others => - Error_Kind ("execute_image_attribute", Expr_Type); - end case; - end Execute_Image_Attribute; - - function Execute_Image_Attribute (Block: Block_Instance_Acc; Expr: Iir) - return Iir_Value_Literal_Acc - is - Val : Iir_Value_Literal_Acc; - Attr_Type : constant Iir := Get_Type (Get_Prefix (Expr)); - begin - Val := Execute_Expression (Block, Get_Parameter (Expr)); - return String_To_Iir_Value - (Execute_Image_Attribute (Val, Attr_Type)); - end Execute_Image_Attribute; - - function Execute_Path_Instance_Name_Attribute - (Block : Block_Instance_Acc; Attr : Iir) return Iir_Value_Literal_Acc - is - use Evaluation; - use Grt.Vstrings; - use Name_Table; - - Name : constant Path_Instance_Name_Type := - Get_Path_Instance_Name_Suffix (Attr); - Instance : Block_Instance_Acc; - Rstr : Rstring; - Is_Instance : constant Boolean := - Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; - begin - if Name.Path_Instance = Null_Iir then - return String_To_Iir_Value (Name.Suffix); - end if; - - Instance := Get_Instance_By_Scope - (Block, Get_Info (Name.Path_Instance).Frame_Scope); - - loop - case Get_Kind (Instance.Label) is - when Iir_Kind_Entity_Declaration => - if Instance.Parent = null then - Prepend (Rstr, Image (Get_Identifier (Instance.Label))); - exit; - end if; - when Iir_Kind_Architecture_Body => - if Is_Instance then - Prepend (Rstr, ')'); - Prepend (Rstr, Image (Get_Identifier (Instance.Label))); - Prepend (Rstr, '('); - end if; - - if Is_Instance or else Instance.Parent = null then - Prepend - (Rstr, - Image (Get_Identifier (Get_Entity (Instance.Label)))); - end if; - if Instance.Parent = null then - Prepend (Rstr, ':'); - exit; - else - Instance := Instance.Parent; - end if; - when Iir_Kind_Block_Statement => - Prepend (Rstr, Image (Get_Label (Instance.Label))); - Prepend (Rstr, ':'); - Instance := Instance.Parent; - when Iir_Kind_Iterator_Declaration => - declare - Val : Iir_Value_Literal_Acc; - begin - Val := Execute_Name (Instance, Instance.Label); - Prepend (Rstr, ')'); - Prepend (Rstr, Execute_Image_Attribute - (Val, Get_Type (Instance.Label))); - Prepend (Rstr, '('); - end; - Instance := Instance.Parent; - when Iir_Kind_Generate_Statement_Body => - Prepend (Rstr, Image (Get_Label (Get_Parent (Instance.Label)))); - Prepend (Rstr, ':'); - Instance := Instance.Parent; - when Iir_Kind_Component_Instantiation_Statement => - if Is_Instance then - Prepend (Rstr, '@'); - end if; - Prepend (Rstr, Image (Get_Label (Instance.Label))); - Prepend (Rstr, ':'); - Instance := Instance.Parent; - when others => - Error_Kind ("Execute_Path_Instance_Name_Attribute", - Instance.Label); - end case; - end loop; - declare - Str1 : String (1 .. Length (Rstr)); - Len1 : Natural; - begin - Copy (Rstr, Str1, Len1); - Free (Rstr); - return String_To_Iir_Value (Str1 & ':' & Name.Suffix); - end; - end Execute_Path_Instance_Name_Attribute; - - function Execute_Shift_Operator (Left : Iir_Value_Literal_Acc; - Count : Ghdl_I64; - Expr : Iir) - return Iir_Value_Literal_Acc - is - Func : constant Iir_Predefined_Shift_Functions := - Get_Implicit_Definition (Get_Implementation (Expr)); - Cnt : Iir_Index32; - Len : constant Iir_Index32 := Left.Bounds.D (1).Length; - Dir_Left : Boolean; - P : Iir_Index32; - Res : Iir_Value_Literal_Acc; - E : Iir_Value_Literal_Acc; - begin - -- LRM93 7.2.3 - -- That is, if R is 0 or if L is a null array, the return value is L. - if Count = 0 or else Len = 0 then - return Left; - end if; - - case Func is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Rol => - Dir_Left := True; - when Iir_Predefined_Array_Srl - | Iir_Predefined_Array_Sra - | Iir_Predefined_Array_Ror => - Dir_Left := False; - end case; - if Count < 0 then - Cnt := Iir_Index32 (-Count); - Dir_Left := not Dir_Left; - else - Cnt := Iir_Index32 (Count); - end if; - - case Func is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl => - E := Create_Enum_Value - (0, Get_Element_Subtype (Get_Base_Type (Get_Type (Expr)))); - when Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra => - if Dir_Left then - E := Left.Val_Array.V (Len); - else - E := Left.Val_Array.V (1); - end if; - when Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - Cnt := Cnt mod Len; - if not Dir_Left then - Cnt := (Len - Cnt) mod Len; - end if; - end case; - - Res := Create_Array_Value (1); - Res.Bounds.D (1) := Left.Bounds.D (1); - Create_Array_Data (Res, Len); - P := 1; - - case Func is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl - | Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra => - if Dir_Left then - if Cnt < Len then - for I in Cnt .. Len - 1 loop - Res.Val_Array.V (P) := Left.Val_Array.V (I + 1); - P := P + 1; - end loop; - else - Cnt := Len; - end if; - for I in 0 .. Cnt - 1 loop - Res.Val_Array.V (P) := E; - P := P + 1; - end loop; - else - if Cnt > Len then - Cnt := Len; - end if; - for I in 0 .. Cnt - 1 loop - Res.Val_Array.V (P) := E; - P := P + 1; - end loop; - for I in Cnt .. Len - 1 loop - Res.Val_Array.V (P) := Left.Val_Array.V (I - Cnt + 1); - P := P + 1; - end loop; - end if; - when Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - for I in 1 .. Len loop - Res.Val_Array.V (P) := Left.Val_Array.V (Cnt + 1); - P := P + 1; - Cnt := Cnt + 1; - if Cnt = Len then - Cnt := 0; - end if; - end loop; - end case; - return Res; - end Execute_Shift_Operator; - - Hex_Chars : constant array (Natural range 0 .. 15) of Character := - "0123456789ABCDEF"; - - function Execute_Bit_Vector_To_String (Val : Iir_Value_Literal_Acc; - Log_Base : Natural) - return Iir_Value_Literal_Acc - is - Base : constant Natural := 2 ** Log_Base; - Blen : constant Natural := Natural (Val.Bounds.D (1).Length); - Str : String (1 .. (Blen + Log_Base - 1) / Log_Base); - Pos : Natural; - V : Natural; - N : Natural; - begin - V := 0; - N := 1; - Pos := Str'Last; - for I in reverse Val.Val_Array.V'Range loop - V := V + Ghdl_B1'Pos (Val.Val_Array.V (I).B1) * N; - N := N * 2; - if N = Base or else I = Val.Val_Array.V'First then - Str (Pos) := Hex_Chars (V); - Pos := Pos - 1; - N := 1; - V := 0; - end if; - end loop; - return String_To_Iir_Value (Str); - end Execute_Bit_Vector_To_String; - - procedure Assert_Std_Ulogic_Dc (Loc : Iir) - is - use Grt.Std_Logic_1164; - begin - Execute_Failed_Assertion - ("assertion", - "STD_LOGIC_1164: '-' operand for matching ordering operator", - 1, Loc); - end Assert_Std_Ulogic_Dc; - - procedure Check_Std_Ulogic_Dc (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic) - is - use Grt.Std_Logic_1164; - begin - if V = '-' then - Assert_Std_Ulogic_Dc (Loc); - end if; - end Check_Std_Ulogic_Dc; - - -- EXPR is the expression whose implementation is an implicit function. - function Execute_Implicit_Function (Block : Block_Instance_Acc; - Expr: Iir; - Left_Param : Iir; - Right_Param : Iir; - Res_Type : Iir) - return Iir_Value_Literal_Acc - is - pragma Unsuppress (Overflow_Check); - - Imp : constant Iir := Strip_Denoting_Name (Get_Implementation (Expr)); - Func : constant Iir_Predefined_Functions := - Get_Implicit_Definition (Imp); - - -- Rename definition for monadic operations. - Left, Right: Iir_Value_Literal_Acc; - Operand : Iir_Value_Literal_Acc renames Left; - Result: Iir_Value_Literal_Acc; - - procedure Eval_Right is - begin - Right := Execute_Expression (Block, Right_Param); - end Eval_Right; - - -- Eval right argument, check left and right have same length, - -- Create RESULT from left. - procedure Eval_Array is - begin - Eval_Right; - if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then - Error_Msg_Constraint (Expr); - end if; - -- Need to copy as the result is modified. - Result := Unshare (Left, Expr_Pool'Access); - end Eval_Array; - begin - -- Eval left operand. - case Func is - when Iir_Predefined_Now_Function => - Left := null; - when Iir_Predefined_Bit_Rising_Edge - | Iir_Predefined_Boolean_Rising_Edge - | Iir_Predefined_Bit_Falling_Edge - | Iir_Predefined_Boolean_Falling_Edge=> - Operand := Execute_Name (Block, Left_Param, True); - when others => - Left := Execute_Expression (Block, Left_Param); - end case; - Right := null; - - case Func is - when Iir_Predefined_Error => - raise Internal_Error; - - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Eval_Right; - - declare - -- Array length of the result. - Len: Iir_Index32; - - -- Index into the result. - Pos: Iir_Index32; - begin - -- Compute the length of the result. - case Func is - when Iir_Predefined_Array_Array_Concat => - Len := Left.Val_Array.Len + Right.Val_Array.Len; - when Iir_Predefined_Element_Array_Concat => - Len := 1 + Right.Val_Array.Len; - when Iir_Predefined_Array_Element_Concat => - Len := Left.Val_Array.Len + 1; - when Iir_Predefined_Element_Element_Concat => - Len := 1 + 1; - when others => - raise Program_Error; - end case; - - if Func = Iir_Predefined_Array_Array_Concat - and then Left.Val_Array.Len = 0 - then - if Flags.Vhdl_Std = Vhdl_87 then - -- LRM87 7.2.3 - -- [...], unless the left operand is a null array, in - -- which case the result of the concatenation is the - -- right operand. - return Right; - else - -- LRM93 7.2.4 - -- If both operands are null arrays, then the result of - -- the concatenation is the right operand. - if Right.Val_Array.Len = 0 then - return Right; - end if; - end if; - end if; - - if Flags.Vhdl_Std = Vhdl_87 - and then (Func = Iir_Predefined_Array_Array_Concat - or Func = Iir_Predefined_Array_Element_Concat) - then - -- LRM87 7.2.3 Adding Operators - -- The left bound if this result is the left bound of the - -- left operand, [...]. The direction of the result is the - -- direction of the left operand, unless the left operand - -- is a null array, in which case the direction of the - -- result is that of the right operand. - Result := Create_Array_Value (Len, 1); - Result.Bounds.D (1) := Create_Range_Value - (Left.Bounds.D (1).Left, null, Left.Bounds.D (1).Dir, Len); - Create_Right_Bound_From_Length (Result.Bounds.D (1), Len); - else - -- Create the array result. - Result := Create_Array_Value (Len, 1); - Result.Bounds.D (1) := Create_Bounds_From_Length - (Block, - Get_Nth_Element (Get_Index_Subtype_List (Res_Type), 0), - Len); - end if; - - -- Fill the result: left. - case Func is - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Array_Element_Concat => - for I in Left.Val_Array.V'Range loop - Result.Val_Array.V (I) := Left.Val_Array.V (I); - end loop; - Pos := Left.Val_Array.Len; - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Element_Element_Concat => - Result.Val_Array.V (1) := Left; - Pos := 1; - when others => - raise Program_Error; - end case; - - -- Note: here POS is equal to the position of the last element - -- filled, or 0 if no elements were filled. - - -- Fill the result: right. - case Func is - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Element_Array_Concat => - for I in Right.Val_Array.V'Range loop - Result.Val_Array.V (Pos + I) := Right.Val_Array.V (I); - end loop; - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Result.Val_Array.V (Pos + 1) := Right; - when others => - raise Program_Error; - end case; - end; - - when Iir_Predefined_Bit_And - | Iir_Predefined_Boolean_And => - if Left.B1 = Lit_Enum_0.B1 then - -- Short circuit operator. - Result := Lit_Enum_0; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); - end if; - when Iir_Predefined_Bit_Nand - | Iir_Predefined_Boolean_Nand => - if Left.B1 = Lit_Enum_0.B1 then - -- Short circuit operator. - Result := Lit_Enum_1; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); - end if; - when Iir_Predefined_Bit_Or - | Iir_Predefined_Boolean_Or => - if Left.B1 = Lit_Enum_1.B1 then - -- Short circuit operator. - Result := Lit_Enum_1; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); - end if; - when Iir_Predefined_Bit_Nor - | Iir_Predefined_Boolean_Nor => - if Left.B1 = Lit_Enum_1.B1 then - -- Short circuit operator. - Result := Lit_Enum_0; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); - end if; - when Iir_Predefined_Bit_Xor - | Iir_Predefined_Boolean_Xor => - Eval_Right; - Result := Boolean_To_Lit (Left.B1 /= Right.B1); - when Iir_Predefined_Bit_Xnor - | Iir_Predefined_Boolean_Xnor => - Eval_Right; - Result := Boolean_To_Lit (Left.B1 = Right.B1); - when Iir_Predefined_Bit_Not - | Iir_Predefined_Boolean_Not => - Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_0.B1); - - when Iir_Predefined_Bit_Condition => - Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_1.B1); - - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl - | Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra - | Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - Eval_Right; - Result := Execute_Shift_Operator (Left, Right.I64, Expr); - - when Iir_Predefined_Enum_Equality - | Iir_Predefined_Integer_Equality - | Iir_Predefined_Array_Equality - | Iir_Predefined_Access_Equality - | Iir_Predefined_Physical_Equality - | Iir_Predefined_Floating_Equality - | Iir_Predefined_Record_Equality - | Iir_Predefined_Bit_Match_Equality - | Iir_Predefined_Bit_Array_Match_Equality => - Eval_Right; - Result := Boolean_To_Lit (Is_Equal (Left, Right)); - when Iir_Predefined_Enum_Inequality - | Iir_Predefined_Integer_Inequality - | Iir_Predefined_Array_Inequality - | Iir_Predefined_Access_Inequality - | Iir_Predefined_Physical_Inequality - | Iir_Predefined_Floating_Inequality - | Iir_Predefined_Record_Inequality - | Iir_Predefined_Bit_Match_Inequality - | Iir_Predefined_Bit_Array_Match_Inequality => - Eval_Right; - Result := Boolean_To_Lit (not Is_Equal (Left, Right)); - when Iir_Predefined_Integer_Less - | Iir_Predefined_Physical_Less - | Iir_Predefined_Enum_Less => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) < Equal); - when Iir_Predefined_Integer_Greater - | Iir_Predefined_Physical_Greater - | Iir_Predefined_Enum_Greater => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) > Equal); - when Iir_Predefined_Integer_Less_Equal - | Iir_Predefined_Physical_Less_Equal - | Iir_Predefined_Enum_Less_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); - when Iir_Predefined_Integer_Greater_Equal - | Iir_Predefined_Physical_Greater_Equal - | Iir_Predefined_Enum_Greater_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); - - when Iir_Predefined_Enum_Minimum - | Iir_Predefined_Physical_Minimum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Left; - else - Result := Right; - end if; - when Iir_Predefined_Enum_Maximum - | Iir_Predefined_Physical_Maximum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Right; - else - Result := Left; - end if; - - when Iir_Predefined_Integer_Plus - | Iir_Predefined_Physical_Plus => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Left.I64 + Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Minus - | Iir_Predefined_Physical_Minus => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Left.I64 - Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Mul => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Left.I64 * Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Mod => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 = 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 mod Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Rem => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 = 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 rem Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Div => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 = 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 / Right.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Absolute - | Iir_Predefined_Physical_Absolute => - case Operand.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (abs Operand.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Negation - | Iir_Predefined_Physical_Negation => - case Operand.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (-Operand.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Identity - | Iir_Predefined_Physical_Identity => - case Operand.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Operand.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Exp => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 < 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 ** Natural (Right.I64)); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Minimum => - Eval_Right; - Result := Create_I64_Value (Ghdl_I64'Min (Left.I64, Right.I64)); - when Iir_Predefined_Integer_Maximum => - Eval_Right; - Result := Create_I64_Value (Ghdl_I64'Max (Left.I64, Right.I64)); - - when Iir_Predefined_Floating_Mul => - Eval_Right; - Result := Create_F64_Value (Left.F64 * Right.F64); - when Iir_Predefined_Floating_Div => - Eval_Right; - Result := Create_F64_Value (Left.F64 / Right.F64); - when Iir_Predefined_Floating_Minus => - Eval_Right; - Result := Create_F64_Value (Left.F64 - Right.F64); - when Iir_Predefined_Floating_Plus => - Eval_Right; - Result := Create_F64_Value (Left.F64 + Right.F64); - when Iir_Predefined_Floating_Exp => - Eval_Right; - Result := Create_F64_Value (Left.F64 ** Integer (Right.I64)); - when Iir_Predefined_Floating_Identity => - Result := Create_F64_Value (Operand.F64); - when Iir_Predefined_Floating_Negation => - Result := Create_F64_Value (-Operand.F64); - when Iir_Predefined_Floating_Absolute => - Result := Create_F64_Value (abs (Operand.F64)); - when Iir_Predefined_Floating_Less => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 < Right.F64); - when Iir_Predefined_Floating_Less_Equal => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 <= Right.F64); - when Iir_Predefined_Floating_Greater => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 > Right.F64); - when Iir_Predefined_Floating_Greater_Equal => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 >= Right.F64); - - when Iir_Predefined_Floating_Minimum => - Eval_Right; - Result := Create_F64_Value (Ghdl_F64'Min (Left.F64, Right.F64)); - when Iir_Predefined_Floating_Maximum => - Eval_Right; - Result := Create_F64_Value (Ghdl_F64'Max (Left.F64, Right.F64)); - - when Iir_Predefined_Integer_Physical_Mul => - Eval_Right; - Result := Create_I64_Value (Left.I64 * Right.I64); - when Iir_Predefined_Physical_Integer_Mul => - Eval_Right; - Result := Create_I64_Value (Left.I64 * Right.I64); - when Iir_Predefined_Physical_Physical_Div => - Eval_Right; - Result := Create_I64_Value (Left.I64 / Right.I64); - when Iir_Predefined_Physical_Integer_Div => - Eval_Right; - Result := Create_I64_Value (Left.I64 / Right.I64); - when Iir_Predefined_Real_Physical_Mul => - Eval_Right; - Result := Create_I64_Value - (Ghdl_I64 (Left.F64 * Ghdl_F64 (Right.I64))); - when Iir_Predefined_Physical_Real_Mul => - Eval_Right; - Result := Create_I64_Value - (Ghdl_I64 (Ghdl_F64 (Left.I64) * Right.F64)); - when Iir_Predefined_Physical_Real_Div => - Eval_Right; - Result := Create_I64_Value - (Ghdl_I64 (Ghdl_F64 (Left.I64) / Right.F64)); - - when Iir_Predefined_Universal_I_R_Mul => - Eval_Right; - Result := Create_F64_Value (Ghdl_F64 (Left.I64) * Right.F64); - when Iir_Predefined_Universal_R_I_Mul => - Eval_Right; - Result := Create_F64_Value (Left.F64 * Ghdl_F64 (Right.I64)); - - when Iir_Predefined_TF_Array_And => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Array_Nand => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1); - end loop; - when Iir_Predefined_TF_Array_Or => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Array_Nor => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1); - end loop; - when Iir_Predefined_TF_Array_Xor => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Array_Xnor => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1); - end loop; - - when Iir_Predefined_TF_Array_Element_And => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 and Right.B1; - end loop; - when Iir_Predefined_TF_Element_Array_And => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 and Left.B1; - end loop; - - when Iir_Predefined_TF_Array_Element_Or => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 or Right.B1; - end loop; - when Iir_Predefined_TF_Element_Array_Or => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 or Left.B1; - end loop; - - when Iir_Predefined_TF_Array_Element_Xor => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 xor Right.B1; - end loop; - when Iir_Predefined_TF_Element_Array_Xor => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 xor Left.B1; - end loop; - - when Iir_Predefined_TF_Array_Element_Nand => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 and Right.B1); - end loop; - when Iir_Predefined_TF_Element_Array_Nand => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 and Left.B1); - end loop; - - when Iir_Predefined_TF_Array_Element_Nor => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 or Right.B1); - end loop; - when Iir_Predefined_TF_Element_Array_Nor => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 or Left.B1); - end loop; - - when Iir_Predefined_TF_Array_Element_Xnor => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 xor Right.B1); - end loop; - when Iir_Predefined_TF_Element_Array_Xnor => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 xor Left.B1); - end loop; - - when Iir_Predefined_TF_Array_Not => - -- Need to copy as the result is modified. - Result := Unshare (Operand, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := not Result.Val_Array.V (I).B1; - end loop; - - when Iir_Predefined_TF_Reduction_And => - Result := Create_B1_Value (True); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Reduction_Nand => - Result := Create_B1_Value (True); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; - end loop; - Result.B1 := not Result.B1; - when Iir_Predefined_TF_Reduction_Or => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Reduction_Nor => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; - end loop; - Result.B1 := not Result.B1; - when Iir_Predefined_TF_Reduction_Xor => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Reduction_Xnor => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; - end loop; - Result.B1 := not Result.B1; - - when Iir_Predefined_Bit_Rising_Edge - | Iir_Predefined_Boolean_Rising_Edge => - return Boolean_To_Lit - (Execute_Event_Attribute (Operand) - and then Execute_Signal_Value (Operand).B1 = True); - when Iir_Predefined_Bit_Falling_Edge - | Iir_Predefined_Boolean_Falling_Edge => - return Boolean_To_Lit - (Execute_Event_Attribute (Operand) - and then Execute_Signal_Value (Operand).B1 = False); - - when Iir_Predefined_Array_Greater => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) = Greater); - - when Iir_Predefined_Array_Greater_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); - - when Iir_Predefined_Array_Less => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) = Less); - - when Iir_Predefined_Array_Less_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); - - when Iir_Predefined_Array_Minimum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Left; - else - Result := Right; - end if; - when Iir_Predefined_Array_Maximum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Right; - else - Result := Left; - end if; - - when Iir_Predefined_Vector_Maximum => - declare - El_St : constant Iir := - Get_Return_Type (Get_Implementation (Expr)); - V : Iir_Value_Literal_Acc; - begin - Result := Execute_Low_Limit (Execute_Bounds (Block, El_St)); - for I in Left.Val_Array.V'Range loop - V := Left.Val_Array.V (I); - if Compare_Value (V, Result) = Greater then - Result := V; - end if; - end loop; - end; - when Iir_Predefined_Vector_Minimum => - declare - El_St : constant Iir := - Get_Return_Type (Get_Implementation (Expr)); - V : Iir_Value_Literal_Acc; - begin - Result := Execute_High_Limit (Execute_Bounds (Block, El_St)); - for I in Left.Val_Array.V'Range loop - V := Left.Val_Array.V (I); - if Compare_Value (V, Result) = Less then - Result := V; - end if; - end loop; - end; - - when Iir_Predefined_Endfile => - Result := Boolean_To_Lit (File_Operation.Endfile (Left, Null_Iir)); - - when Iir_Predefined_Now_Function => - Result := Create_I64_Value (Ghdl_I64 (Grt.Types.Current_Time)); - - when Iir_Predefined_Integer_To_String - | Iir_Predefined_Floating_To_String - | Iir_Predefined_Physical_To_String => - Result := String_To_Iir_Value - (Execute_Image_Attribute (Left, Get_Type (Left_Param))); - - when Iir_Predefined_Enum_To_String => - declare - use Name_Table; - Base_Type : constant Iir := - Get_Base_Type (Get_Type (Left_Param)); - Lits : constant Iir_Flist := - Get_Enumeration_Literal_List (Base_Type); - Pos : constant Natural := Get_Enum_Pos (Left); - Id : Name_Id; - begin - if Base_Type = Std_Package.Character_Type_Definition then - Result := String_To_Iir_Value ((1 => Character'Val (Pos))); - else - Id := Get_Identifier (Get_Nth_Element (Lits, Pos)); - if Is_Character (Id) then - Result := String_To_Iir_Value ((1 => Get_Character (Id))); - else - Image (Id); - if Nam_Buffer (1) = '\' then - -- Reformat extended identifiers for to_image. - pragma Assert (Nam_Buffer (Nam_Length) = '\'); - declare - Npos : Natural; - K : Natural; - C : Character; - begin - Npos := 1; - K := 2; - while K < Nam_Length loop - C := Nam_Buffer (K); - Nam_Buffer (Npos) := C; - Npos := Npos + 1; - if C = '\' then - K := K + 2; - else - K := K + 1; - end if; - end loop; - Nam_Length := Npos - 1; - end; - end if; - Result := - String_To_Iir_Value (Nam_Buffer (1 .. Nam_Length)); - end if; - end if; - end; - - when Iir_Predefined_Array_Char_To_String => - declare - Lits : constant Iir_Flist := - Get_Enumeration_Literal_List - (Get_Base_Type - (Get_Element_Subtype (Get_Type (Left_Param)))); - Str : String (1 .. Natural (Left.Bounds.D (1).Length)); - Pos : Natural; - begin - for I in Left.Val_Array.V'Range loop - Pos := Get_Enum_Pos (Left.Val_Array.V (I)); - Str (Positive (I)) := Name_Table.Get_Character - (Get_Identifier (Get_Nth_Element (Lits, Pos))); - end loop; - Result := String_To_Iir_Value (Str); - end; - - when Iir_Predefined_Bit_Vector_To_Hstring => - return Execute_Bit_Vector_To_String (Left, 4); - - when Iir_Predefined_Bit_Vector_To_Ostring => - return Execute_Bit_Vector_To_String (Left, 3); - - when Iir_Predefined_Real_To_String_Digits => - Eval_Right; - declare - Str : Grt.Vstrings.String_Real_Format; - Last : Natural; - begin - Grt.Vstrings.To_String - (Str, Last, Left.F64, Ghdl_I32 (Right.I64)); - Result := String_To_Iir_Value (Str (1 .. Last)); - end; - when Iir_Predefined_Real_To_String_Format => - Eval_Right; - declare - Format : String (1 .. Natural (Right.Val_Array.Len) + 1); - Str : Grt.Vstrings.String_Real_Format; - Last : Natural; - begin - for I in Right.Val_Array.V'Range loop - Format (Positive (I)) := - Character'Val (Right.Val_Array.V (I).E8); - end loop; - Format (Format'Last) := ASCII.NUL; - Grt.Vstrings.To_String - (Str, Last, Left.F64, To_Ghdl_C_String (Format'Address)); - Result := String_To_Iir_Value (Str (1 .. Last)); - end; - when Iir_Predefined_Time_To_String_Unit => - Eval_Right; - declare - Str : Grt.Vstrings.String_Time_Unit; - First : Natural; - Unit : Iir; - begin - Unit := Get_Unit_Chain (Std_Package.Time_Type_Definition); - while Unit /= Null_Iir loop - exit when Evaluation.Get_Physical_Value (Unit) - = Iir_Int64 (Right.I64); - Unit := Get_Chain (Unit); - end loop; - if Unit = Null_Iir then - Error_Msg_Exec - ("to_string for time called with wrong unit", Expr); - end if; - Grt.Vstrings.To_String (Str, First, Left.I64, Right.I64); - Result := String_To_Iir_Value - (Str (First .. Str'Last) & ' ' - & Name_Table.Image (Get_Identifier (Unit))); - end; - - when Iir_Predefined_Std_Ulogic_Match_Equality => - Eval_Right; - declare - use Grt.Std_Logic_1164; - begin - Result := Create_E8_Value - (Std_Ulogic'Pos - (Match_Eq_Table (Std_Ulogic'Val (Left.E8), - Std_Ulogic'Val (Right.E8)))); - end; - when Iir_Predefined_Std_Ulogic_Match_Inequality => - Eval_Right; - declare - use Grt.Std_Logic_1164; - begin - Result := Create_E8_Value - (Std_Ulogic'Pos - (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E8), - Std_Ulogic'Val (Right.E8))))); - end; - when Iir_Predefined_Std_Ulogic_Match_Ordering_Functions => - Eval_Right; - declare - use Grt.Std_Logic_1164; - L : constant Std_Ulogic := Std_Ulogic'Val (Left.E8); - R : constant Std_Ulogic := Std_Ulogic'Val (Right.E8); - Res : Std_Ulogic; - begin - Check_Std_Ulogic_Dc (Expr, L); - Check_Std_Ulogic_Dc (Expr, R); - case Iir_Predefined_Std_Ulogic_Match_Ordering_Functions (Func) - is - when Iir_Predefined_Std_Ulogic_Match_Less => - Res := Match_Lt_Table (L, R); - when Iir_Predefined_Std_Ulogic_Match_Less_Equal => - Res := Or_Table (Match_Lt_Table (L, R), - Match_Eq_Table (L, R)); - when Iir_Predefined_Std_Ulogic_Match_Greater => - Res := Not_Table (Or_Table (Match_Lt_Table (L, R), - Match_Eq_Table (L, R))); - when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => - Res := Not_Table (Match_Lt_Table (L, R)); - end case; - Result := Create_E8_Value (Std_Ulogic'Pos (Res)); - end; - - when Iir_Predefined_Std_Ulogic_Array_Match_Equality - | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => - Eval_Right; - if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then - Error_Msg_Constraint (Expr); - end if; - declare - use Grt.Std_Logic_1164; - Res : Std_Ulogic := '1'; - Le, Re : Std_Ulogic; - Has_Match_Err : Boolean; - begin - Has_Match_Err := False; - for I in Left.Val_Array.V'Range loop - Le := Std_Ulogic'Val (Left.Val_Array.V (I).E8); - Re := Std_Ulogic'Val (Right.Val_Array.V (I).E8); - if (Le = '-' or Re = '-') and then not Has_Match_Err then - Assert_Std_Ulogic_Dc (Expr); - Has_Match_Err := True; - end if; - Res := And_Table (Res, Match_Eq_Table (Le, Re)); - end loop; - if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then - Res := Not_Table (Res); - end if; - Result := Create_E8_Value (Std_Ulogic'Pos (Res)); - end; - - when others => - Error_Msg_Elab (Expr, "execute_implicit_function: unimplemented " & - Iir_Predefined_Functions'Image (Func)); - raise Internal_Error; - end case; - return Result; - exception - when Constraint_Error => - Error_Msg_Constraint (Expr); - end Execute_Implicit_Function; - - procedure Execute_Implicit_Procedure - (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) - is - Imp : constant Iir := Get_Implementation (Stmt); - Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); - Assoc: Iir; - Args: Iir_Value_Literal_Array (0 .. 3); - Inter_Chain : Iir; - Expr_Mark : Mark_Type; - begin - Mark (Expr_Mark, Expr_Pool); - Assoc := Assoc_Chain; - for I in Iir_Index32 loop - exit when Assoc = Null_Iir; - Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); - Assoc := Get_Chain (Assoc); - end loop; - Inter_Chain := Get_Interface_Declaration_Chain (Imp); - case Get_Implicit_Definition (Imp) is - when Iir_Predefined_Deallocate => - if Args (0).Val_Access /= null then - Free_Heap_Value (Args (0)); - Args (0).Val_Access := null; - end if; - when Iir_Predefined_File_Open => - File_Operation.File_Open - (Args (0), Args (1), Args (2), Inter_Chain, Stmt); - when Iir_Predefined_File_Open_Status => - File_Operation.File_Open_Status - (Args (0), Args (1), Args (2), Args (3), - Get_Chain (Inter_Chain), Stmt); - when Iir_Predefined_Write => - if Get_Text_File_Flag (Get_Type (Inter_Chain)) then - File_Operation.Write_Text (Args (0), Args (1)); - else - File_Operation.Write_Binary (Args (0), Args (1)); - end if; - when Iir_Predefined_Read_Length => - if Get_Text_File_Flag (Get_Type (Inter_Chain)) then - File_Operation.Read_Length_Text - (Args (0), Args (1), Args (2)); - else - File_Operation.Read_Length_Binary - (Args (0), Args (1), Args (2)); - end if; - when Iir_Predefined_Read => - File_Operation.Read_Binary (Args (0), Args (1)); - when Iir_Predefined_Flush => - File_Operation.Flush (Args (0)); - when Iir_Predefined_File_Close => - if Get_Text_File_Flag (Get_Type (Inter_Chain)) then - File_Operation.File_Close_Text (Args (0), Stmt); - else - File_Operation.File_Close_Binary (Args (0), Stmt); - end if; - when others => - Error_Kind ("execute_implicit_procedure", - Get_Implicit_Definition (Imp)); - end case; - Release (Expr_Mark, Expr_Pool); - end Execute_Implicit_Procedure; - - procedure Execute_Foreign_Procedure - (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) - is - Imp : constant Iir := Get_Implementation (Stmt); - Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); - Assoc: Iir; - Args: Iir_Value_Literal_Array (0 .. 3) := (others => null); - Expr_Mark : Mark_Type; - begin - Mark (Expr_Mark, Expr_Pool); - Assoc := Assoc_Chain; - for I in Args'Range loop - exit when Assoc = Null_Iir; - Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); - Assoc := Get_Chain (Assoc); - end loop; - case Get_Identifier (Imp) is - when Std_Names.Name_Untruncated_Text_Read => - File_Operation.Untruncated_Text_Read - (Args (0), Args (1), Args (2)); - when Std_Names.Name_Control_Simulation => - Grt.Lib.Ghdl_Control_Simulation - (Args (0).B1, Args (1).B1, Std_Integer (Args (2).I64)); - -- Do not return. - when Std_Names.Name_Textio_Write_Real => - File_Operation.Textio_Write_Real - (Args (0), Args (1), Args (2).F64, Std_Integer (Args (3).I64)); - when others => - Error_Msg_Exec ("unsupported foreign procedure call", Stmt); - end case; - Release (Expr_Mark, Expr_Pool); - end Execute_Foreign_Procedure; - - -- Compute the offset for INDEX into a range BOUNDS. - -- EXPR is only used in case of error. - function Get_Index_Offset - (Index: Iir_Value_Literal_Acc; - Bounds: Iir_Value_Literal_Acc; - Expr: Iir) - return Iir_Index32 - is - Left_Pos, Right_Pos: Iir_Value_Literal_Acc; - begin - Left_Pos := Bounds.Left; - Right_Pos := Bounds.Right; - if Index.Kind /= Left_Pos.Kind or else Index.Kind /= Right_Pos.Kind then - raise Internal_Error; - end if; - case Iir_Value_Discrete (Index.Kind) is - when Iir_Value_B1 => - case Bounds.Dir is - when Iir_To => - if Index.B1 >= Left_Pos.B1 and then - Index.B1 <= Right_Pos.B1 - then - -- to - return Ghdl_B1'Pos (Index.B1) - Ghdl_B1'Pos (Left_Pos.B1); - end if; - when Iir_Downto => - if Index.B1 <= Left_Pos.B1 and then - Index.B1 >= Right_Pos.B1 - then - -- downto - return Ghdl_B1'Pos (Left_Pos.B1) - Ghdl_B1'Pos (Index.B1); - end if; - end case; - when Iir_Value_E8 => - case Bounds.Dir is - when Iir_To => - if Index.E8 >= Left_Pos.E8 and then - Index.E8 <= Right_Pos.E8 - then - -- to - return Iir_Index32 (Index.E8 - Left_Pos.E8); - end if; - when Iir_Downto => - if Index.E8 <= Left_Pos.E8 and then - Index.E8 >= Right_Pos.E8 - then - -- downto - return Iir_Index32 (Left_Pos.E8 - Index.E8); - end if; - end case; - when Iir_Value_E32 => - case Bounds.Dir is - when Iir_To => - if Index.E32 >= Left_Pos.E32 and then - Index.E32 <= Right_Pos.E32 - then - -- to - return Iir_Index32 (Index.E32 - Left_Pos.E32); - end if; - when Iir_Downto => - if Index.E32 <= Left_Pos.E32 and then - Index.E32 >= Right_Pos.E32 - then - -- downto - return Iir_Index32 (Left_Pos.E32 - Index.E32); - end if; - end case; - when Iir_Value_I64 => - case Bounds.Dir is - when Iir_To => - if Index.I64 >= Left_Pos.I64 and then - Index.I64 <= Right_Pos.I64 - then - -- to - return Iir_Index32 (Index.I64 - Left_Pos.I64); - end if; - when Iir_Downto => - if Index.I64 <= Left_Pos.I64 and then - Index.I64 >= Right_Pos.I64 - then - -- downto - return Iir_Index32 (Left_Pos.I64 - Index.I64); - end if; - end case; - end case; - Error_Msg_Constraint (Expr); - return 0; - end Get_Index_Offset; - - -- Create an iir_value_literal of kind iir_value_array and of life LIFE. - -- Allocate the array of bounds, and fill it from A_TYPE. - -- Allocate the array of values. - function Create_Array_Bounds_From_Type - (Block : Block_Instance_Acc; - A_Type : Iir; - Create_Val_Array : Boolean) - return Iir_Value_Literal_Acc - is - -- Only for constrained subtypes. - pragma Assert (Get_Kind (A_Type) /= Iir_Kind_Array_Type_Definition); - - Index_List : constant Iir_Flist := Get_Index_Subtype_List (A_Type); - Res : Iir_Value_Literal_Acc; - Len : Iir_Index32; - Bound : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value - (Iir_Index32 (Get_Nbr_Elements (Index_List))); - Len := 1; - for I in 1 .. Res.Bounds.Nbr_Dims loop - Bound := Execute_Bounds - (Block, Get_Nth_Element (Index_List, Natural (I - 1))); - Len := Len * Bound.Length; - Res.Bounds.D (I) := Bound; - end loop; - if Create_Val_Array then - Create_Array_Data (Res, Len); - end if; - return Res; - end Create_Array_Bounds_From_Type; - - -- Return the steps (ie, offset in the array when index DIM is increased - -- by one) for array ARR and dimension DIM. - function Get_Step_For_Dim (Arr: Iir_Value_Literal_Acc; Dim : Natural) - return Iir_Index32 - is - Bounds : Value_Bounds_Array_Acc renames Arr.Bounds; - Res : Iir_Index32; - begin - Res := 1; - for I in Iir_Index32 (Dim + 1) .. Bounds.Nbr_Dims loop - Res := Res * Bounds.D (I).Length; - end loop; - return Res; - end Get_Step_For_Dim; - - -- Create a literal for a string or a bit_string - function String_To_Enumeration_Array_1 (Str: Iir; El_Type : Iir) - return Iir_Value_Literal_Acc - is - pragma Assert (Get_Kind (Str) = Iir_Kind_String_Literal8); - Id : constant String8_Id := Get_String8_Id (Str); - Len : constant Iir_Index32 := Iir_Index32 (Get_String_Length (Str)); - - El_Btype : constant Iir := Get_Base_Type (El_Type); - - Lit: Iir_Value_Literal_Acc; - El : Iir_Value_Literal_Acc; - Element_Mode : Iir_Value_Scalars; - - Pos : Nat8; - begin - Element_Mode := Get_Info (El_Btype).Scalar_Mode; - - Lit := Create_Array_Value (Len, 1); - - for I in Lit.Val_Array.V'Range loop - -- FIXME: use literal from type ?? - Pos := Str_Table.Element_String8 (Id, Pos32 (I)); - case Element_Mode is - when Iir_Value_B1 => - El := Create_B1_Value (Ghdl_B1'Val (Pos)); - when Iir_Value_E8 => - El := Create_E8_Value (Ghdl_E8'Val (Pos)); - when Iir_Value_E32 => - El := Create_E32_Value (Ghdl_E32'Val (Pos)); - when others => - raise Internal_Error; - end case; - Lit.Val_Array.V (I) := El; - end loop; - - return Lit; - end String_To_Enumeration_Array_1; - - -- Create a literal for a string or a bit_string - function String_To_Enumeration_Array (Block: Block_Instance_Acc; Str: Iir) - return Iir_Value_Literal_Acc - is - Array_Type: constant Iir := Get_Type (Str); - Index_Types : constant Iir_Flist := Get_Index_Subtype_List (Array_Type); - Res : Iir_Value_Literal_Acc; - begin - -- Array must be unidimensional. - pragma Assert (Get_Nbr_Elements (Index_Types) = 1); - - Res := String_To_Enumeration_Array_1 - (Str, Get_Element_Subtype (Array_Type)); - - -- When created from static evaluation, a string may still have an - -- unconstrained type. - if Get_Constraint_State (Array_Type) /= Fully_Constrained then - Res.Bounds.D (1) := - Create_Range_Value (Create_I64_Value (1), - Create_I64_Value (Ghdl_I64 (Res.Val_Array.Len)), - Iir_To, - Res.Val_Array.Len); - else - Res.Bounds.D (1) := - Execute_Bounds (Block, Get_Nth_Element (Index_Types, 0)); - end if; - - -- The range may not be statically constant. - if Res.Bounds.D (1).Length /= Res.Val_Array.Len then - Error_Msg_Constraint (Str); - end if; - - return Res; - end String_To_Enumeration_Array; - - -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. - -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. - -- EL_TYPE is the type of the array element. - procedure Fill_Array_Aggregate_1 - (Block : Block_Instance_Acc; - Aggregate : Iir; - Res : Iir_Value_Literal_Acc; - Orig : Iir_Index32; - Step : Iir_Index32; - Dim : Iir_Index32; - Nbr_Dim : Iir_Index32; - El_Type : Iir) - is - Value : Iir; - Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim); - - procedure Set_Elem (Pos : Iir_Index32) - is - Val : Iir_Value_Literal_Acc; - begin - if Dim = Nbr_Dim then - -- VALUE is an expression (which may be an aggregate, but not - -- a sub-aggregate. - Val := Execute_Expression_With_Type (Block, Value, El_Type); - -- LRM93 7.3.2.2 - -- For a multi-dimensional aggregate of dimension n, a check - -- is made that all (n-1)-dimensional subaggregates have the - -- same bounds. - -- GHDL: I have added an implicit array conversion, however - -- it may be useful to allow cases like this: - -- type str_array is array (natural range <>) - -- of string (10 downto 1); - -- constant floats : str_array := - -- ( "00000000.0", HT & "+1.5ABCDE"); - -- The subtype of the first sub-aggregate (0.0) is - -- determinated by the context, according to rule 9 and 4 - -- of LRM93 7.3.2.2 and therefore is string (10 downto 1), - -- while the subtype of the second sub-aggregate (HT & ...) - -- is determinated by rules 1 and 2 of LRM 7.2.4, and is - -- string (1 to 10). - -- Unless an implicit conversion is used, according to the - -- LRM, this should fail, but it makes no sens. - -- - -- FIXME: Add a warning, a flag ? - --Implicit_Array_Conversion (Block, Val, El_Type, Value); - --Check_Constraints (Block, Val, El_Type, Value); - Res.Val_Array.V (1 + Orig + Pos * Step) := Val; - else - case Get_Kind (Value) is - when Iir_Kind_Aggregate => - -- VALUE is a sub-aggregate. - Fill_Array_Aggregate_1 (Block, Value, Res, - Orig + Pos * Step, - Step / Res.Bounds.D (Dim + 1).Length, - Dim + 1, Nbr_Dim, El_Type); - when Iir_Kind_String_Literal8 => - pragma Assert (Dim + 1 = Nbr_Dim); - Val := String_To_Enumeration_Array_1 (Value, El_Type); - if Val.Val_Array.Len /= Res.Bounds.D (Nbr_Dim).Length then - Error_Msg_Constraint (Value); - end if; - for I in Val.Val_Array.V'Range loop - Res.Val_Array.V (Orig + Pos * Step + I) := - Val.Val_Array.V (I); - end loop; - when others => - Error_Kind ("fill_array_aggregate_1", Value); - end case; - end if; - end Set_Elem; - - procedure Set_Elem_By_Expr (Expr : Iir) - is - Expr_Pos: Iir_Value_Literal_Acc; - begin - Expr_Pos := Execute_Expression (Block, Expr); - Set_Elem (Get_Index_Offset (Expr_Pos, Bound, Expr)); - end Set_Elem_By_Expr; - - procedure Set_Elem_By_Range (Expr : Iir) - is - A_Range : Iir_Value_Literal_Acc; - High, Low : Iir_Value_Literal_Acc; - begin - A_Range := Execute_Bounds (Block, Expr); - if Is_Null_Range (A_Range) then - return; - end if; - if A_Range.Dir = Iir_To then - High := A_Range.Right; - Low := A_Range.Left; - else - High := A_Range.Left; - Low := A_Range.Right; - end if; - - -- Locally modified (incremented) - Low := Unshare (Low, Expr_Pool'Access); - - loop - Set_Elem (Get_Index_Offset (Low, Bound, Expr)); - exit when Is_Equal (Low, High); - Increment (Low); - end loop; - end Set_Elem_By_Range; - - Length : constant Iir_Index32 := Bound.Length; - Assoc : Iir; - Pos : Iir_Index32; - begin - Assoc := Get_Association_Choices_Chain (Aggregate); - Pos := 0; - while Assoc /= Null_Iir loop - Value := Get_Associated_Expr (Assoc); - loop - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - if Pos >= Length then - Error_Msg_Constraint (Assoc); - end if; - Set_Elem (Pos); - Pos := Pos + 1; - when Iir_Kind_Choice_By_Expression => - Set_Elem_By_Expr (Get_Choice_Expression (Assoc)); - when Iir_Kind_Choice_By_Range => - Set_Elem_By_Range (Get_Choice_Range (Assoc)); - when Iir_Kind_Choice_By_Others => - for J in 1 .. Length loop - if Res.Val_Array.V (Orig + J * Step) = null then - Set_Elem (J - 1); - end if; - end loop; - return; - when others => - raise Internal_Error; - end case; - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - exit when not Get_Same_Alternative_Flag (Assoc); - end loop; - end loop; - - -- Check each elements have been set. - -- FIXME: check directly with type. - for J in 1 .. Length loop - if Res.Val_Array.V (Orig + J * Step) = null then - Error_Msg_Constraint (Aggregate); - end if; - end loop; - end Fill_Array_Aggregate_1; - - -- Use expressions from (BLOCK, AGGREGATE) to fill RES. - procedure Fill_Array_Aggregate - (Block : Block_Instance_Acc; - Aggregate : Iir; - Res : Iir_Value_Literal_Acc) - is - Aggr_Type : constant Iir := Get_Type (Aggregate); - El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); - Index_List : constant Iir_Flist := Get_Index_Subtype_List (Aggr_Type); - Nbr_Dim : constant Iir_Index32 := - Iir_Index32 (Get_Nbr_Elements (Index_List)); - Step : Iir_Index32; - begin - Step := Get_Step_For_Dim (Res, 1); - Fill_Array_Aggregate_1 - (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); - end Fill_Array_Aggregate; - - function Execute_Record_Aggregate (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc - is - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); - - Res: Iir_Value_Literal_Acc; - Expr : Iir; - - procedure Set_Expr (Pos : Iir_Index32) is - El : constant Iir := Get_Nth_Element (List, Natural (Pos - 1)); - begin - Res.Val_Record.V (Pos) := - Execute_Expression_With_Type (Block, Expr, Get_Type (El)); - end Set_Expr; - - Pos : Iir_Index32; - Assoc: Iir; - N_Expr : Iir; - begin - Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); - - Assoc := Get_Association_Choices_Chain (Aggregate); - Pos := 1; - loop - N_Expr := Get_Associated_Expr (Assoc); - if N_Expr /= Null_Iir then - Expr := N_Expr; - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - Set_Expr (Pos); - Pos := Pos + 1; - when Iir_Kind_Choice_By_Name => - Set_Expr (1 + Get_Element_Position - (Get_Named_Entity (Get_Choice_Name (Assoc)))); - when Iir_Kind_Choice_By_Others => - for I in Res.Val_Record.V'Range loop - if Res.Val_Record.V (I) = null then - Set_Expr (I); - end if; - end loop; - when others => - Error_Kind ("execute_record_aggregate", Assoc); - end case; - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - end loop; - return Res; - end Execute_Record_Aggregate; - - function Execute_Aggregate (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc is - begin - case Get_Kind (Aggregate_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - declare - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Bounds_From_Type - (Block, Aggregate_Type, True); - Fill_Array_Aggregate (Block, Aggregate, Res); - return Res; - end; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - return Execute_Record_Aggregate - (Block, Aggregate, Aggregate_Type); - when others => - Error_Kind ("execute_aggregate", Aggregate_Type); - end case; - end Execute_Aggregate; - - function Execute_Simple_Aggregate (Block: Block_Instance_Acc; Aggr : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - List : constant Iir_Flist := Get_Simple_Aggregate_List (Aggr); - begin - Res := Create_Array_Bounds_From_Type (Block, Get_Type (Aggr), True); - for I in Res.Val_Array.V'Range loop - Res.Val_Array.V (I) := - Execute_Expression (Block, Get_Nth_Element (List, Natural (I - 1))); - end loop; - return Res; - end Execute_Simple_Aggregate; - - -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. - -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. - -- EL_TYPE is the type of the array element. - procedure Execute_Name_Array_Aggregate - (Block : Block_Instance_Acc; - Aggregate : Iir; - Res : Iir_Value_Literal_Acc; - Orig : Iir_Index32; - Step : Iir_Index32; - Dim : Iir_Index32; - Nbr_Dim : Iir_Index32; - El_Type : Iir) - is - Value : Iir; - Bound : Iir_Value_Literal_Acc; - - procedure Set_Elem (Pos : Iir_Index32) - is - Val : Iir_Value_Literal_Acc; - Is_Sig : Boolean; - begin - if Dim = Nbr_Dim then - -- VALUE is an expression (which may be an aggregate, but not - -- a sub-aggregate. - Execute_Name_With_Base (Block, Value, null, Val, Is_Sig); - Res.Val_Array.V (1 + Orig + Pos * Step) := Val; - else - -- VALUE is a sub-aggregate. - Execute_Name_Array_Aggregate - (Block, Value, Res, - Orig + Pos * Step, - Step / Res.Bounds.D (Dim + 1).Length, - Dim + 1, Nbr_Dim, El_Type); - end if; - end Set_Elem; - - Assoc : Iir; - Pos : Iir_Index32; - begin - Assoc := Get_Association_Choices_Chain (Aggregate); - Bound := Res.Bounds.D (Dim); - Pos := 0; - while Assoc /= Null_Iir loop - Value := Get_Associated_Expr (Assoc); - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - null; - when Iir_Kind_Choice_By_Expression => - declare - Expr_Pos: Iir_Value_Literal_Acc; - Val : constant Iir := Get_Expression (Assoc); - begin - Expr_Pos := Execute_Expression (Block, Val); - Pos := Get_Index_Offset (Expr_Pos, Bound, Val); - end; - when others => - raise Internal_Error; - end case; - Set_Elem (Pos); - Pos := Pos + 1; - Assoc := Get_Chain (Assoc); - end loop; - end Execute_Name_Array_Aggregate; - - function Execute_Record_Name_Aggregate - (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc - is - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); - Res: Iir_Value_Literal_Acc; - Expr : Iir; - Pos : Iir_Index32; - El_Pos : Iir_Index32; - Is_Sig : Boolean; - Assoc: Iir; - begin - Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); - Assoc := Get_Association_Choices_Chain (Aggregate); - Pos := 0; - loop - Expr := Get_Associated_Expr (Assoc); - if Expr = Null_Iir then - -- List of choices is not allowed. - raise Internal_Error; - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - El_Pos := Pos; - Pos := Pos + 1; - when Iir_Kind_Choice_By_Name => - El_Pos := Get_Element_Position (Get_Name (Assoc)); - when Iir_Kind_Choice_By_Others => - raise Internal_Error; - when others => - Error_Kind ("execute_record_name_aggregate", Assoc); - end case; - Execute_Name_With_Base - (Block, Expr, null, Res.Val_Record.V (1 + El_Pos), Is_Sig); - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - end loop; - return Res; - end Execute_Record_Name_Aggregate; - - function Execute_Name_Aggregate - (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc - is - begin - case Get_Kind (Aggregate_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - declare - El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type); - Index_List : constant Iir_Flist := - Get_Index_Subtype_List (Aggregate_Type); - Nbr_Dim : constant Iir_Index32 := - Iir_Index32 (Get_Nbr_Elements (Index_List)); - Res : Iir_Value_Literal_Acc; - Step : Iir_Index32; - begin - Res := Create_Array_Bounds_From_Type - (Block, Aggregate_Type, True); - Step := Get_Step_For_Dim (Res, 1); - Execute_Name_Array_Aggregate - (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); - return Res; - end; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - return Execute_Record_Name_Aggregate - (Block, Aggregate, Aggregate_Type); - when others => - Error_Kind ("execute_name_aggregate", Aggregate_Type); - end case; - end Execute_Name_Aggregate; - - -- Return the indexes range for prefix of ATTR. - function Execute_Indexes (Block: Block_Instance_Acc; Attr : Iir) - return Iir_Value_Literal_Acc - is - Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Attr)); - Dim : constant Natural := - Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); - begin - case Get_Kind (Prefix) is - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - declare - Index : Iir; - begin - Index := Get_Nth_Element - (Get_Index_Subtype_List (Get_Type (Prefix)), Dim - 1); - return Execute_Bounds (Block, Index); - end; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - Error_Kind ("execute_indexes", Prefix); - when others => - declare - Orig : Iir_Value_Literal_Acc; - begin - Orig := Execute_Name (Block, Prefix, True); - return Orig.Bounds.D (Iir_Index32 (Dim)); - end; - end case; - end Execute_Indexes; - - function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) - return Iir_Value_Literal_Acc - is - Bound : Iir_Value_Literal_Acc; - begin - case Get_Kind (Prefix) is - when Iir_Kind_Range_Expression => - declare - Info : constant Sim_Info_Acc := Get_Info (Prefix); - begin - if Info = null then - Bound := Create_Range_Value - (Execute_Expression (Block, Get_Left_Limit (Prefix)), - Execute_Expression (Block, Get_Right_Limit (Prefix)), - Get_Direction (Prefix)); - elsif Info.Kind = Kind_Object then - Bound := Get_Instance_For_Slot - (Block, Prefix).Objects (Info.Slot); - else - raise Internal_Error; - end if; - end; - - when Iir_Kind_Subtype_Declaration => - return Execute_Bounds (Block, Get_Type (Prefix)); - - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - -- FIXME: move this block before and avoid recursion. - return Execute_Bounds (Block, Get_Range_Constraint (Prefix)); - - when Iir_Kind_Range_Array_Attribute => - Bound := Execute_Indexes (Block, Prefix); - when Iir_Kind_Reverse_Range_Array_Attribute => - Bound := Execute_Indexes (Block, Prefix); - case Bound.Dir is - when Iir_To => - Bound := Create_Range_Value - (Bound.Right, Bound.Left, Iir_Downto, Bound.Length); - when Iir_Downto => - Bound := Create_Range_Value - (Bound.Right, Bound.Left, Iir_To, Bound.Length); - end case; - - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Integer_Type_Definition => - return Execute_Bounds - (Block, - Get_Range_Constraint (Get_Type (Get_Type_Declarator (Prefix)))); - - when Iir_Kinds_Denoting_Name => - return Execute_Bounds (Block, Get_Named_Entity (Prefix)); - - when others => - -- Error_Kind ("execute_bounds", Get_Kind (Prefix)); - declare - Prefix_Val: Iir_Value_Literal_Acc; - begin - Prefix_Val := Execute_Expression (Block, Prefix); - Bound := Prefix_Val.Bounds.D (1); - end; - end case; - if not Bound.Dir'Valid then - raise Internal_Error; - end if; - return Bound; - end Execute_Bounds; - - -- Perform type conversion as desribed in LRM93 7.3.5 - function Execute_Type_Conversion (Block: Block_Instance_Acc; - Val : Iir_Value_Literal_Acc; - Target_Type : Iir; - Loc : Iir) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - Res := Val; - case Get_Kind (Target_Type) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - case Iir_Value_Numerics (Res.Kind) is - when Iir_Value_I64 => - null; - when Iir_Value_F64 => - if Res.F64 > Ghdl_F64 (Iir_Int64'Last) or - Res.F64 < Ghdl_F64 (Iir_Int64'First) - then - Error_Msg_Constraint (Loc); - end if; - Res := Create_I64_Value (Ghdl_I64 (Res.F64)); - end case; - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - case Iir_Value_Numerics (Res.Kind) is - when Iir_Value_F64 => - null; - when Iir_Value_I64 => - Res := Create_F64_Value (Ghdl_F64 (Res.I64)); - end case; - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - -- Must be same type. - null; - when Iir_Kind_Physical_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - -- Same type. - null; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - -- Same type. - null; - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - -- LRM93 7.3.5 - -- if the type mark denotes an unconstrained array type and the - -- operand is not a null array, then for each index position, the - -- bounds of the result are obtained by converting the bounds of - -- the operand to the corresponding index type of the target type. - -- - -- LRM93 7.3.5 - -- If the type mark denotes a constrained array subtype, then the - -- bounds of the result are those imposed by the type mark. - if Get_Constraint_State (Target_Type) = Fully_Constrained then - Implicit_Array_Conversion (Block, Res, Target_Type, Loc); - else - declare - Idx_List : constant Iir_Flist := - Get_Index_Subtype_List (Target_Type); - Idx_Type : Iir; - begin - Res := Create_Array_Value (Val.Bounds.Nbr_Dims); - Res.Val_Array := Val.Val_Array; - for I in Val.Bounds.D'Range loop - Idx_Type := Get_Index_Type (Idx_List, Natural (I - 1)); - Res.Bounds.D (I) := Create_Range_Value - (Left => Execute_Type_Conversion - (Block, Val.Bounds.D (I).Left, Idx_Type, Loc), - Right => Execute_Type_Conversion - (Block, Val.Bounds.D (I).Right, Idx_Type, Loc), - Dir => Val.Bounds.D (I).Dir, - Length => Val.Bounds.D (I).Length); - end loop; - end; - end if; - when others => - Error_Kind ("execute_type_conversion", Target_Type); - end case; - Check_Constraints (Block, Res, Target_Type, Loc); - return Res; - end Execute_Type_Conversion; - - -- Decrement VAL. - -- May raise a constraint error using EXPR. - function Execute_Dec (Val : Iir_Value_Literal_Acc; Expr : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_B1 => - if Val.B1 = False then - Error_Msg_Constraint (Expr); - end if; - Res := Create_B1_Value (False); - when Iir_Value_E8 => - if Val.E8 = 0 then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E8_Value (Val.E8 - 1); - when Iir_Value_E32 => - if Val.E32 = 0 then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E32_Value (Val.E32 - 1); - when Iir_Value_I64 => - if Val.I64 = Ghdl_I64'First then - Error_Msg_Constraint (Expr); - end if; - Res := Create_I64_Value (Val.I64 - 1); - end case; - return Res; - end Execute_Dec; - - -- Increment VAL. - -- May raise a constraint error using EXPR. - function Execute_Inc (Val : Iir_Value_Literal_Acc; Expr : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_B1 => - if Val.B1 = True then - Error_Msg_Constraint (Expr); - end if; - Res := Create_B1_Value (True); - when Iir_Value_E32 => - if Val.E32 = Ghdl_E32'Last then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E32_Value (Val.E32 + 1); - when Iir_Value_E8 => - if Val.E8 = Ghdl_E8'Last then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E8_Value (Val.E8 + 1); - when Iir_Value_I64 => - if Val.I64 = Ghdl_I64'Last then - Error_Msg_Constraint (Expr); - end if; - Res := Create_I64_Value (Val.I64 + 1); - end case; - return Res; - end Execute_Inc; - - function Execute_Expression_With_Type - (Block: Block_Instance_Acc; - Expr: Iir; - Expr_Type : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - if Get_Kind (Expr) = Iir_Kind_Aggregate - and then not Is_Fully_Constrained_Type (Get_Type (Expr)) - then - return Execute_Aggregate (Block, Expr, Expr_Type); - else - Res := Execute_Expression (Block, Expr); - Implicit_Array_Conversion (Block, Res, Expr_Type, Expr); - Check_Constraints (Block, Res, Expr_Type, Expr); - return Res; - end if; - end Execute_Expression_With_Type; - - function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) - return Iir_Value_Literal_Acc - is - Base : constant Iir := Get_Object_Prefix (Expr, False); - Info : constant Sim_Info_Acc := Get_Info (Base); - Bblk : Block_Instance_Acc; - Base_Val : Iir_Value_Literal_Acc; - Res : Iir_Value_Literal_Acc; - Is_Sig : Boolean; - begin - if Get_Kind (Base) = Iir_Kind_Object_Alias_Declaration then - Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); - Base_Val := Execute_Signal_Init_Value (Bblk, Get_Name (Base)); - else - Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); - Base_Val := Bblk.Objects (Info.Slot + 1); - end if; - Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig); - pragma Assert (Is_Sig); - return Res; - end Execute_Signal_Init_Value; - - -- Indexed element will be at Pfx.Val_Array.V (Pos + 1) - procedure Execute_Indexed_Name (Block: Block_Instance_Acc; - Expr: Iir; - Pfx : Iir_Value_Literal_Acc; - Pos : out Iir_Index32) - is - pragma Assert (Get_Kind (Expr) = Iir_Kind_Indexed_Name); - Index_List : constant Iir_Flist := Get_Index_List (Expr); - Nbr_Dimensions : constant Iir_Index32 := - Iir_Index32 (Get_Nbr_Elements (Index_List)); - Index: Iir; - Value: Iir_Value_Literal_Acc; - Off : Iir_Index32; - begin - for I in 1 .. Nbr_Dimensions loop - Index := Get_Nth_Element (Index_List, Natural (I - 1)); - Value := Execute_Expression (Block, Index); - Off := Get_Index_Offset (Value, Pfx.Bounds.D (I), Expr); - if I = 1 then - Pos := Off; - else - Pos := Pos * Pfx.Bounds.D (I).Length + Off; - end if; - end loop; - end Execute_Indexed_Name; - - -- Indexed element will be at Pfx.Val_Array.V (Pos) - procedure Execute_Slice_Name (Prefix_Array: Iir_Value_Literal_Acc; - Srange : Iir_Value_Literal_Acc; - Low : out Iir_Index32; - High : out Iir_Index32; - Loc : Iir) - is - Index_Order : Order; - -- Lower and upper bounds of the slice. - begin - pragma Assert (Prefix_Array /= null); - - -- LRM93 6.5 - -- It is an error if the direction of the discrete range is not - -- the same as that of the index range of the array denoted by - -- the prefix of the slice name. - if Srange.Dir /= Prefix_Array.Bounds.D (1).Dir then - Error_Msg_Exec ("slice direction mismatch", Loc); - end if; - - -- LRM93 6.5 - -- It is an error if either of the bounds of the - -- discrete range does not belong to the index range of the - -- prefixing array, unless the slice is a null slice. - Index_Order := Compare_Value (Srange.Left, Srange.Right); - if (Srange.Dir = Iir_To and Index_Order = Greater) - or (Srange.Dir = Iir_Downto and Index_Order = Less) - then - -- Null slice. - Low := 1; - High := 0; - else - Low := Get_Index_Offset - (Srange.Left, Prefix_Array.Bounds.D (1), Loc); - High := Get_Index_Offset - (Srange.Right, Prefix_Array.Bounds.D (1), Loc); - end if; - end Execute_Slice_Name; - - procedure Execute_Name_With_Base (Block: Block_Instance_Acc; - Expr: Iir; - Base : Iir_Value_Literal_Acc; - Res : out Iir_Value_Literal_Acc; - Is_Sig : out Boolean) - is - Slot_Block: Block_Instance_Acc; - begin - -- Default value - Is_Sig := False; - - case Get_Kind (Expr) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute => - Is_Sig := True; - if Base /= null then - Res := Base; - else - Slot_Block := Get_Instance_For_Slot (Block, Expr); - Res := Slot_Block.Objects (Get_Info (Expr).Slot); - end if; - - when Iir_Kind_Object_Alias_Declaration => - -- FIXME: add a flag ? - Is_Sig := Is_Signal_Object (Expr); - if Base /= null then - Res := Base; - else - Slot_Block := Get_Instance_For_Slot (Block, Expr); - Res := Slot_Block.Objects (Get_Info (Expr).Slot); - end if; - - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Attribute_Value - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Terminal_Declaration - | Iir_Kinds_Quantity_Declaration => - if Base /= null then - Res := Base; - else - declare - Info : constant Sim_Info_Acc := Get_Info (Expr); - begin - Slot_Block := Get_Instance_By_Scope (Block, Info.Obj_Scope); - Res := Slot_Block.Objects (Info.Slot); - end; - end if; - - when Iir_Kind_Indexed_Name => - declare - Pfx : Iir_Value_Literal_Acc; - Pos : Iir_Index32; - begin - Execute_Name_With_Base - (Block, Get_Prefix (Expr), Base, Pfx, Is_Sig); - Execute_Indexed_Name (Block, Expr, Pfx, Pos); - Res := Pfx.Val_Array.V (Pos + 1); - end; - - when Iir_Kind_Slice_Name => - declare - Prefix_Array: Iir_Value_Literal_Acc; - Srange : Iir_Value_Literal_Acc; - Low, High: Iir_Index32; - begin - Execute_Name_With_Base - (Block, Get_Prefix (Expr), Base, Prefix_Array, Is_Sig); - - Srange := Execute_Bounds (Block, Get_Suffix (Expr)); - Execute_Slice_Name (Prefix_Array, Srange, Low, High, Expr); - - Res := Create_Array_Value (High - Low + 1, 1); - Res.Bounds.D (1) := Srange; - for I in Low .. High loop - Res.Val_Array.V (1 + I - Low) := - Prefix_Array.Val_Array.V (1 + I); - end loop; - end; - - when Iir_Kind_Selected_Element => - declare - Prefix: Iir_Value_Literal_Acc; - Pos: Iir_Index32; - begin - Execute_Name_With_Base - (Block, Get_Prefix (Expr), Base, Prefix, Is_Sig); - Pos := Get_Element_Position (Get_Selected_Element (Expr)); - Res := Prefix.Val_Record.V (Pos + 1); - end; - - when Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference => - declare - Prefix: Iir_Value_Literal_Acc; - begin - Prefix := Execute_Name (Block, Get_Prefix (Expr)); - Res := Prefix.Val_Access; - if Res = null then - Error_Msg_Exec ("deferencing null access", Expr); - end if; - end; - - when Iir_Kinds_Denoting_Name - | Iir_Kind_Attribute_Name => - Execute_Name_With_Base - (Block, Get_Named_Entity (Expr), Base, Res, Is_Sig); - - when Iir_Kind_Function_Call => - -- A prefix can be an expression - if Base /= null then - raise Internal_Error; - end if; - Res := Execute_Expression (Block, Expr); - - when Iir_Kind_Aggregate => - Res := Execute_Name_Aggregate (Block, Expr, Get_Type (Expr)); - -- FIXME: is_sig ? - - when Iir_Kind_Image_Attribute => - Res := Execute_Image_Attribute (Block, Expr); - - when Iir_Kind_Path_Name_Attribute - | Iir_Kind_Instance_Name_Attribute => - Res := Execute_Path_Instance_Name_Attribute (Block, Expr); - - when others => - Error_Kind ("execute_name_with_base", Expr); - end case; - end Execute_Name_With_Base; - - function Execute_Name (Block: Block_Instance_Acc; - Expr: Iir; - Ref : Boolean := False) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - Is_Sig : Boolean; - begin - Execute_Name_With_Base (Block, Expr, null, Res, Is_Sig); - if not Is_Sig or else Ref then - return Res; - else - return Execute_Signal_Value (Res); - end if; - end Execute_Name; - - function Execute_Value_Attribute (Block: Block_Instance_Acc; - Str_Val : Iir_Value_Literal_Acc; - Expr: Iir) - return Iir_Value_Literal_Acc - is - use Grt_Interface; - use Name_Table; - pragma Unreferenced (Block); - - Expr_Type : constant Iir := Get_Type (Expr); - Res : Iir_Value_Literal_Acc; - - Str_Bnd : aliased Std_String_Bound := Build_Bound (Str_Val); - Str_Str : aliased Std_String_Uncons (1 .. Str_Bnd.Dim_1.Length); - Str : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), - To_Std_String_Boundp (Str_Bnd'Address)); - begin - Set_Std_String_From_Iir_Value (Str, Str_Val); - case Get_Kind (Expr_Type) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - Res := Create_I64_Value - (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access)); - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - Res := Create_F64_Value - (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access)); - when Iir_Kind_Physical_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - declare - Is_Real : Boolean; - Lit_Pos : Ghdl_Index_Type; - Lit_End : Ghdl_Index_Type; - Unit_Pos : Ghdl_Index_Type; - Unit_Len : Ghdl_Index_Type; - Mult : Ghdl_I64; - Unit : Iir; - Unit_Id : Name_Id; - begin - Grt.Values.Ghdl_Value_Physical_Split - (Str'Unrestricted_Access, - Is_Real, Lit_Pos, Lit_End, Unit_Pos); - - -- Find unit. - Unit_Len := 0; - Unit_Pos := Unit_Pos + 1; -- From 0 based to 1 based - for I in Unit_Pos .. Str_Bnd.Dim_1.Length loop - exit when Grt.Strings.Is_Whitespace (Str_Str (I)); - Unit_Len := Unit_Len + 1; - Str_Str (I) := Grt.Strings.To_Lower (Str_Str (I)); - end loop; - - Unit := Get_Primary_Unit (Expr_Type); - while Unit /= Null_Iir loop - Unit_Id := Get_Identifier (Unit); - exit when Get_Name_Length (Unit_Id) = Natural (Unit_Len) - and then Image (Unit_Id) = - String (Str_Str (Unit_Pos .. Unit_Pos + Unit_Len - 1)); - Unit := Get_Chain (Unit); - end loop; - - if Unit = Null_Iir then - Error_Msg_Exec ("incorrect unit name", Expr); - end if; - Mult := Ghdl_I64 (Get_Value (Get_Physical_Unit (Unit))); - - Str_Bnd.Dim_1.Length := Lit_End; - if Is_Real then - Res := Create_I64_Value - (Ghdl_I64 - (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access) - * Ghdl_F64 (Mult))); - else - Res := Create_I64_Value - (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access) - * Mult); - end if; - end; - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - declare - Enums : constant Iir_Flist := - Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); - Lit_Start : Ghdl_Index_Type; - Lit_End : Ghdl_Index_Type; - Enum : Iir; - Lit_Id : Name_Id; - Enum_Id : Name_Id; - begin - -- Remove leading and trailing blanks - for I in Str_Str'Range loop - if not Grt.Strings.Is_Whitespace (Str_Str (I)) then - Lit_Start := I; - exit; - end if; - end loop; - for I in reverse Lit_Start .. Str_Str'Last loop - if not Grt.Strings.Is_Whitespace (Str_Str (I)) then - Lit_End := I; - exit; - end if; - end loop; - - if Str_Str (Lit_Start) = ''' - and then Str_Str (Lit_End) = ''' - and then Lit_End = Lit_Start + 2 - then - -- Enumeration literal. - Lit_Id := Get_Identifier (Str_Str (Lit_Start + 1)); - - for I in Natural loop - Enum := Get_Nth_Element (Enums, I); - exit when Enum = Null_Iir; - exit when Get_Identifier (Enum) = Lit_Id; - end loop; - else - -- Literal identifier. - -- Convert to lower case. - for I in Lit_Start .. Lit_End loop - Str_Str (I) := Grt.Strings.To_Lower (Str_Str (I)); - end loop; - - for I in Natural loop - Enum := Get_Nth_Element (Enums, I); - exit when Enum = Null_Iir; - Enum_Id := Get_Identifier (Enum); - exit when (Get_Name_Length (Enum_Id) = - Natural (Lit_End - Lit_Start + 1)) - and then (Image (Enum_Id) = - String (Str_Str (Lit_Start .. Lit_End))); - end loop; - end if; - - if Enum = Null_Iir then - Error_Msg_Exec - ("incorrect enumeration literal for 'value", Expr); - end if; - - return Create_Enum_Value - (Natural (Get_Enum_Pos (Enum)), Expr_Type); - end; - when others => - Error_Kind ("value_attribute", Expr_Type); - end case; - return Res; - end Execute_Value_Attribute; - - -- For 'Last_Event and 'Last_Active: convert the absolute last time to - -- a relative delay. - function To_Relative_Time (T : Ghdl_I64) return Iir_Value_Literal_Acc is - A : Ghdl_I64; - begin - if T = -Ghdl_I64'Last then - A := Ghdl_I64'Last; - else - A := Ghdl_I64 (Grt.Types.Current_Time) - T; - end if; - return Create_I64_Value (A); - end To_Relative_Time; - - -- Evaluate an expression. - function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - case Get_Kind (Expr) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Object_Alias_Declaration => - Res := Execute_Name (Block, Expr); - return Res; - - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Attribute_Value - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference => - return Execute_Name (Block, Expr); - - when Iir_Kinds_Denoting_Name - | Iir_Kind_Attribute_Name => - return Execute_Expression (Block, Get_Named_Entity (Expr)); - - when Iir_Kind_Aggregate => - return Execute_Aggregate (Block, Expr, Get_Type (Expr)); - when Iir_Kind_Simple_Aggregate => - return Execute_Simple_Aggregate (Block, Expr); - - when Iir_Kinds_Dyadic_Operator - | Iir_Kinds_Monadic_Operator => - declare - Imp : constant Iir := Get_Implementation (Expr); - begin - if Get_Implicit_Definition (Imp) in Iir_Predefined_Explicit then - return Execute_Function_Call (Block, Expr, Imp); - else - if Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator then - Res := Execute_Implicit_Function - (Block, Expr, Get_Left (Expr), Get_Right (Expr), - Get_Type (Expr)); - else - Res := Execute_Implicit_Function - (Block, Expr, Get_Operand (Expr), Null_Iir, - Get_Type (Expr)); - end if; - return Res; - end if; - end; - - when Iir_Kind_Function_Call => - declare - Imp : constant Iir := Get_Implementation (Expr); - Assoc : Iir; - Args : Iir_Array (0 .. 1); - begin - if Get_Implicit_Definition (Imp) in Iir_Predefined_Explicit then - return Execute_Function_Call (Block, Expr, Imp); - else - Assoc := Get_Parameter_Association_Chain (Expr); - if Assoc /= Null_Iir then - Args (0) := Get_Actual (Assoc); - Assoc := Get_Chain (Assoc); - else - Args (0) := Null_Iir; - end if; - if Assoc /= Null_Iir then - Args (1) := Get_Actual (Assoc); - else - Args (1) := Null_Iir; - end if; - return Execute_Implicit_Function - (Block, Expr, Args (0), Args (1), Get_Type (Expr)); - end if; - end; - - when Iir_Kind_Integer_Literal => - declare - Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); - Lit : constant Iir_Int64 := Get_Value (Expr); - begin - case Get_Info (Lit_Type).Scalar_Mode is - when Iir_Value_I64 => - return Create_I64_Value (Ghdl_I64 (Lit)); - when others => - raise Internal_Error; - end case; - end; - - when Iir_Kind_Floating_Point_Literal => - return Create_F64_Value (Ghdl_F64 (Get_Fp_Value (Expr))); - - when Iir_Kind_Enumeration_Literal => - declare - Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); - Lit : constant Iir_Int32 := Get_Enum_Pos (Expr); - begin - case Get_Info (Lit_Type).Scalar_Mode is - when Iir_Value_B1 => - return Create_B1_Value (Ghdl_B1'Val (Lit)); - when Iir_Value_E8 => - return Create_E8_Value (Ghdl_E8'Val (Lit)); - when Iir_Value_E32 => - return Create_E32_Value (Ghdl_E32 (Lit)); - when others => - raise Internal_Error; - end case; - end; - - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal - | Iir_Kind_Unit_Declaration => - return Create_I64_Value - (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr))); - - when Iir_Kind_String_Literal8 => - return String_To_Enumeration_Array (Block, Expr); - - when Iir_Kind_Null_Literal => - return Null_Lit; - - when Iir_Kind_Overflow_Literal => - Error_Msg_Constraint (Expr); - return null; - - when Iir_Kind_Parenthesis_Expression => - return Execute_Expression (Block, Get_Expression (Expr)); - - when Iir_Kind_Type_Conversion => - return Execute_Type_Conversion - (Block, Execute_Expression (Block, Get_Expression (Expr)), - Get_Type (Expr), Expr); - - when Iir_Kind_Qualified_Expression => - Res := Execute_Expression_With_Type - (Block, Get_Expression (Expr), Get_Type (Get_Type_Mark (Expr))); - return Res; - - when Iir_Kind_Allocator_By_Expression => - Res := Execute_Expression (Block, Get_Expression (Expr)); - Res := Unshare_Heap (Res); - return Create_Access_Value (Res); - - when Iir_Kind_Allocator_By_Subtype => - Res := Create_Value_For_Type - (Block, - Get_Type_Of_Subtype_Indication (Get_Subtype_Indication (Expr)), - Init_Value_Default); - Res := Unshare_Heap (Res); - return Create_Access_Value (Res); - - when Iir_Kind_Left_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_Left_Limit (Res); - - when Iir_Kind_Right_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_Right_Limit (Res); - - when Iir_Kind_High_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_High_Limit (Res); - - when Iir_Kind_Low_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_Low_Limit (Res); - - when Iir_Kind_High_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_High_Limit (Res); - - when Iir_Kind_Low_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Low_Limit (Res); - - when Iir_Kind_Left_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Left_Limit (Res); - - when Iir_Kind_Right_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Right_Limit (Res); - - when Iir_Kind_Length_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Length (Res); - - when Iir_Kind_Ascending_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Boolean_To_Lit (Res.Dir = Iir_To); - - when Iir_Kind_Event_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Boolean_To_Lit (Execute_Event_Attribute (Res)); - - when Iir_Kind_Active_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Boolean_To_Lit (Execute_Active_Attribute (Res)); - - when Iir_Kind_Driving_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Boolean_To_Lit (Execute_Driving_Attribute (Res)); - - when Iir_Kind_Last_Value_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Execute_Last_Value_Attribute (Res); - - when Iir_Kind_Driving_Value_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Execute_Driving_Value_Attribute (Res); - - when Iir_Kind_Last_Event_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return To_Relative_Time (Execute_Last_Event_Attribute (Res)); - - when Iir_Kind_Last_Active_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return To_Relative_Time (Execute_Last_Active_Attribute (Res)); - - when Iir_Kind_Val_Attribute => - declare - Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); - Base_Type : constant Iir := Get_Base_Type (Prefix_Type); - Mode : constant Iir_Value_Kind := - Get_Info (Base_Type).Scalar_Mode; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - case Iir_Value_Discrete (Mode) is - when Iir_Value_I64 => - null; - when Iir_Value_E8 => - Res := Create_E8_Value (Ghdl_E8 (Res.I64)); - when Iir_Value_E32 => - Res := Create_E32_Value (Ghdl_E32 (Res.I64)); - when Iir_Value_B1 => - Res := Create_B1_Value (Ghdl_B1'Val (Res.I64)); - end case; - Check_Constraints (Block, Res, Prefix_Type, Expr); - return Res; - end; - - when Iir_Kind_Pos_Attribute => - declare - N_Res: Iir_Value_Literal_Acc; - Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); - Base_Type : constant Iir := Get_Base_Type (Prefix_Type); - Mode : constant Iir_Value_Kind := - Get_Info (Base_Type).Scalar_Mode; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - case Iir_Value_Discrete (Mode) is - when Iir_Value_I64 => - null; - when Iir_Value_B1 => - N_Res := Create_I64_Value (Ghdl_B1'Pos (Res.B1)); - Res := N_Res; - when Iir_Value_E8 => - N_Res := Create_I64_Value (Ghdl_I64 (Res.E8)); - Res := N_Res; - when Iir_Value_E32 => - N_Res := Create_I64_Value (Ghdl_I64 (Res.E32)); - Res := N_Res; - end case; - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - end; - - when Iir_Kind_Succ_Attribute => - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Res := Execute_Inc (Res, Expr); - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - - when Iir_Kind_Pred_Attribute => - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Res := Execute_Dec (Res, Expr); - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - - when Iir_Kind_Leftof_Attribute => - declare - Bound : Iir_Value_Literal_Acc; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Bound := Execute_Bounds - (Block, Get_Type (Get_Prefix (Expr))); - case Bound.Dir is - when Iir_To => - Res := Execute_Dec (Res, Expr); - when Iir_Downto => - Res := Execute_Inc (Res, Expr); - end case; - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - end; - - when Iir_Kind_Rightof_Attribute => - declare - Bound : Iir_Value_Literal_Acc; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Bound := Execute_Bounds - (Block, Get_Type (Get_Prefix (Expr))); - case Bound.Dir is - when Iir_Downto => - Res := Execute_Dec (Res, Expr); - when Iir_To => - Res := Execute_Inc (Res, Expr); - end case; - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - end; - - when Iir_Kind_Image_Attribute => - return Execute_Image_Attribute (Block, Expr); - - when Iir_Kind_Value_Attribute => - Res := Execute_Expression (Block, Get_Parameter (Expr)); - return Execute_Value_Attribute (Block, Res, Expr); - - when Iir_Kind_Path_Name_Attribute - | Iir_Kind_Instance_Name_Attribute => - return Execute_Path_Instance_Name_Attribute (Block, Expr); - - when others => - Error_Kind ("execute_expression", Expr); - end case; - end Execute_Expression; - - procedure Execute_Dyadic_Association - (Out_Block: Block_Instance_Acc; - In_Block: Block_Instance_Acc; - Expr : Iir; - Inter_Chain: Iir) - is - Inter: Iir; - Val: Iir_Value_Literal_Acc; - begin - Inter := Inter_Chain; - for I in 0 .. 1 loop - if I = 0 then - Val := Execute_Expression (Out_Block, Get_Left (Expr)); - else - Val := Execute_Expression (Out_Block, Get_Right (Expr)); - end if; - Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); - Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); - - Elaboration.Create_Object (In_Block, Inter); - In_Block.Objects (Get_Info (Inter).Slot) := - Unshare (Val, Instance_Pool); - Inter := Get_Chain (Inter); - end loop; - end Execute_Dyadic_Association; - - procedure Execute_Monadic_Association - (Out_Block: Block_Instance_Acc; - In_Block: Block_Instance_Acc; - Expr : Iir; - Inter: Iir) - is - Val: Iir_Value_Literal_Acc; - begin - Val := Execute_Expression (Out_Block, Get_Operand (Expr)); - Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); - Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); - - Elaboration.Create_Object (In_Block, Inter); - In_Block.Objects (Get_Info (Inter).Slot) := - Unshare (Val, Instance_Pool); - end Execute_Monadic_Association; - - -- Create a block instance for subprogram IMP. - function Create_Subprogram_Instance (Instance : Block_Instance_Acc; - Prot_Obj : Block_Instance_Acc; - Imp : Iir) - return Block_Instance_Acc - is - Func_Info : constant Sim_Info_Acc := Get_Info (Imp); - - subtype Block_Type is Block_Instance_Type (Func_Info.Nbr_Objects); - function To_Block_Instance_Acc is new - Ada.Unchecked_Conversion (System.Address, Block_Instance_Acc); - function Alloc_Block_Instance is new - Alloc_On_Pool_Addr (Block_Type); - - Up_Block: Block_Instance_Acc; - Up_Info : Sim_Info_Acc; - Res : Block_Instance_Acc; - - Origin : Iir; - Label : Iir; - begin - pragma Assert (Get_Kind (Imp) in Iir_Kinds_Subprogram_Declaration - or else Get_Kind (Imp) = Iir_Kind_Protected_Type_Body); - - if Prot_Obj /= null then - Up_Block := Prot_Obj; - Label := Imp; - else - Up_Info := Get_Info (Get_Parent (Imp)); - Up_Block := Get_Instance_By_Scope (Instance, Up_Info.Frame_Scope); - - Origin := Sem_Inst.Get_Origin (Imp); - if Origin /= Null_Iir then - -- Call to a subprogram of an instantiated package. - -- For a generic package, only the spec is instantiated, the body - -- is shared by all the instances. - - -- Execute code of the 'shared' body - Label := Origin; - - -- Get the real instance for package interface. - if Up_Info.Kind = Kind_Environment then - Up_Block := Environment_Table.Table - (Up_Block.Objects (Up_Info.Env_Slot).Environment); - end if; - else - Label := Imp; - end if; - end if; - - Res := To_Block_Instance_Acc - (Alloc_Block_Instance - (Instance_Pool, - Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects, - Id => No_Block_Instance_Id, - Block_Scope => Get_Info (Label).Frame_Scope, - Up_Block => Up_Block, - Label => Label, - Stmt => Null_Iir, - Parent => Instance, - Children => null, - Brother => null, - Ports_Map => Null_Iir, - Marker => Empty_Marker, - Objects => (others => null), - Elab_Objects => 0, - In_Wait_Flag => False, - Actuals_Ref => null, - Result => null))); - return Res; - end Create_Subprogram_Instance; - - -- Destroy a dynamic block_instance. - procedure Execute_Subprogram_Call_Final (Instance : Block_Instance_Acc) - is - Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); - begin - Finalize_Declarative_Part - (Instance, Get_Declaration_Chain (Subprg_Body)); - end Execute_Subprogram_Call_Final; - - function Execute_Function_Body (Instance : Block_Instance_Acc) - return Iir_Value_Literal_Acc - is - Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); - Res : Iir_Value_Literal_Acc; - begin - Current_Process.Instance := Instance; - - Elaborate_Declarative_Part - (Instance, Get_Declaration_Chain (Subprg_Body)); - - -- execute statements - Instance.Stmt := Get_Sequential_Statement_Chain (Subprg_Body); - Execute_Sequential_Statements (Current_Process); - pragma Assert (Current_Process.Instance = Instance); - - if Instance.Result = null then - Error_Msg_Exec - ("function scope exited without a return statement", - Instance.Label); - end if; - - -- Free variables, slots... - -- Need to copy the return value, because it can contains values from - -- arguments. - Res := Instance.Result; - - Current_Process.Instance := Instance.Parent; - Execute_Subprogram_Call_Final (Instance); - - return Res; - end Execute_Function_Body; - - function Execute_Assoc_Function_Conversion - (Block : Block_Instance_Acc; Func : Iir; Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Inter : Iir; - Instance : Block_Instance_Acc; - Res : Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - Mark (Marker, Instance_Pool.all); - - -- Create an instance for this function. - Instance := Create_Subprogram_Instance (Block, null, Func); - - Inter := Get_Interface_Declaration_Chain (Func); - Elaboration.Create_Object (Instance, Inter); - -- FIXME: implicit conversion - Instance.Objects (Get_Info (Inter).Slot) := Val; - - Res := Execute_Function_Body (Instance); - Res := Unshare (Res, Expr_Pool'Access); - Release (Marker, Instance_Pool.all); - return Res; - end Execute_Assoc_Function_Conversion; - - function Execute_Assoc_Conversion - (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Ent : Iir; - begin - case Get_Kind (Conv) is - when Iir_Kind_Function_Call => - -- FIXME: shouldn't CONV always be a denoting_name ? - return Execute_Assoc_Function_Conversion - (Block, Get_Implementation (Conv), Val); - when Iir_Kind_Type_Conversion => - -- FIXME: shouldn't CONV always be a denoting_name ? - return Execute_Type_Conversion (Block, Val, Get_Type (Conv), Conv); - when Iir_Kinds_Denoting_Name - | Iir_Kind_Function_Declaration => - Ent := Strip_Denoting_Name (Conv); - if Get_Kind (Ent) = Iir_Kind_Function_Declaration then - return Execute_Assoc_Function_Conversion (Block, Ent, Val); - elsif Get_Kind (Ent) in Iir_Kinds_Type_Declaration then - return Execute_Type_Conversion - (Block, Val, Get_Type (Ent), Ent); - else - Error_Kind ("execute_assoc_conversion(1)", Ent); - end if; - when others => - Error_Kind ("execute_assoc_conversion(2)", Conv); - end case; - end Execute_Assoc_Conversion; - - procedure Associate_By_Reference (Block : Block_Instance_Acc; - Formal : Iir; - Formal_Base : Iir_Value_Literal_Acc; - Actual : Iir_Value_Literal_Acc) - is - Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Formal)); - Is_Sig : Boolean; - Pfx : Iir_Value_Literal_Acc; - Pos : Iir_Index32; - begin - if Get_Kind (Prefix) = Iir_Kind_Slice_Name then - -- That case is not handled correctly. - raise Program_Error; - end if; - Execute_Name_With_Base (Block, Prefix, Formal_Base, Pfx, Is_Sig); - - case Get_Kind (Formal) is - when Iir_Kind_Indexed_Name => - Execute_Indexed_Name (Block, Formal, Pfx, Pos); - Store (Pfx.Val_Array.V (Pos + 1), Actual); - when Iir_Kind_Slice_Name => - declare - Low, High : Iir_Index32; - Srange : Iir_Value_Literal_Acc; - begin - Srange := Execute_Bounds (Block, Get_Suffix (Formal)); - Execute_Slice_Name (Pfx, Srange, Low, High, Formal); - for I in 1 .. High - Low + 1 loop - Store (Pfx.Val_Array.V (Low + I), Actual.Val_Array.V (I)); - end loop; - end; - when Iir_Kind_Selected_Element => - Pos := Get_Element_Position (Get_Selected_Element (Formal)); - Store (Pfx.Val_Record.V (Pos + 1), Actual); - when others => - Error_Kind ("associate_by_reference", Formal); - end case; - end Associate_By_Reference; - - -- Establish correspondance for association list ASSOC_LIST from block - -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK. - procedure Execute_Association - (Out_Block : Block_Instance_Acc; - Subprg_Block : Block_Instance_Acc; - Inter_Chain : Iir; - Assoc_Chain : Iir) - is - Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain); - Assoc: Iir; - Assoc_Inter : Iir; - Actual : Iir; - Inter: Iir; - Formal : Iir; - Conv : Iir; - Val: Iir_Value_Literal_Acc; - Assoc_Idx : Iir_Index32; - Last_Individual : Iir_Value_Literal_Acc; - Mode : Iir_Mode; - Marker : Mark_Type; - begin - Subprg_Block.Actuals_Ref := null; - Mark (Marker, Expr_Pool); - - Assoc := Assoc_Chain; - Assoc_Inter := Inter_Chain; - Assoc_Idx := 1; - while Assoc /= Null_Iir loop - Inter := Get_Association_Interface (Assoc, Assoc_Inter); - Formal := Get_Association_Formal (Assoc, Inter); - - -- Extract the actual value. - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_Open => - -- Not allowed in individual association. - pragma Assert (Formal = Inter); - pragma Assert (Get_Whole_Association_Flag (Assoc)); - Actual := Get_Default_Value (Inter); - when Iir_Kind_Association_Element_By_Expression => - Actual := Get_Actual (Assoc); - when Iir_Kind_Association_Element_By_Individual => - -- Directly create the whole value on the instance pool, as its - -- life is longer than the statement. - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then - Last_Individual := Create_Value_For_Type - (Out_Block, Get_Actual_Type (Assoc), Init_Value_Signal); - else - Last_Individual := Create_Value_For_Type - (Out_Block, Get_Actual_Type (Assoc), Init_Value_Any); - end if; - Last_Individual := - Unshare (Last_Individual, Instance_Pool); - Elaboration.Create_Object (Subprg_Block, Inter); - Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual; - goto Continue; - when others => - Error_Kind ("execute_association(1)", Assoc); - end case; - - -- Compute actual value. - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - Val := Execute_Expression (Out_Block, Actual); - Implicit_Array_Conversion - (Subprg_Block, Val, Get_Type (Formal), Assoc); - Check_Constraints (Subprg_Block, Val, Get_Type (Formal), Assoc); - when Iir_Kind_Interface_Signal_Declaration => - Val := Execute_Name (Out_Block, Actual, True); - Implicit_Array_Conversion - (Subprg_Block, Val, Get_Type (Formal), Assoc); - when Iir_Kind_Interface_Variable_Declaration => - Mode := Get_Mode (Inter); - if Mode = Iir_In_Mode then - -- FIXME: Ref ? - Val := Execute_Expression (Out_Block, Actual); - else - Val := Execute_Name (Out_Block, Actual, False); - end if; - - -- FIXME: by value for scalars ? - - -- Keep ref for back-copy - if Mode /= Iir_In_Mode then - if Subprg_Block.Actuals_Ref = null then - declare - subtype Actuals_Ref_Type is - Value_Array (Iir_Index32 (Nbr_Assoc)); - function To_Value_Array_Acc is new - Ada.Unchecked_Conversion (System.Address, - Value_Array_Acc); - function Alloc_Actuals_Ref is new - Alloc_On_Pool_Addr (Actuals_Ref_Type); - - begin - Subprg_Block.Actuals_Ref := To_Value_Array_Acc - (Alloc_Actuals_Ref - (Instance_Pool, - Actuals_Ref_Type'(Len => Iir_Index32 (Nbr_Assoc), - V => (others => null)))); - end; - end if; - Subprg_Block.Actuals_Ref.V (Assoc_Idx) := - Unshare_Bounds (Val, Instance_Pool); - end if; - - if Mode = Iir_Out_Mode then - if Get_Formal_Conversion (Assoc) /= Null_Iir then - -- For an OUT variable using an out conversion, don't - -- associate with the actual, create a temporary value. - Val := Create_Value_For_Type - (Out_Block, Get_Type (Formal), Init_Value_Default); - elsif Get_Kind (Get_Type (Formal)) in - Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - -- These are passed by value. Must be reset. - Val := Create_Value_For_Type - (Out_Block, Get_Type (Formal), Init_Value_Default); - end if; - else - if Get_Kind (Assoc) = - Iir_Kind_Association_Element_By_Expression - then - Conv := Get_Actual_Conversion (Assoc); - if Conv /= Null_Iir then - Val := Execute_Assoc_Conversion - (Subprg_Block, Conv, Val); - end if; - end if; - - -- FIXME: check constraints ? - end if; - - Implicit_Array_Conversion - (Subprg_Block, Val, Get_Type (Formal), Assoc); - - when others => - Error_Kind ("execute_association(2)", Inter); - end case; - - if Get_Whole_Association_Flag (Assoc) then - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_File_Declaration => - -- FIXME: Arguments are passed by copy. - Elaboration.Create_Object (Subprg_Block, Inter); - Subprg_Block.Objects (Get_Info (Inter).Slot) := - Unshare (Val, Instance_Pool); - when Iir_Kind_Interface_Signal_Declaration => - Elaboration.Create_Signal (Subprg_Block, Inter); - Subprg_Block.Objects (Get_Info (Inter).Slot) := - Unshare_Bounds (Val, Instance_Pool); - when others => - Error_Kind ("execute_association", Inter); - end case; - else - Associate_By_Reference - (Subprg_Block, Formal, Last_Individual, Val); - end if; - - << Continue >> null; - Next_Association_Interface (Assoc, Assoc_Inter); - Assoc_Idx := Assoc_Idx + 1; - end loop; - - Release (Marker, Expr_Pool); - end Execute_Association; - - procedure Execute_Back_Association (Instance : Block_Instance_Acc) - is - Call : constant Iir := Get_Procedure_Call (Instance.Parent.Stmt); - Imp : constant Iir := Get_Implementation (Call); - Assoc : Iir; - Assoc_Inter : Iir; - Inter : Iir; - Formal : Iir; - Assoc_Idx : Iir_Index32; - begin - Assoc := Get_Parameter_Association_Chain (Call); - Assoc_Inter := Get_Interface_Declaration_Chain (Imp); - Assoc_Idx := 1; - while Assoc /= Null_Iir loop - if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then - Inter := Get_Association_Interface (Assoc, Assoc_Inter); - Formal := Get_Association_Formal (Assoc, Inter); - - case Get_Kind (Inter) is - when Iir_Kind_Interface_Variable_Declaration => - if Get_Mode (Inter) /= Iir_In_Mode - and then Get_Kind (Get_Type (Inter)) /= - Iir_Kind_File_Type_Definition - then - -- For out/inout variable interface, the value must - -- be copied (FIXME: unless when passed by reference ?). - declare - Targ : constant Iir_Value_Literal_Acc := - Instance.Actuals_Ref.V (Assoc_Idx); - Base : constant Iir_Value_Literal_Acc := - Instance.Objects (Get_Info (Inter).Slot); - Val : Iir_Value_Literal_Acc; - Conv : Iir; - Is_Sig : Boolean; - Expr_Mark : Mark_Type; - begin - Mark (Expr_Mark, Expr_Pool); - - -- Extract for individual association. - Execute_Name_With_Base - (Instance, Formal, Base, Val, Is_Sig); - Conv := Get_Formal_Conversion (Assoc); - if Conv /= Null_Iir then - Val := Execute_Assoc_Conversion - (Instance, Conv, Val); - -- FIXME: free val ? - end if; - Store (Targ, Val); - - Release (Expr_Mark, Expr_Pool); - end; - end if; - when Iir_Kind_Interface_File_Declaration => - null; - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Constant_Declaration => - null; - when others => - Error_Kind ("execute_back_association", Inter); - end case; - end if; - Next_Association_Interface (Assoc, Assoc_Inter); - Assoc_Idx := Assoc_Idx + 1; - end loop; - end Execute_Back_Association; - - function Get_Protected_Object_Instance - (Block : Block_Instance_Acc; Call : Iir) return Block_Instance_Acc - is - Meth_Obj : constant Iir := Get_Method_Object (Call); - Obj : Iir_Value_Literal_Acc; - begin - if Meth_Obj = Null_Iir then - return null; - else - Obj := Execute_Name (Block, Meth_Obj, True); - return Protected_Table.Table (Obj.Prot); - end if; - end Get_Protected_Object_Instance; - - function Execute_Foreign_Function_Call - (Block: Block_Instance_Acc; Expr : Iir; Imp : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Get_Identifier (Imp) is - when Std_Names.Name_Get_Resolution_Limit => - Res := Create_I64_Value - (Ghdl_I64 - (Evaluation.Get_Physical_Value (Std_Package.Time_Base))); - when Std_Names.Name_Textio_Read_Real => - Res := Create_F64_Value - (File_Operation.Textio_Read_Real (Block.Objects (1))); - when others => - Error_Msg_Exec ("unsupported foreign function call", Expr); - end case; - return Res; - end Execute_Foreign_Function_Call; - - -- BLOCK is the block instance in which the function call appears. - function Execute_Function_Call - (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) - return Iir_Value_Literal_Acc - is - Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); - Subprg_Block: Block_Instance_Acc; - Prot_Block : Block_Instance_Acc; - Assoc_Chain: Iir; - Res : Iir_Value_Literal_Acc; - begin - Mark (Block.Marker, Instance_Pool.all); - - case Get_Kind (Expr) is - when Iir_Kind_Function_Call => - Prot_Block := Get_Protected_Object_Instance (Block, Expr); - Subprg_Block := - Create_Subprogram_Instance (Block, Prot_Block, Imp); - Assoc_Chain := Get_Parameter_Association_Chain (Expr); - Execute_Association - (Block, Subprg_Block, Inter_Chain, Assoc_Chain); - -- No out/inout interface for functions. - pragma Assert (Subprg_Block.Actuals_Ref = null); - when Iir_Kinds_Dyadic_Operator => - Subprg_Block := Create_Subprogram_Instance (Block, null, Imp); - Execute_Dyadic_Association - (Block, Subprg_Block, Expr, Inter_Chain); - when Iir_Kinds_Monadic_Operator => - Subprg_Block := Create_Subprogram_Instance (Block, null, Imp); - Execute_Monadic_Association - (Block, Subprg_Block, Expr, Inter_Chain); - when others => - Error_Kind ("execute_subprogram_call_init", Expr); - end case; - - if Get_Foreign_Flag (Imp) then - Res := Execute_Foreign_Function_Call (Subprg_Block, Expr, Imp); - else - Res := Execute_Function_Body (Subprg_Block); - end if; - - -- Unfortunately, we don't know where the result has been allocated, - -- so copy it before releasing the instance pool. - Res := Unshare (Res, Expr_Pool'Access); - - Release (Block.Marker, Instance_Pool.all); - - return Res; - end Execute_Function_Call; - - -- Slide an array VALUE using bounds from REF_VALUE. Do not modify - -- VALUE if not an array. - procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; - Ref_Value : Iir_Value_Literal_Acc; - Expr : Iir) - is - Res : Iir_Value_Literal_Acc; - begin - if Value.Kind /= Iir_Value_Array then - return; - end if; - Res := Create_Array_Value (Value.Bounds.Nbr_Dims); - Res.Val_Array := Value.Val_Array; - for I in Value.Bounds.D'Range loop - if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then - Error_Msg_Constraint (Expr); - return; - end if; - Res.Bounds.D (I) := Ref_Value.Bounds.D (I); - end loop; - Value := Res; - end Implicit_Array_Conversion; - - procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; - Value : in out Iir_Value_Literal_Acc; - Ref_Type : Iir; - Expr : Iir) - is - Ref_Value : Iir_Value_Literal_Acc; - begin - -- Do array conversion only if REF_TYPE is a constrained array type - -- definition. - if Value.Kind /= Iir_Value_Array then - return; - end if; - if Get_Constraint_State (Ref_Type) /= Fully_Constrained then - return; - end if; - Ref_Value := Create_Array_Bounds_From_Type (Instance, Ref_Type, True); - for I in Value.Bounds.D'Range loop - if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then - Error_Msg_Constraint (Expr); - return; - end if; - end loop; - Ref_Value.Val_Array.V := Value.Val_Array.V; - Value := Ref_Value; - end Implicit_Array_Conversion; - - procedure Check_Array_Constraints - (Instance: Block_Instance_Acc; - Value: Iir_Value_Literal_Acc; - Def: Iir; - Expr: Iir) - is - Index_List : Iir_Flist; - Element_Subtype : Iir; - New_Bounds : Iir_Value_Literal_Acc; - begin - -- Nothing to check for unconstrained arrays. - if not Get_Index_Constraint_Flag (Def) then - return; - end if; - - Index_List := Get_Index_Subtype_List (Def); - for I in Value.Bounds.D'Range loop - New_Bounds := Execute_Bounds - (Instance, Get_Nth_Element (Index_List, Natural (I - 1))); - if not Is_Equal (Value.Bounds.D (I), New_Bounds) then - Error_Msg_Constraint (Expr); - return; - end if; - end loop; - - if Boolean'(False) then - Index_List := Get_Index_List (Def); - Element_Subtype := Get_Element_Subtype (Def); - for I in Value.Val_Array.V'Range loop - Check_Constraints - (Instance, Value.Val_Array.V (I), Element_Subtype, Expr); - end loop; - end if; - end Check_Array_Constraints; - - -- Check DEST and SRC are array compatible. - procedure Check_Array_Match - (Instance: Block_Instance_Acc; - Dest: Iir_Value_Literal_Acc; - Src : Iir_Value_Literal_Acc; - Expr: Iir) - is - pragma Unreferenced (Instance); - begin - for I in Dest.Bounds.D'Range loop - if Dest.Bounds.D (I).Length /= Src.Bounds.D (I).Length then - Error_Msg_Constraint (Expr); - exit; - end if; - end loop; - end Check_Array_Match; - pragma Unreferenced (Check_Array_Match); - - procedure Check_Constraints - (Instance: Block_Instance_Acc; - Value: Iir_Value_Literal_Acc; - Def: Iir; - Expr: Iir) - is - Base_Type : constant Iir := Get_Base_Type (Def); - High, Low: Iir_Value_Literal_Acc; - Bound : Iir_Value_Literal_Acc; - begin - case Get_Kind (Def) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition => - Bound := Execute_Bounds (Instance, Def); - if Bound.Dir = Iir_To then - High := Bound.Right; - Low := Bound.Left; - else - High := Bound.Left; - Low := Bound.Right; - end if; - case Iir_Value_Scalars (Get_Info (Base_Type).Scalar_Mode) is - when Iir_Value_I64 => - if Value.I64 in Low.I64 .. High.I64 then - return; - end if; - when Iir_Value_E8 => - if Value.E8 in Low.E8 .. High.E8 then - return; - end if; - when Iir_Value_E32 => - if Value.E32 in Low.E32 .. High.E32 then - return; - end if; - when Iir_Value_F64 => - if Value.F64 in Low.F64 .. High.F64 then - return; - end if; - when Iir_Value_B1 => - if Value.B1 in Low.B1 .. High.B1 then - return; - end if; - end case; - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - Check_Array_Constraints (Instance, Value, Def, Expr); - return; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Def)); - El : Iir_Element_Declaration; - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Check_Constraints - (Instance, - Value.Val_Record.V (Get_Element_Position (El) + 1), - Get_Type (El), - Expr); - end loop; - end; - return; - when Iir_Kind_Integer_Type_Definition => - return; - when Iir_Kind_Floating_Type_Definition => - return; - when Iir_Kind_Physical_Type_Definition => - return; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - return; - when Iir_Kind_File_Type_Definition => - return; - when others => - Error_Kind ("check_constraints", Def); - end case; - Error_Msg_Constraint (Expr); - end Check_Constraints; - - function Execute_Resolution_Function - (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Inter : Iir; - Instance : Block_Instance_Acc; - begin - -- Create a frame for this function. - Instance := Create_Subprogram_Instance (Block, null, Imp); - - Inter := Get_Interface_Declaration_Chain (Imp); - Elaboration.Create_Object (Instance, Inter); - Instance.Objects (Get_Info (Inter).Slot) := Arr; - - return Execute_Function_Body (Instance); - end Execute_Resolution_Function; - - procedure Execute_Signal_Assignment - (Instance: Block_Instance_Acc; - Stmt: Iir_Signal_Assignment_Statement) - is - Wf : constant Iir_Waveform_Element := Get_Waveform_Chain (Stmt); - Nbr_We : constant Natural := Get_Chain_Length (Wf); - - Transactions : Transaction_Type (Nbr_We); - - We: Iir_Waveform_Element; - Res: Iir_Value_Literal_Acc; - Rdest: Iir_Value_Literal_Acc; - Targ_Type : Iir; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - - Rdest := Execute_Name (Instance, Get_Target (Stmt), True); - Targ_Type := Get_Type (Get_Target (Stmt)); - - -- Disconnection statement. - if Wf = Null_Iir then - Disconnect_Signal (Rdest); - Release (Marker, Expr_Pool); - return; - end if; - - Transactions.Stmt := Stmt; - - -- LRM93 8.4.1 - -- Evaluation of a waveform consists of the evaluation of each waveform - -- elements in the waveform. - We := Wf; - for I in Transactions.Els'Range loop - declare - Trans : Transaction_El_Type renames Transactions.Els (I); - begin - if Get_Time (We) /= Null_Iir then - Res := Execute_Expression (Instance, Get_Time (We)); - -- LRM93 8.4.1 - -- It is an error if the time expression in a waveform element - -- evaluates to a negative value. - if Res.I64 < 0 then - Error_Msg_Exec ("time value is negative", Get_Time (We)); - end if; - Trans.After := Std_Time (Res.I64); - else - -- LRM93 8.4.1 - -- If the after clause of a waveform element is not present, - -- then an implicit "after 0 ns" is assumed. - Trans.After := 0; - end if; - - -- LRM93 8.4.1 - -- It is an error if the sequence of new transactions is not in - -- ascending order with respect to time. - if I > 1 - and then Trans.After <= Transactions.Els (I - 1).After - then - Error_Msg_Exec - ("sequence not in ascending order with respect to time", We); - end if; - - if Get_Kind (Get_We_Value (We)) = Iir_Kind_Null_Literal then - -- null transaction. - Trans.Value := null; - else - -- LRM93 8.4.1 - -- For the first form of waveform element, the value component - -- of the transaction is determined by the value expression in - -- the waveform element. - Trans.Value := Execute_Expression_With_Type - (Instance, Get_We_Value (We), Targ_Type); - end if; - end; - We := Get_Chain (We); - end loop; - pragma Assert (We = Null_Iir); - - case Get_Delay_Mechanism (Stmt) is - when Iir_Transport_Delay => - Transactions.Reject := 0; - when Iir_Inertial_Delay => - -- LRM93 8.4 - -- or, in the case that a pulse rejection limit is specified, - -- a pulse whose duration is shorter than that limit will not - -- be transmitted. - -- Every inertially delayed signal assignment has a pulse - -- rejection limit. - if Get_Reject_Time_Expression (Stmt) /= Null_Iir then - -- LRM93 8.4 - -- If the delay mechanism specifies inertial delay, and if the - -- reserved word reject followed by a time expression is - -- present, then the time expression specifies the pulse - -- rejection limit. - Res := Execute_Expression - (Instance, Get_Reject_Time_Expression (Stmt)); - -- LRM93 8.4 - -- It is an error if the pulse rejection limit for any - -- inertially delayed signal assignement statement is either - -- negative ... - if Res.I64 < 0 then - Error_Msg_Exec ("reject time negative", Stmt); - end if; - -- LRM93 8.4 - -- ... or greather than the time expression associated with - -- the first waveform element. - Transactions.Reject := Std_Time (Res.I64); - if Transactions.Reject > Transactions.Els (1).After then - Error_Msg_Exec - ("reject time greather than time expression", Stmt); - end if; - else - -- LRM93 8.4 - -- In all other cases, the pulse rejection limit is the time - -- expression associated ith the first waveform element. - Transactions.Reject := Transactions.Els (1).After; - end if; - end case; - - -- FIXME: slice Transactions to remove transactions after end of time. - Assign_Value_To_Signal (Instance, Rdest, Transactions); - - Release (Marker, Expr_Pool); - end Execute_Signal_Assignment; - - -- Display a message when an assertion has failed. - -- REPORT is the value (string) to display, or null to use default message. - -- SEVERITY is the severity or null to use default (error). - -- STMT is used to display location. - procedure Execute_Failed_Assertion (Msg : String; - Report : String; - Severity : Natural; - Stmt: Iir) is - begin - -- LRM93 8.2 - -- The error message consists of at least: - - -- 4: name of the design unit containing the assertion. - Put (Standard_Error, Disp_Location (Stmt)); - - -- 1: an indication that this message is from an assertion. - Put (Standard_Error, '('); - Put (Standard_Error, Msg); - Put (Standard_Error, ' '); - - -- 2: the value of the severity level. - case Severity is - when 0 => - Put (Standard_Error, "note"); - when 1 => - Put (Standard_Error, "warning"); - when 2 => - Put (Standard_Error, "error"); - when 3 => - Put (Standard_Error, "failure"); - when others => - Error_Internal (Null_Iir, "execute_failed_assertion"); - end case; - if Disp_Time_Before_Values then - Put (Standard_Error, " at "); - Grt.Astdio.Put_Time (Grt.Stdio.stderr, Current_Time); - end if; - Put (Standard_Error, "): "); - - -- 3: the value of the message string. - Put_Line (Standard_Error, Report); - - -- Stop execution if the severity is too high. - if Severity >= Grt.Options.Severity_Level then - Debug (Reason_Assert); - Grt.Errors.Fatal_Error; - end if; - end Execute_Failed_Assertion; - - procedure Execute_Failed_Assertion - (Instance: Block_Instance_Acc; - Label : String; - Stmt : Iir; - Default_Msg : String; - Default_Severity : Natural) - is - Expr: Iir; - Report, Severity_Lit: Iir_Value_Literal_Acc; - Severity : Natural; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - Expr := Get_Report_Expression (Stmt); - if Expr /= Null_Iir then - Report := Execute_Expression (Instance, Expr); - else - Report := null; - end if; - Expr := Get_Severity_Expression (Stmt); - if Expr /= Null_Iir then - Severity_Lit := Execute_Expression (Instance, Expr); - Severity := Natural'Val (Severity_Lit.E8); - else - Severity := Default_Severity; - end if; - if Report /= null then - declare - Msg : String (1 .. Natural (Report.Val_Array.Len)); - begin - for I in Report.Val_Array.V'Range loop - Msg (Positive (I)) := - Character'Val (Report.Val_Array.V (I).E8); - end loop; - Execute_Failed_Assertion (Label, Msg, Severity, Stmt); - end; - else - Execute_Failed_Assertion (Label, Default_Msg, Severity, Stmt); - end if; - Release (Marker, Expr_Pool); - end Execute_Failed_Assertion; - - function Is_In_Choice - (Instance: Block_Instance_Acc; - Choice: Iir; - Expr: Iir_Value_Literal_Acc) - return Boolean - is - Res : Boolean; - begin - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Others => - return True; - when Iir_Kind_Choice_By_Expression => - declare - Expr1: Iir_Value_Literal_Acc; - begin - Expr1 := Execute_Expression - (Instance, Get_Choice_Expression (Choice)); - Res := Is_Equal (Expr, Expr1); - return Res; - end; - when Iir_Kind_Choice_By_Range => - declare - A_Range : Iir_Value_Literal_Acc; - begin - A_Range := Execute_Bounds - (Instance, Get_Choice_Range (Choice)); - Res := Is_In_Range (Expr, A_Range); - end; - return Res; - when others => - Error_Kind ("is_in_choice", Choice); - end case; - end Is_In_Choice; - - -- Return TRUE iff VAL is in the range defined by BOUNDS. - function Is_In_Range (Val : Iir_Value_Literal_Acc; - Bounds : Iir_Value_Literal_Acc) - return Boolean - is - Max, Min : Iir_Value_Literal_Acc; - begin - case Bounds.Dir is - when Iir_To => - Min := Bounds.Left; - Max := Bounds.Right; - when Iir_Downto => - Min := Bounds.Right; - Max := Bounds.Left; - end case; - - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_E8 => - return Val.E8 >= Min.E8 and Val.E8 <= Max.E8; - when Iir_Value_E32 => - return Val.E32 >= Min.E32 and Val.E32 <= Max.E32; - when Iir_Value_B1 => - return Val.B1 >= Min.B1 and Val.B1 <= Max.B1; - when Iir_Value_I64 => - return Val.I64 >= Min.I64 and Val.I64 <= Max.I64; - end case; - end Is_In_Range; - - -- Increment or decrement VAL according to BOUNDS.DIR. - -- FIXME: use increment ? - procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; - Bounds : Iir_Value_Literal_Acc) - is - begin - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_E8 => - case Bounds.Dir is - when Iir_To => - Val.E8 := Val.E8 + 1; - when Iir_Downto => - Val.E8 := Val.E8 - 1; - end case; - when Iir_Value_E32 => - case Bounds.Dir is - when Iir_To => - Val.E32 := Val.E32 + 1; - when Iir_Downto => - Val.E32 := Val.E32 - 1; - end case; - when Iir_Value_B1 => - case Bounds.Dir is - when Iir_To => - Val.B1 := True; - when Iir_Downto => - Val.B1 := False; - end case; - when Iir_Value_I64 => - case Bounds.Dir is - when Iir_To => - Val.I64 := Val.I64 + 1; - when Iir_Downto => - Val.I64 := Val.I64 - 1; - end case; - end case; - end Update_Loop_Index; - - procedure Finalize_For_Loop_Statement (Instance : Block_Instance_Acc; - Stmt : Iir) - is - begin - Destroy_Iterator_Declaration - (Instance, Get_Parameter_Specification (Stmt)); - end Finalize_For_Loop_Statement; - - procedure Finalize_Loop_Statement (Instance : Block_Instance_Acc; - Stmt : Iir) - is - begin - if Get_Kind (Stmt) = Iir_Kind_For_Loop_Statement then - Finalize_For_Loop_Statement (Instance, Stmt); - end if; - end Finalize_Loop_Statement; - - procedure Execute_For_Loop_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir_For_Loop_Statement := Instance.Stmt; - Iterator : constant Iir := Get_Parameter_Specification (Stmt); - Bounds : Iir_Value_Literal_Acc; - Index : Iir_Value_Literal_Acc; - Stmt_Chain : Iir; - Is_Nul : Boolean; - Marker : Mark_Type; - begin - -- Elaborate the iterator (and its type). - Elaborate_Declaration (Instance, Iterator); - - -- Extract bounds. - Mark (Marker, Expr_Pool); - Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); - Index := Instance.Objects (Get_Info (Iterator).Slot); - Store (Index, Bounds.Left); - Is_Nul := Is_Null_Range (Bounds); - Release (Marker, Expr_Pool); - - if Is_Nul then - -- Loop is complete. - Finalize_For_Loop_Statement (Instance, Stmt); - Update_Next_Statement (Proc); - else - Stmt_Chain := Get_Sequential_Statement_Chain (Stmt); - if Stmt_Chain = Null_Iir then - -- Nothing to do for an empty loop. - Finalize_For_Loop_Statement (Instance, Stmt); - Update_Next_Statement (Proc); - else - Instance.Stmt := Stmt_Chain; - end if; - end if; - end Execute_For_Loop_Statement; - - -- This function is called when there is no more statements to execute - -- in the statement list of a for_loop. Returns FALSE in case of end of - -- loop. - function Finish_For_Loop_Statement (Instance : Block_Instance_Acc) - return Boolean - is - Iterator : constant Iir := Get_Parameter_Specification (Instance.Stmt); - Bounds : Iir_Value_Literal_Acc; - Index : Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - -- FIXME: avoid allocation. - Mark (Marker, Expr_Pool); - Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); - Index := Instance.Objects (Get_Info (Iterator).Slot); - - if Is_Equal (Index, Bounds.Right) then - -- Loop is complete. - Release (Marker, Expr_Pool); - Finalize_For_Loop_Statement (Instance, Instance.Stmt); - return False; - else - -- Update the loop index. - Update_Loop_Index (Index, Bounds); - - Release (Marker, Expr_Pool); - - -- start the loop again. - Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); - return True; - end if; - end Finish_For_Loop_Statement; - - -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. - function Execute_Condition (Instance : Block_Instance_Acc; - Cond : Iir) return Boolean - is - V : Iir_Value_Literal_Acc; - Res : Boolean; - Marker : Mark_Type; - begin - if Cond = Null_Iir then - return True; - end if; - - Mark (Marker, Expr_Pool); - V := Execute_Expression (Instance, Cond); - Res := V.B1 = True; - Release (Marker, Expr_Pool); - return Res; - end Execute_Condition; - - -- Start a while loop statement, or return FALSE if the loop is not - -- executed. - procedure Execute_While_Loop_Statement (Proc : Process_State_Acc) - is - Instance: constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Cond : Boolean; - begin - Cond := Execute_Condition (Instance, Get_Condition (Stmt)); - if Cond then - Init_Sequential_Statements (Proc, Stmt); - else - Update_Next_Statement (Proc); - end if; - end Execute_While_Loop_Statement; - - -- This function is called when there is no more statements to execute - -- in the statement list of a while loop. Returns FALSE iff loop is - -- completed. - function Finish_While_Loop_Statement (Instance : Block_Instance_Acc) - return Boolean - is - Cond : Boolean; - begin - Cond := Execute_Condition (Instance, Get_Condition (Instance.Stmt)); - - if Cond then - -- start the loop again. - Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); - return True; - else - -- Loop is complete. - return False; - end if; - end Finish_While_Loop_Statement; - - -- Return TRUE if the loop must be executed again - function Finish_Loop_Statement (Instance : Block_Instance_Acc; - Stmt : Iir) return Boolean is - begin - Instance.Stmt := Stmt; - case Get_Kind (Stmt) is - when Iir_Kind_While_Loop_Statement => - return Finish_While_Loop_Statement (Instance); - when Iir_Kind_For_Loop_Statement => - return Finish_For_Loop_Statement (Instance); - when others => - Error_Kind ("finish_loop_statement", Stmt); - end case; - end Finish_Loop_Statement; - - -- Return FALSE if the next statement should be executed (possibly - -- updated). - procedure Execute_Exit_Next_Statement (Proc : Process_State_Acc; - Is_Exit : Boolean) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Label : constant Iir := Get_Named_Entity (Get_Loop_Label (Stmt)); - Cond : Boolean; - Parent : Iir; - begin - Cond := Execute_Condition (Instance, Get_Condition (Stmt)); - if not Cond then - Update_Next_Statement (Proc); - return; - end if; - - Parent := Stmt; - loop - Parent := Get_Parent (Parent); - case Get_Kind (Parent) is - when Iir_Kind_For_Loop_Statement - | Iir_Kind_While_Loop_Statement => - if Label = Null_Iir or else Label = Parent then - -- Target is this statement. - if Is_Exit then - Finalize_Loop_Statement (Instance, Parent); - Instance.Stmt := Parent; - Update_Next_Statement (Proc); - elsif not Finish_Loop_Statement (Instance, Parent) then - Update_Next_Statement (Proc); - else - Init_Sequential_Statements (Proc, Parent); - end if; - return; - else - Finalize_Loop_Statement (Instance, Parent); - end if; - when others => - null; - end case; - end loop; - end Execute_Exit_Next_Statement; - - procedure Execute_Case_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Value: Iir_Value_Literal_Acc; - Assoc: Iir; - Stmt_Chain : Iir; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - - Value := Execute_Expression (Instance, Get_Expression (Stmt)); - Assoc := Get_Case_Statement_Alternative_Chain (Stmt); - - while Assoc /= Null_Iir loop - if not Get_Same_Alternative_Flag (Assoc) then - Stmt_Chain := Get_Associated_Chain (Assoc); - end if; - - if Is_In_Choice (Instance, Assoc, Value) then - if Stmt_Chain = Null_Iir then - Update_Next_Statement (Proc); - else - Instance.Stmt := Stmt_Chain; - end if; - Release (Marker, Expr_Pool); - return; - end if; - - Assoc := Get_Chain (Assoc); - end loop; - -- FIXME: infinite loop??? - Error_Msg_Exec ("no choice for expression", Stmt); - raise Internal_Error; - end Execute_Case_Statement; - - procedure Execute_Call_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Call : constant Iir := Get_Procedure_Call (Stmt); - Imp : constant Iir := Get_Implementation (Call); - Subprg_Instance : Block_Instance_Acc; - Prot_Block : Block_Instance_Acc; - Assoc_Chain: Iir; - Inter_Chain : Iir; - Subprg_Body : Iir; - begin - if Get_Implicit_Definition (Imp) in Iir_Predefined_Implicit then - Execute_Implicit_Procedure (Instance, Call); - Update_Next_Statement (Proc); - elsif Get_Foreign_Flag (Imp) then - Execute_Foreign_Procedure (Instance, Call); - Update_Next_Statement (Proc); - else - Mark (Instance.Marker, Instance_Pool.all); - Prot_Block := Get_Protected_Object_Instance (Instance, Call); - Subprg_Instance := - Create_Subprogram_Instance (Instance, Prot_Block, Imp); - Assoc_Chain := Get_Parameter_Association_Chain (Call); - Inter_Chain := Get_Interface_Declaration_Chain (Imp); - Execute_Association - (Instance, Subprg_Instance, Inter_Chain, Assoc_Chain); - - Current_Process.Instance := Subprg_Instance; - Subprg_Body := Get_Subprogram_Body (Imp); - Elaborate_Declarative_Part - (Subprg_Instance, Get_Declaration_Chain (Subprg_Body)); - - Init_Sequential_Statements (Proc, Subprg_Body); - end if; - end Execute_Call_Statement; - - procedure Finish_Procedure_Frame (Proc : Process_State_Acc) - is - Old_Instance : constant Block_Instance_Acc := Proc.Instance; - begin - Execute_Back_Association (Old_Instance); - Proc.Instance := Old_Instance.Parent; - Execute_Subprogram_Call_Final (Old_Instance); - Release (Proc.Instance.Marker, Instance_Pool.all); - end Finish_Procedure_Frame; - - procedure Execute_If_Statement - (Proc : Process_State_Acc; Stmt: Iir_Wait_Statement) - is - Clause: Iir; - Cond: Boolean; - begin - Clause := Stmt; - loop - Cond := Execute_Condition (Proc.Instance, Get_Condition (Clause)); - if Cond then - Init_Sequential_Statements (Proc, Clause); - return; - end if; - Clause := Get_Else_Clause (Clause); - exit when Clause = Null_Iir; - end loop; - Update_Next_Statement (Proc); - end Execute_If_Statement; - - procedure Execute_Variable_Assignment - (Proc : Process_State_Acc; Stmt : Iir) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Target : constant Iir := Get_Target (Stmt); - Target_Type : constant Iir := Get_Type (Target); - Expr : constant Iir := Get_Expression (Stmt); - Expr_Type : constant Iir := Get_Type (Expr); - Target_Val: Iir_Value_Literal_Acc; - Res : Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - Target_Val := Execute_Expression (Instance, Target); - - -- If the type of the target is not static and the value is - -- an aggregate, then the aggregate may be contrained by the - -- target. - if Get_Kind (Expr) = Iir_Kind_Aggregate - and then Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition - then - Res := Copy_Array_Bound (Target_Val); - Fill_Array_Aggregate (Instance, Expr, Res); - else - Res := Execute_Expression (Instance, Expr); - end if; - if Get_Kind (Target_Type) in Iir_Kinds_Array_Type_Definition then - -- Note: target_type may be dynamic (slice case), so - -- check_constraints is not called. - Implicit_Array_Conversion (Res, Target_Val, Stmt); - else - Check_Constraints (Instance, Res, Target_Type, Stmt); - end if; - - -- Note: we need to unshare before copying to avoid - -- overwrites (in assignments like: v (1 to 4) := v (3 to 6)). - -- FIXME: improve that handling (detect overlaps before). - Store (Target_Val, Unshare (Res, Expr_Pool'Access)); - - Release (Marker, Expr_Pool); - end Execute_Variable_Assignment; - - function Execute_Return_Statement (Proc : Process_State_Acc) - return Boolean - is - Res : Iir_Value_Literal_Acc; - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Expr : constant Iir := Get_Expression (Stmt); - begin - if Expr /= Null_Iir then - Res := Execute_Expression (Instance, Expr); - Implicit_Array_Conversion (Instance, Res, Get_Type (Stmt), Stmt); - Check_Constraints (Instance, Res, Get_Type (Stmt), Stmt); - Instance.Result := Res; - end if; - - case Get_Kind (Instance.Label) is - when Iir_Kind_Procedure_Declaration => - Finish_Procedure_Frame (Proc); - Update_Next_Statement (Proc); - return False; - when Iir_Kind_Function_Declaration => - return True; - when others => - raise Internal_Error; - end case; - end Execute_Return_Statement; - - procedure Finish_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir) - is - Instance : Block_Instance_Acc := Proc.Instance; - Stmt : Iir; - begin - Stmt := Complex_Stmt; - loop - Instance.Stmt := Stmt; - case Get_Kind (Stmt) is - when Iir_Kind_For_Loop_Statement => - if Finish_For_Loop_Statement (Instance) then - return; - end if; - when Iir_Kind_While_Loop_Statement => - if Finish_While_Loop_Statement (Instance) then - return; - end if; - when Iir_Kind_Case_Statement - | Iir_Kind_If_Statement => - null; - when Iir_Kind_Sensitized_Process_Statement => - Instance.Stmt := Null_Iir; - return; - when Iir_Kind_Process_Statement => - -- Start again. - Instance.Stmt := Get_Sequential_Statement_Chain (Stmt); - return; - when Iir_Kind_Procedure_Body => - Finish_Procedure_Frame (Proc); - Instance := Proc.Instance; - when Iir_Kind_Function_Body => - Error_Msg_Exec ("missing return statement in function", Stmt); - when others => - Error_Kind ("execute_next_statement", Stmt); - end case; - Stmt := Get_Chain (Instance.Stmt); - if Stmt /= Null_Iir then - Instance.Stmt := Stmt; - return; - end if; - Stmt := Get_Parent (Instance.Stmt); - end loop; - end Finish_Sequential_Statements; - - procedure Init_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir) - is - Stmt : Iir; - begin - Stmt := Get_Sequential_Statement_Chain (Complex_Stmt); - if Stmt /= Null_Iir then - Proc.Instance.Stmt := Stmt; - else - Finish_Sequential_Statements (Proc, Complex_Stmt); - end if; - end Init_Sequential_Statements; - - procedure Update_Next_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : Iir; - begin - Stmt := Get_Chain (Instance.Stmt); - if Stmt /= Null_Iir then - Instance.Stmt := Stmt; - return; - end if; - Finish_Sequential_Statements (Proc, Get_Parent (Instance.Stmt)); - end Update_Next_Statement; - - procedure Execute_Sequential_Statements (Proc : Process_State_Acc) - is - Instance : Block_Instance_Acc; - Stmt: Iir; - begin - loop - Instance := Proc.Instance; - Stmt := Instance.Stmt; - - -- End of process or subprogram. - exit when Stmt = Null_Iir; - - if Trace_Statements then - declare - Name : Name_Id; - Line : Natural; - Col : Natural; - begin - Files_Map.Location_To_Position - (Get_Location (Stmt), Name, Line, Col); - Put_Line ("Execute statement at " - & Name_Table.Image (Name) - & Natural'Image (Line)); - end; - end if; - - if Flag_Need_Debug then - Debug (Reason_Break); - end if; - - -- execute statement STMT. - case Get_Kind (Stmt) is - when Iir_Kind_Null_Statement => - Update_Next_Statement (Proc); - - when Iir_Kind_If_Statement => - Execute_If_Statement (Proc, Stmt); - - when Iir_Kind_Simple_Signal_Assignment_Statement => - Execute_Signal_Assignment (Instance, Stmt); - Update_Next_Statement (Proc); - - when Iir_Kind_Assertion_Statement => - declare - Res : Boolean; - begin - Res := Execute_Condition - (Instance, Get_Assertion_Condition (Stmt)); - if not Res then - Execute_Failed_Assertion (Instance, "assertion", Stmt, - "Assertion violation.", 2); - end if; - end; - Update_Next_Statement (Proc); - - when Iir_Kind_Report_Statement => - Execute_Failed_Assertion (Instance, "report", Stmt, - "Assertion violation.", 0); - Update_Next_Statement (Proc); - - when Iir_Kind_Variable_Assignment_Statement => - Execute_Variable_Assignment (Proc, Stmt); - Update_Next_Statement (Proc); - - when Iir_Kind_Return_Statement => - if Execute_Return_Statement (Proc) then - return; - end if; - - when Iir_Kind_For_Loop_Statement => - Execute_For_Loop_Statement (Proc); - - when Iir_Kind_While_Loop_Statement => - Execute_While_Loop_Statement (Proc); - - when Iir_Kind_Case_Statement => - Execute_Case_Statement (Proc); - - when Iir_Kind_Wait_Statement => - if Execute_Wait_Statement (Instance, Stmt) then - return; - end if; - Update_Next_Statement (Proc); - - when Iir_Kind_Procedure_Call_Statement => - Execute_Call_Statement (Proc); - - when Iir_Kind_Exit_Statement => - Execute_Exit_Next_Statement (Proc, True); - when Iir_Kind_Next_Statement => - Execute_Exit_Next_Statement (Proc, False); - - when others => - Error_Kind ("execute_sequential_statements", Stmt); - end case; - end loop; - end Execute_Sequential_Statements; -end Execution; diff --git a/src/vhdl/simulate/execution.ads b/src/vhdl/simulate/execution.ads deleted file mode 100644 index d9406be94..000000000 --- a/src/vhdl/simulate/execution.ads +++ /dev/null @@ -1,192 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Types; use Types; -with Iirs; use Iirs; -with Iir_Values; use Iir_Values; -with Elaboration; use Elaboration; -with Areapools; use Areapools; - -package Execution is - Trace_Statements : Boolean := False; - - -- If true, disp current time in assert message. - Disp_Time_Before_Values: Boolean := False; - - Current_Component : Block_Instance_Acc := null; - - -- State associed with each process. - type Process_State_Type is record - -- The process instance. - Top_Instance: Block_Instance_Acc := null; - Proc: Iir := Null_Iir; - - -- Memory pool to allocate objects from. - Pool : aliased Areapool; - - -- The stack of the process. - Instance : Block_Instance_Acc := null; - end record; - type Process_State_Acc is access all Process_State_Type; - - type Process_State_Array is - array (Process_Index_Type range <>) of aliased Process_State_Type; - type Process_State_Array_Acc is access Process_State_Array; - - -- Array containing all processes. - Processes_State: Process_State_Array_Acc; - - Simulation_Finished : exception; - - -- Current process being executed. This is only for the debugger. - Current_Process : Process_State_Acc; - - -- Pseudo process used for resolution functions, ... - No_Process : Process_State_Acc := new Process_State_Type; - -- Execute a list of sequential statements. - -- Return when there is no more statements to execute. - procedure Execute_Sequential_Statements (Proc : Process_State_Acc); - - -- Evaluate an expression. - function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) - return Iir_Value_Literal_Acc; - - -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. - function Execute_Condition (Instance : Block_Instance_Acc; - Cond : Iir) return Boolean; - - -- Execute a name. Return the value if Ref is False, or the reference - -- (for a signal, a quantity or a terminal) if Ref is True. - function Execute_Name (Block: Block_Instance_Acc; - Expr: Iir; - Ref : Boolean := False) - return Iir_Value_Literal_Acc; - - 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); - - -- Return the initial value (default value) of signal name EXPR. To be - -- used only during (non-dynamic) elaboration. - function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) - return Iir_Value_Literal_Acc; - - function Execute_Expression_With_Type - (Block: Block_Instance_Acc; - Expr: Iir; - Expr_Type : Iir) - return Iir_Value_Literal_Acc; - - procedure Execute_Failed_Assertion - (Instance: Block_Instance_Acc; - Label : String; - Stmt : Iir; - Default_Msg : String; - Default_Severity : Natural); - - function Execute_Resolution_Function - (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - function Execute_Assoc_Conversion - (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - -- Sub function common for left/right/length/low/high attributes. - -- Return bounds of PREFIX. - function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) - return Iir_Value_Literal_Acc; - - -- 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; - - function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - function Get_Instance_By_Scope - (Instance: Block_Instance_Acc; Scope: Scope_Type) - return Block_Instance_Acc; - - function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) - return Block_Instance_Acc; - - -- Check VALUE follows the constraints of DEF. - -- INSTANCE,DEF is the definition of a subtype. - -- EXPR is just used in case of error to display the location - -- If there is no location, EXPR can be null. - -- Implicitly convert VALUE (array cases). - -- Return in case of success. - -- Raise errorout.execution_constraint_error in case of failure. - procedure Check_Constraints - (Instance: Block_Instance_Acc; - Value: Iir_Value_Literal_Acc; - Def: Iir; Expr: Iir); - - -- If VALUE is not an array, then this is a no-op. - -- If VALUE is an array, then bounds are checked and converted. INSTANCE - -- is the instance corresponding to REF_TYPE. - -- EXPR is used in case of error. - procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; - Ref_Value : Iir_Value_Literal_Acc; - Expr : Iir); - procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; - Value : in out Iir_Value_Literal_Acc; - Ref_Type : Iir; - Expr : Iir); - - -- 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; - - -- Create a range from LEN for scalar type ATYPE. - function Create_Bounds_From_Length (Block : Block_Instance_Acc; - Atype : Iir; - Len : Iir_Index32) - return Iir_Value_Literal_Acc; - - -- 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; - - -- Increment or decrement VAL according to BOUNDS.DIR. - procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; - Bounds : Iir_Value_Literal_Acc); - - -- Create a block instance for subprogram IMP. - function Create_Subprogram_Instance (Instance : Block_Instance_Acc; - Prot_Obj : Block_Instance_Acc; - Imp : Iir) - return Block_Instance_Acc; - - function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; - Expr_Type : Iir) - return String; -end Execution; diff --git a/src/vhdl/simulate/file_operation.adb b/src/vhdl/simulate/file_operation.adb deleted file mode 100644 index dab6ec889..000000000 --- a/src/vhdl/simulate/file_operation.adb +++ /dev/null @@ -1,384 +0,0 @@ --- File operations for interpreter --- 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 Types; use Types; -with Annotations; use Annotations; -with Execution; use Execution; -with Debugger; use Debugger; -with Grt_Interface; use Grt_Interface; -with Grt.Lib; - -package body File_Operation is - -- Open a file. - -- See LRM93 3.4.1 for definition of arguments. - -- IS_TEXT is true if the file format is text. - -- The purpose of the IS_TEXT is to allow a text implementation of file - -- type TEXT, defined in std.textio. - procedure File_Open (Status : out Ghdl_I32; - File : Iir_Value_Literal_Acc; - External_Name : Iir_Value_Literal_Acc; - Mode : Ghdl_I32; - Is_Text : Boolean; - Return_Status : Boolean) - is - Name_Len : constant Ghdl_Index_Type := - Ghdl_Index_Type (External_Name.Bounds.D (1).Length); - Name_Str : aliased Std_String_Uncons (1 .. Name_Len); - Name_Bnd : aliased Std_String_Bound := Build_Bound (External_Name); - Name : aliased Std_String := (To_Std_String_Basep (Name_Str'Address), - To_Std_String_Boundp (Name_Bnd'Address)); - begin - -- Convert the string to an Ada string. - for I in External_Name.Val_Array.V'Range loop - Name_Str (Name_Str'First + Ghdl_Index_Type (I - 1)) := - Character'Val (External_Name.Val_Array.V (I).E8); - end loop; - - if Is_Text then - if Return_Status then - Status := Ghdl_Text_File_Open_Status - (File.File, Mode, Name'Unrestricted_Access); - else - Ghdl_Text_File_Open (File.File, Mode, Name'Unrestricted_Access); - Status := Open_Ok; - end if; - else - if Return_Status then - Status := Ghdl_File_Open_Status - (File.File, Mode, Name'Unrestricted_Access); - else - Ghdl_File_Open (File.File, Mode, Name'Unrestricted_Access); - Status := Open_Ok; - end if; - end if; - end File_Open; - - -- Open a file. - procedure File_Open (File : Iir_Value_Literal_Acc; - Name : Iir_Value_Literal_Acc; - Mode : Iir_Value_Literal_Acc; - File_Decl : Iir; - Stmt : Iir) - is - pragma Unreferenced (Stmt); - Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); - File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E8); - Status : Ghdl_I32; - begin - File_Open (Status, File, Name, File_Mode, Is_Text, False); - if Status /= Open_Ok then - raise Program_Error; - end if; - end File_Open; - - procedure File_Open_Status (Status : Iir_Value_Literal_Acc; - File : Iir_Value_Literal_Acc; - Name : Iir_Value_Literal_Acc; - Mode : Iir_Value_Literal_Acc; - File_Decl : Iir; - Stmt : Iir) - is - pragma Unreferenced (Stmt); - Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); - File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E8); - R_Status : Ghdl_I32; - begin - File_Open (R_Status, File, Name, File_Mode, Is_Text, True); - Status.E8 := Ghdl_E8 (R_Status); - end File_Open_Status; - - function Elaborate_File_Declaration - (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration) - return Iir_Value_Literal_Acc - is - Def : constant Iir := Get_Type (Decl); - External_Name : Iir; - File_Name: Iir_Value_Literal_Acc; - Is_Text : constant Boolean := Get_Text_File_Flag (Def); - File_Mode : Ghdl_I32; - Res : Iir_Value_Literal_Acc; - Status : Ghdl_I32; - Mode : Iir_Value_Literal_Acc; - begin - if Is_Text then - Res := Create_File_Value (Ghdl_Text_File_Elaborate); - else - declare - Sig : constant String_Acc := Get_Info (Def).File_Signature; - Cstr : Ghdl_C_String; - begin - if Sig = null then - Cstr := null; - else - Cstr := To_Ghdl_C_String (Sig.all'Address); - end if; - Res := Create_File_Value (Ghdl_File_Elaborate (Cstr)); - end; - end if; - - External_Name := Get_File_Logical_Name (Decl); - - -- LRM93 4.3.1.4 - -- If file open information is not included in a given file declaration, - -- then the file declared by the declaration is not opened when the file - -- declaration is elaborated. - if External_Name = Null_Iir then - return Res; - end if; - - File_Name := Execute_Expression (Instance, External_Name); - if Get_File_Open_Kind (Decl) /= Null_Iir then - Mode := Execute_Expression (Instance, Get_File_Open_Kind (Decl)); - File_Mode := Ghdl_I32 (Mode.E8); - else - case Get_Mode (Decl) is - when Iir_In_Mode => - File_Mode := Read_Mode; - when Iir_Out_Mode => - File_Mode := Write_Mode; - when others => - raise Internal_Error; - end case; - end if; - File_Open (Status, Res, File_Name, File_Mode, Is_Text, False); - return Res; - end Elaborate_File_Declaration; - - procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir) is - pragma Unreferenced (Stmt); - begin - Ghdl_Text_File_Close (File.File); - end File_Close_Text; - - procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir) is - pragma Unreferenced (Stmt); - begin - Ghdl_File_Close (File.File); - end File_Close_Binary; - - procedure File_Destroy_Text (File : Iir_Value_Literal_Acc) is - begin - Ghdl_Text_File_Finalize (File.File); - end File_Destroy_Text; - - procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc) is - begin - Ghdl_File_Finalize (File.File); - end File_Destroy_Binary; - - - procedure Write_Binary (File: Iir_Value_Literal_Acc; - Value: Iir_Value_Literal_Acc) is - begin - case Value.Kind is - when Iir_Value_B1 => - Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); - when Iir_Value_I64 => - Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); - when Iir_Value_E8 => - Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.E8'Address), 1); - when Iir_Value_E32 => - Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); - when Iir_Value_F64 => - Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); - when Iir_Value_Array => - for I in Value.Bounds.D'Range loop - Ghdl_Write_Scalar - (File.File, Ghdl_Ptr (Value.Bounds.D (I).Length'Address), 4); - end loop; - for I in Value.Val_Array.V'Range loop - Write_Binary (File, Value.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - for I in Value.Val_Record.V'Range loop - Write_Binary (File, Value.Val_Record.V (I)); - end loop; - when others => - raise Internal_Error; - end case; - end Write_Binary; - - procedure Write_Text (File: Iir_Value_Literal_Acc; - Value: Iir_Value_Literal_Acc) - is - Val_Len : constant Ghdl_Index_Type := - Ghdl_Index_Type (Value.Bounds.D (1).Length); - Val_Str : aliased Std_String_Uncons (1 .. Val_Len); - Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); - Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), - To_Std_String_Boundp (Val_Bnd'Address)); - begin - -- Convert the string to an Ada string. - for I in Value.Val_Array.V'Range loop - Val_Str (Val_Str'First + Ghdl_Index_Type (I - 1)) := - Character'Val (Value.Val_Array.V (I).E8); - end loop; - - Ghdl_Text_Write (File.File, Val'Unrestricted_Access); - end Write_Text; - - function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) - return Boolean - is - pragma Unreferenced (Stmt); - begin - return Grt.Files.Ghdl_File_Endfile (File.File); - end Endfile; - - procedure Read_Length_Text (File : Iir_Value_Literal_Acc; - Value : Iir_Value_Literal_Acc; - Length : Iir_Value_Literal_Acc) - is - Val_Len : constant Ghdl_Index_Type := - Ghdl_Index_Type (Value.Bounds.D (1).Length); - Val_Str : aliased Std_String_Uncons (1 .. Val_Len); - Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); - Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), - To_Std_String_Boundp (Val_Bnd'Address)); - Len : Std_Integer; - begin - Len := Ghdl_Text_Read_Length (File.File, Val'Unrestricted_Access); - for I in 1 .. Len loop - Value.Val_Array.V (Iir_Index32 (I)).E8 := - Character'Pos (Val_Str (Ghdl_Index_Type (I))); - end loop; - Length.I64 := Ghdl_I64 (Len); - end Read_Length_Text; - - procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc; - Str : Iir_Value_Literal_Acc; - Length : Iir_Value_Literal_Acc) - is - Len : Std_Integer; - Val_Len : constant Ghdl_Index_Type := - Ghdl_Index_Type (Str.Bounds.D (1).Length); - Val_Str : aliased Std_String_Uncons (1 .. Val_Len); - Val_Bnd : aliased Std_String_Bound := Build_Bound (Str); - Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), - To_Std_String_Boundp (Val_Bnd'Address)); - begin - Ghdl_Untruncated_Text_Read - (File.File, Val'Unrestricted_Access, Len'Unrestricted_Access); - for I in 1 .. Len loop - Str.Val_Array.V (Iir_Index32 (I)).E8 := - Character'Pos (Val_Str (Ghdl_Index_Type (I))); - end loop; - Length.I64 := Ghdl_I64 (Len); - end Untruncated_Text_Read; - - procedure Read_Binary (File: Iir_Value_Literal_Acc; - Value: Iir_Value_Literal_Acc) - is - begin - case Value.Kind is - when Iir_Value_B1 => - Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); - when Iir_Value_I64 => - Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); - when Iir_Value_E8 => - Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E8'Address), 1); - when Iir_Value_E32 => - Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); - when Iir_Value_F64 => - Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); - when Iir_Value_Array => - for I in Value.Bounds.D'Range loop - declare - Len : Iir_Index32; - begin - Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); - if Len /= Value.Bounds.D (I).Length then - Error_Msg_Constraint (Null_Iir); -- FIXME: loc - end if; - end; - end loop; - for I in Value.Val_Array.V'Range loop - Read_Binary (File, Value.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - for I in Value.Val_Record.V'Range loop - Read_Binary (File, Value.Val_Record.V (I)); - end loop; - when others => - raise Internal_Error; - end case; - end Read_Binary; - - procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; - Value : Iir_Value_Literal_Acc; - Length : Iir_Value_Literal_Acc) - is - Len : Iir_Index32; - begin - Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); - for I in 1 .. Len loop - if I <= Value.Bounds.D (1).Length then - Read_Binary (File, Value.Val_Array.V (I)); - else - -- FIXME: for empty arrays ?? - -- Lose_Binary (File, Value.Val_Array (0)); - raise Internal_Error; - end if; - end loop; - Length.I64 := Ghdl_I64 (Len); - end Read_Length_Binary; - - procedure Flush (File : Iir_Value_Literal_Acc) is - begin - Ghdl_File_Flush (File.File); - end Flush; - - procedure Textio_Write_Real (Str : Iir_Value_Literal_Acc; - Len : Iir_Value_Literal_Acc; - Val : Ghdl_F64; - Ndigits : Std_Integer) - is - Len_Arg : aliased Std_Integer; - Str_Len : constant Ghdl_Index_Type := - Ghdl_Index_Type (Str.Bounds.D (1).Length); - Str_Str : aliased Std_String_Uncons (1 .. Str_Len); - Str_Bnd : aliased Std_String_Bound := Build_Bound (Str); - Str_Arg : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), - To_Std_String_Boundp (Str_Bnd'Address)); - begin - Grt.Lib.Textio_Write_Real - (Str_Arg'Unrestricted_Access, Len_Arg'Unrestricted_Access, - Val, Ndigits); - for I in 1 .. Len_Arg loop - Str.Val_Array.V (Iir_Index32 (I)).E8 := - Character'Pos (Str_Str (Ghdl_Index_Type (I))); - end loop; - Len.I64 := Ghdl_I64 (Len_Arg); - end Textio_Write_Real; - - function Textio_Read_Real (Str : Iir_Value_Literal_Acc) return Ghdl_F64 - is - Str_Len : constant Ghdl_Index_Type := - Ghdl_Index_Type (Str.Bounds.D (1).Length); - Str_Str : aliased Std_String_Uncons (1 .. Str_Len); - Str_Bnd : aliased Std_String_Bound := Build_Bound (Str); - Str_Arg : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), - To_Std_String_Boundp (Str_Bnd'Address)); - begin - for I in Str.Val_Array.V'Range loop - Str_Str (Ghdl_Index_Type (I)) := - Character'Val (Str.Val_Array.V (I).E8); - end loop; - return Grt.Lib.Textio_Read_Real (Str_Arg'Unrestricted_Access); - end Textio_Read_Real; -end File_Operation; diff --git a/src/vhdl/simulate/file_operation.ads b/src/vhdl/simulate/file_operation.ads deleted file mode 100644 index ef3b8b22b..000000000 --- a/src/vhdl/simulate/file_operation.ads +++ /dev/null @@ -1,89 +0,0 @@ --- File operations for interpreter --- 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 Iirs; use Iirs; -with Iir_Values; use Iir_Values; -with Grt.Files; use Grt.Files; -with Grt.Types; use Grt.Types; - -package File_Operation is - Null_File : constant Natural := 0; - - -- Open a file. - procedure File_Open (File : Iir_Value_Literal_Acc; - Name : Iir_Value_Literal_Acc; - Mode : Iir_Value_Literal_Acc; - File_Decl : Iir; - Stmt : Iir); - - procedure File_Open_Status (Status : Iir_Value_Literal_Acc; - File : Iir_Value_Literal_Acc; - Name : Iir_Value_Literal_Acc; - Mode : Iir_Value_Literal_Acc; - File_Decl : Iir; - Stmt : Iir); - - -- Close a file. - -- If the file was not open, this has no effects. - procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir); - procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir); - - procedure File_Destroy_Text (File : Iir_Value_Literal_Acc); - procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc); - - -- Elaborate a file_declaration. - function Elaborate_File_Declaration - (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration) - return Iir_Value_Literal_Acc; - - -- Write VALUE to FILE. - -- STMT is the statement, to display error. - procedure Write_Text (File: Iir_Value_Literal_Acc; - Value: Iir_Value_Literal_Acc); - procedure Write_Binary (File: Iir_Value_Literal_Acc; - Value: Iir_Value_Literal_Acc); - - procedure Read_Binary (File: Iir_Value_Literal_Acc; - Value: Iir_Value_Literal_Acc); - - procedure Read_Length_Text (File : Iir_Value_Literal_Acc; - Value : Iir_Value_Literal_Acc; - Length : Iir_Value_Literal_Acc); - - procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; - Value : Iir_Value_Literal_Acc; - Length : Iir_Value_Literal_Acc); - - procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc; - Str : Iir_Value_Literal_Acc; - Length : Iir_Value_Literal_Acc); - - procedure Flush (File : Iir_Value_Literal_Acc); - - -- Test end of FILE is reached. - function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) - return Boolean; - - -- Fp to string - procedure Textio_Write_Real (Str : Iir_Value_Literal_Acc; - Len : Iir_Value_Literal_Acc; - Val : Ghdl_F64; - Ndigits : Std_Integer); - - function Textio_Read_Real (Str : Iir_Value_Literal_Acc) return Ghdl_F64; -end File_Operation; diff --git a/src/vhdl/simulate/grt_interface.adb b/src/vhdl/simulate/grt_interface.adb deleted file mode 100644 index 604d30d01..000000000 --- a/src/vhdl/simulate/grt_interface.adb +++ /dev/null @@ -1,44 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Iirs; use Iirs; -with Types; use Types; - -package body Grt_Interface is - To_Dir : constant array (Iir_Direction) of Ghdl_Dir_Type := - (Iir_To => Dir_To, Iir_Downto => Dir_Downto); - - function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound - is - Rng : constant Iir_Value_Literal_Acc := Arr.Bounds.D (1); - begin - return (Dim_1 => (Left => Std_Integer (Rng.Left.I64), - Right => Std_Integer (Rng.Right.I64), - Dir => To_Dir (Rng.Dir), - Length => Ghdl_Index_Type (Rng.Length))); - end Build_Bound; - - procedure Set_Std_String_From_Iir_Value (Str : Std_String; - Val : Iir_Value_Literal_Acc) is - begin - for I in Val.Val_Array.V'Range loop - Str.Base (Ghdl_Index_Type (I - 1)) := - Character'Val (Val.Val_Array.V (I).E8); - end loop; - end Set_Std_String_From_Iir_Value; -end Grt_Interface; diff --git a/src/vhdl/simulate/grt_interface.ads b/src/vhdl/simulate/grt_interface.ads deleted file mode 100644 index 05f7abb69..000000000 --- a/src/vhdl/simulate/grt_interface.ads +++ /dev/null @@ -1,27 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Grt.Types; use Grt.Types; -with Iir_Values; use Iir_Values; - -package Grt_Interface is - procedure Set_Std_String_From_Iir_Value (Str : Std_String; - Val : Iir_Value_Literal_Acc); - - function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound; -end Grt_Interface; diff --git a/src/vhdl/simulate/iir_values.adb b/src/vhdl/simulate/iir_values.adb deleted file mode 100644 index 62b70f9c2..000000000 --- a/src/vhdl/simulate/iir_values.adb +++ /dev/null @@ -1,1127 +0,0 @@ --- Naive values for 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 System; -with Ada.Unchecked_Conversion; -with GNAT.Debug_Utilities; -with Name_Table; -with Debugger; use Debugger; - -package body Iir_Values is - - -- Functions for iir_value_literal - function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean is - begin - if Left.Kind /= Right.Kind then - raise Internal_Error; - end if; - case Left.Kind is - when Iir_Value_B1 => - return Left.B1 = Right.B1; - when Iir_Value_E8 => - return Left.E8 = Right.E8; - when Iir_Value_E32 => - return Left.E32 = Right.E32; - when Iir_Value_I64 => - return Left.I64 = Right.I64; - when Iir_Value_F64 => - return Left.F64 = Right.F64; - when Iir_Value_Access => - return Left.Val_Access = Right.Val_Access; - when Iir_Value_File => - raise Internal_Error; - when Iir_Value_Array => - if Left.Bounds.Nbr_Dims /= Right.Bounds.Nbr_Dims then - raise Internal_Error; - end if; - for I in Left.Bounds.D'Range loop - if Left.Bounds.D (I).Length /= Right.Bounds.D (I).Length then - return False; - end if; - end loop; - for I in Left.Val_Array.V'Range loop - if not Is_Equal (Left.Val_Array.V (I), - Right.Val_Array.V (I)) then - return False; - end if; - end loop; - return True; - when Iir_Value_Record => - if Left.Val_Record.Len /= Right.Val_Record.Len then - raise Constraint_Error; - end if; - for I in Left.Val_Record.V'Range loop - if not Is_Equal (Left.Val_Record.V (I), - Right.Val_Record.V (I)) then - return False; - end if; - end loop; - return True; - when Iir_Value_Range => - if Left.Dir /= Right.Dir then - return False; - end if; - if not Is_Equal (Left.Left, Right.Left) then - return False; - end if; - if not Is_Equal (Left.Right, Right.Right) then - return False; - end if; - return True; - when Iir_Value_Signal - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Is_Equal; - - function Compare_Value (Left, Right : Iir_Value_Literal_Acc) - return Order is - begin - if Left.Kind /= Right.Kind then - raise Constraint_Error; - end if; - case Left.Kind is - when Iir_Value_B1 => - if Left.B1 < Right.B1 then - return Less; - elsif Left.B1 = Right.B1 then - return Equal; - else - return Greater; - end if; - when Iir_Value_E8 => - if Left.E8 < Right.E8 then - return Less; - elsif Left.E8 = Right.E8 then - return Equal; - else - return Greater; - end if; - when Iir_Value_E32 => - if Left.E32 < Right.E32 then - return Less; - elsif Left.E32 = Right.E32 then - return Equal; - else - return Greater; - end if; - when Iir_Value_I64 => - if Left.I64 < Right.I64 then - return Less; - elsif Left.I64 = Right.I64 then - return Equal; - else - return Greater; - end if; - when Iir_Value_F64 => - if Left.F64 < Right.F64 then - return Less; - elsif Left.F64 = Right.F64 then - return Equal; - elsif Left.F64 > Right.F64 then - return Greater; - else - raise Constraint_Error; - end if; - when Iir_Value_Array => - -- LRM93 §7.2.2 - -- For discrete array types, the relation < (less than) is defined - -- such as the left operand is less than the right operand if - -- and only if: - -- * the left operand is a null array and the right operand is - -- a non-null array; otherwise - -- * both operands are non-null arrays, and one of the following - -- conditions is satisfied: - -- - the leftmost element of the left operand is less than - -- that of the right; or - -- - the leftmost element of the left operand is equal to - -- that of the right, and the tail of the left operand is - -- less than that of the right (the tail consists of the - -- remaining elements to the rights of the leftmost element - -- and can be null) - -- The relation <= (less than or equal) for discrete array types - -- is defined to be the inclusive disjunction of the results of - -- the < and = operators for the same two operands. - -- The relation > (greater than) and >= (greater than of equal) - -- are defined to be the complements of the <= and < operators - -- respectively for the same two operands. - if Left.Bounds.Nbr_Dims /= 1 or Right.Bounds.Nbr_Dims /= 1 then - raise Internal_Error; - end if; - for I in 1 .. Iir_Index32'Min (Left.Bounds.D (1).Length, - Right.Bounds.D (1).Length) - loop - case Compare_Value (Left.Val_Array.V (I), - Right.Val_Array.V (I)) is - when Less => - return Less; - when Greater => - return Greater; - when Equal => - null; - end case; - end loop; - if Left.Bounds.D (1).Length < Right.Bounds.D (1).Length then - return Less; - elsif Left.Bounds.D (1).Length = Right.Bounds.D (1).Length then - return Equal; - else - return Greater; - end if; - when Iir_Value_Signal - | Iir_Value_Access - | Iir_Value_Range - | Iir_Value_Record - | Iir_Value_File - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Compare_Value; - - function Is_Null_Range (Arange : Iir_Value_Literal_Acc) return Boolean - is - Cmp : Order; - begin - Cmp := Compare_Value (Arange.Left, Arange.Right); - case Arange.Dir is - when Iir_To => - return Cmp = Greater; - when Iir_Downto => - return Cmp = Less; - end case; - end Is_Null_Range; - - procedure Increment (Val : Iir_Value_Literal_Acc) is - begin - case Val.Kind is - when Iir_Value_B1 => - if Val.B1 = False then - Val.B1 := True; - else - raise Constraint_Error; - end if; - when Iir_Value_E8 => - Val.E8 := Val.E8 + 1; - when Iir_Value_E32 => - Val.E32 := Val.E32 + 1; - when Iir_Value_I64 => - Val.I64 := Val.I64 + 1; - when Iir_Value_F64 - | Iir_Value_Array - | Iir_Value_Record - | Iir_Value_Range - | Iir_Value_File - | Iir_Value_Access - | Iir_Value_Signal - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Increment; - - procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc) - is - begin - if Dest.Kind /= Src.Kind then - raise Constraint_Error; - end if; - case Dest.Kind is - when Iir_Value_Array => - if Dest.Val_Array.Len /= Src.Val_Array.Len then - raise Constraint_Error; - end if; - for I in Dest.Val_Array.V'Range loop - Store (Dest.Val_Array.V (I), Src.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - if Dest.Val_Record.Len /= Src.Val_Record.Len then - raise Constraint_Error; - end if; - for I in Dest.Val_Record.V'Range loop - Store (Dest.Val_Record.V (I), Src.Val_Record.V (I)); - end loop; - when Iir_Value_B1 => - Dest.B1 := Src.B1; - when Iir_Value_E8 => - Dest.E8 := Src.E8; - when Iir_Value_E32 => - Dest.E32 := Src.E32; - when Iir_Value_I64 => - Dest.I64 := Src.I64; - when Iir_Value_F64 => - Dest.F64 := Src.F64; - when Iir_Value_Access => - Dest.Val_Access := Src.Val_Access; - when Iir_Value_File => - Dest.File := Src.File; - when Iir_Value_Protected => - Dest.Prot := Src.Prot; - when Iir_Value_Signal => - pragma Assert (Dest.Sig = null); - Dest.Sig := Src.Sig; - when Iir_Value_Range - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Store; - - procedure Check_Bounds (Dest : Iir_Value_Literal_Acc; - Src : Iir_Value_Literal_Acc; - Loc : Iir) - is - begin - case Dest.Kind is - when Iir_Value_Array => - if Src.Kind /= Iir_Value_Array then - raise Internal_Error; - end if; - if Dest.Val_Array.Len /= Src.Val_Array.Len then - Error_Msg_Constraint (Loc); - end if; - if Dest.Val_Array.Len /= 0 then - Check_Bounds (Dest.Val_Array.V (1), Src.Val_Array.V (1), Loc); - end if; - when Iir_Value_Record => - if Src.Kind /= Iir_Value_Record then - raise Internal_Error; - end if; - if Dest.Val_Record.Len /= Src.Val_Record.Len then - raise Internal_Error; - end if; - for I in Dest.Val_Record.V'Range loop - Check_Bounds (Dest.Val_Record.V (I), Src.Val_Record.V (I), Loc); - end loop; - when Iir_Value_Access - | Iir_Value_File => - if Src.Kind /= Dest.Kind then - raise Internal_Error; - end if; - when Iir_Value_Scalars - | Iir_Value_Signal => - return; - when Iir_Value_Range - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Check_Bounds; - - function To_Iir_Value_Literal_Acc is new Ada.Unchecked_Conversion - (System.Address, Iir_Value_Literal_Acc); - function To_Value_Array_Acc is new Ada.Unchecked_Conversion - (System.Address, Value_Array_Acc); - function To_Value_Bounds_Array_Acc is new Ada.Unchecked_Conversion - (System.Address, Value_Bounds_Array_Acc); - - Last_Sig_Id : Signal_Index_Type := 0; - - function Get_Last_Signal_Index return Signal_Index_Type is - begin - return Last_Sig_Id; - end Get_Last_Signal_Index; - - function Create_Signal_Value (Sig : Ghdl_Signal_Ptr) - return Iir_Value_Literal_Acc - is - subtype Signal_Value is Iir_Value_Literal (Iir_Value_Signal); - function Alloc is new Alloc_On_Pool_Addr (Signal_Value); - begin - Last_Sig_Id := Last_Sig_Id + 1; - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Signal, - Sig => Sig, Sig_Id => Last_Sig_Id))); - end Create_Signal_Value; - - function Create_Terminal_Value (Terminal : Terminal_Index_Type) - return Iir_Value_Literal_Acc - is - subtype Terminal_Value is Iir_Value_Literal (Iir_Value_Terminal); - function Alloc is new Alloc_On_Pool_Addr (Terminal_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Terminal, Terminal => Terminal))); - end Create_Terminal_Value; - - function Create_Quantity_Value (Quantity : Quantity_Index_Type) - return Iir_Value_Literal_Acc - is - subtype Quantity_Value is Iir_Value_Literal (Iir_Value_Quantity); - function Alloc is new Alloc_On_Pool_Addr (Quantity_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Quantity, Quantity => Quantity))); - end Create_Quantity_Value; - - function Create_Environment_Value (Env : Environment_Index_Type) - return Iir_Value_Literal_Acc - is - subtype Environment_Value is Iir_Value_Literal (Iir_Value_Environment); - function Alloc is new Alloc_On_Pool_Addr (Environment_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Environment, Environment => Env))); - end Create_Environment_Value; - - function Create_Protected_Value (Prot : Protected_Index_Type) - return Iir_Value_Literal_Acc - is - subtype Protected_Value is Iir_Value_Literal (Iir_Value_Protected); - function Alloc is new Alloc_On_Pool_Addr (Protected_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Protected, Prot => Prot))); - end Create_Protected_Value; - - function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc - is - subtype B1_Value is Iir_Value_Literal (Iir_Value_B1); - function Alloc is new Alloc_On_Pool_Addr (B1_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_B1, B1 => Val))); - end Create_B1_Value; - - function Create_E8_Value (Val : Ghdl_E8) return Iir_Value_Literal_Acc - is - subtype E8_Value is Iir_Value_Literal (Iir_Value_E8); - function Alloc is new Alloc_On_Pool_Addr (E8_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_E8, E8 => Val))); - end Create_E8_Value; - - function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc - is - subtype E32_Value is Iir_Value_Literal (Iir_Value_E32); - function Alloc is new Alloc_On_Pool_Addr (E32_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_E32, E32 => Val))); - end Create_E32_Value; - - function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc - is - subtype I64_Value is Iir_Value_Literal (Iir_Value_I64); - function Alloc is new Alloc_On_Pool_Addr (I64_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_I64, I64 => Val))); - end Create_I64_Value; - - function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc - is - subtype F64_Value is Iir_Value_Literal (Iir_Value_F64); - function Alloc is new Alloc_On_Pool_Addr (F64_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_F64, F64 => Val))); - end Create_F64_Value; - - function Create_Access_Value (Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - subtype Access_Value is Iir_Value_Literal (Iir_Value_Access); - function Alloc is new Alloc_On_Pool_Addr (Access_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, - (Kind => Iir_Value_Access, Val_Access => Val))); - end Create_Access_Value; - - function Create_Range_Value - (Left, Right : Iir_Value_Literal_Acc; - Dir : Iir_Direction; - Length : Iir_Index32) - return Iir_Value_Literal_Acc - is - subtype Range_Value is Iir_Value_Literal (Iir_Value_Range); - function Alloc is new Alloc_On_Pool_Addr (Range_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, - (Kind => Iir_Value_Range, - Left => Left, - Right => Right, - Dir => Dir, - Length => Length))); - end Create_Range_Value; - - function Create_File_Value (Val : Grt.Files.Ghdl_File_Index) - return Iir_Value_Literal_Acc - is - subtype File_Value is Iir_Value_Literal (Iir_Value_File); - function Alloc is new Alloc_On_Pool_Addr (File_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, - (Kind => Iir_Value_File, File => Val))); - end Create_File_Value; - - -- Create a range_value of life LIFE. - function Create_Range_Value - (Left, Right : Iir_Value_Literal_Acc; - Dir : Iir_Direction) - return Iir_Value_Literal_Acc - is - Low, High : Iir_Value_Literal_Acc; - Len : Iir_Index32; - begin - case Dir is - when Iir_To => - Low := Left; - High := Right; - when Iir_Downto => - Low := Right; - High := Left; - end case; - - case Iir_Value_Scalars (Low.Kind) is - when Iir_Value_B1 => - if High.B1 >= Low.B1 then - Len := Ghdl_B1'Pos (High.B1) - Ghdl_B1'Pos (Low.B1) + 1; - else - Len := 0; - end if; - when Iir_Value_E32 => - if High.E32 >= Low.E32 then - Len := Iir_Index32 (High.E32 - Low.E32 + 1); - else - Len := 0; - end if; - when Iir_Value_E8 => - if High.E8 >= Low.E8 then - Len := Ghdl_E8'Pos (High.E8) - Ghdl_E8'Pos (Low.E8) + 1; - else - Len := 0; - end if; - when Iir_Value_I64 => - declare - L : Ghdl_I64; - begin - if High.I64 = Ghdl_I64'Last and Low.I64 = Ghdl_I64'First - then - -- Prevent overflow - Len := Iir_Index32'Last; - else - L := High.I64 - Low.I64; - if L >= Ghdl_I64 (Iir_Index32'Last) then - -- Prevent overflow - Len := Iir_Index32'Last; - else - L := L + 1; - if L < 0 then - -- null range. - Len := 0; - else - Len := Iir_Index32 (L); - end if; - end if; - end if; - end; - when Iir_Value_F64 => - Len := 0; - end case; - return Create_Range_Value (Left, Right, Dir, Len); - end Create_Range_Value; - - -- Return an array of length LENGTH. - function Create_Array_Value (Dim : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc - is - subtype Array_Value is Iir_Value_Literal (Iir_Value_Array); - function Alloc_Array is new Alloc_On_Pool_Addr (Array_Value); - subtype Dim_Type is Value_Bounds_Array (Dim); - function Alloc_Bounds is new Alloc_On_Pool_Addr (Dim_Type); - Res : Iir_Value_Literal_Acc; - begin - Res := To_Iir_Value_Literal_Acc - (Alloc_Array (Pool, - (Kind => Iir_Value_Array, - Bounds => null, Val_Array => null))); - - Res.Bounds := To_Value_Bounds_Array_Acc - (Alloc_Bounds (Pool, Dim_Type'(Nbr_Dims => Dim, - D => (others => null)))); - - return Res; - end Create_Array_Value; - - procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc; - Len : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - is - use System; - subtype Data_Type is Value_Array (Len); - Res : Address; - begin - -- Manually allocate the array to handle large arrays without - -- creating a large temporary value. - Allocate - (Pool.all, Res, Data_Type'Size / Storage_Unit, Data_Type'Alignment); - - declare - -- Discard the warnings for no pragma Import as we really want - -- to use the default initialization. - pragma Warnings (Off); - Addr1 : constant Address := Res; - Init : Data_Type; - for Init'Address use Addr1; - pragma Warnings (On); - begin - null; - end; - - Arr.Val_Array := To_Value_Array_Acc (Res); - end Create_Array_Data; - - function Create_Array_Value (Length: Iir_Index32; - Dim : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value (Dim, Pool); - Create_Array_Data (Res, Length, Pool); - return Res; - end Create_Array_Value; - - function Create_Record_Value - (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc - is - subtype Record_Value is Iir_Value_Literal (Iir_Value_Record); - function Alloc_Record is new Alloc_On_Pool_Addr (Record_Value); - subtype Data_Type is Value_Array (Nbr); - function Alloc_Data is new Alloc_On_Pool_Addr (Data_Type); - Res : Iir_Value_Literal_Acc; - begin - Res := To_Iir_Value_Literal_Acc - (Alloc_Record (Pool, (Kind => Iir_Value_Record, Val_Record => null))); - - Res.Val_Record := To_Value_Array_Acc - (Alloc_Data (Pool, Data_Type'(Len => Nbr, V => (others => null)))); - - return Res; - end Create_Record_Value; - - -- Create a copy of SRC with a specified life. - function Copy (Src: in Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - case Src.Kind is - when Iir_Value_B1 => - return Create_B1_Value (Src.B1); - when Iir_Value_E32 => - return Create_E32_Value (Src.E32); - when Iir_Value_E8 => - return Create_E8_Value (Src.E8); - when Iir_Value_I64 => - return Create_I64_Value (Src.I64); - when Iir_Value_F64 => - return Create_F64_Value (Src.F64); - when Iir_Value_Access => - return Create_Access_Value (Src.Val_Access); - when Iir_Value_Array => - Res := Copy_Array_Bound (Src); - for I in Src.Val_Array.V'Range loop - Res.Val_Array.V (I) := Copy (Src.Val_Array.V (I)); - end loop; - return Res; - - when Iir_Value_Range => - return Create_Range_Value - (Left => Copy (Src.Left), - Right => Copy (Src.Right), - Dir => Src.Dir, - Length => Src.Length); - - when Iir_Value_Record => - Res := Copy_Record (Src); - for I in Src.Val_Record.V'Range loop - Res.Val_Record.V (I) := Copy (Src.Val_Record.V (I)); - end loop; - return Res; - - when Iir_Value_File => - return Create_File_Value (Src.File); - when Iir_Value_Protected => - return Create_Protected_Value (Src.Prot); - - when Iir_Value_Signal => - pragma Assert (Src.Sig = null); - return Create_Signal_Value (Src.Sig); - - when Iir_Value_Environment => - return Create_Environment_Value (Src.Environment); - - when Iir_Value_Quantity - | Iir_Value_Terminal => - raise Internal_Error; - end case; - end Copy; - - function Copy_Array_Bound (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); - for I in Res.Bounds.D'Range loop - Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); - end loop; - return Res; - end Copy_Array_Bound; - - function Copy_Record (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Create_Record_Value (Src.Val_Record.Len); - end Copy_Record; - - function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) - return Iir_Value_Literal_Acc - is - Prev_Pool : constant Areapool_Acc := Current_Pool; - Res : Iir_Value_Literal_Acc; - begin - Current_Pool := Pool; - Res := Copy (Src); - Current_Pool := Prev_Pool; - return Res; - end Unshare; - - function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) - return Iir_Value_Literal_Acc is - begin - if Src.Kind /= Iir_Value_Array then - return Src; - end if; - declare - Prev_Pool : constant Areapool_Acc := Current_Pool; - Res : Iir_Value_Literal_Acc; - begin - Current_Pool := Pool; - Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); - for I in Src.Bounds.D'Range loop - Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); - end loop; - Res.Val_Array.V := Src.Val_Array.V; - Current_Pool := Prev_Pool; - return Res; - end; - end Unshare_Bounds; - - Heap_Pool : aliased Areapool; - - function Unshare_Heap (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - -- FIXME: this is never free. - return Unshare (Src, Heap_Pool'Access); - end Unshare_Heap; - - procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc) is - begin - null; - end Free_Heap_Value; - - function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural is - begin - case Val.Kind is - when Iir_Value_Scalars - | Iir_Value_Access - | Iir_Value_Signal => - return 1; - when Iir_Value_Record => - declare - Total : Natural := 0; - begin - for I in Val.Val_Record.V'Range loop - Total := Total + Get_Nbr_Of_Scalars (Val.Val_Record.V (I)); - end loop; - return Total; - end; - when Iir_Value_Array => - if Val.Val_Array.Len = 0 then - -- Nul array - return 0; - else - -- At least one element. - return Natural (Val.Val_Array.Len) - * Get_Nbr_Of_Scalars (Val.Val_Array.V (1)); - end if; - when Iir_Value_File - | Iir_Value_Range - | Iir_Value_Protected - | Iir_Value_Terminal - | Iir_Value_Quantity - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Get_Nbr_Of_Scalars; - - function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural is - begin - case Val.Kind is - when Iir_Value_E8 => - return Ghdl_E8'Pos (Val.E8); - when Iir_Value_E32 => - return Ghdl_E32'Pos (Val.E32); - when Iir_Value_B1 => - return Ghdl_B1'Pos (Val.B1); - when others => - raise Internal_Error; - end case; - end Get_Enum_Pos; - - procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; - Tab: Ada.Text_IO.Count) - is - use Ada.Text_IO; - use GNAT.Debug_Utilities; - begin - Set_Col (Tab); - if Value = null then - Put_Line ("*NULL*"); - return; - end if; - - if Boolean'(True) then - Put (Image (Value.all'Address) & ' '); - end if; - - case Value.Kind is - when Iir_Value_B1 => - Put_Line ("b1:" & Ghdl_B1'Image (Value.B1)); - when Iir_Value_E8 => - Put_Line ("E8:" & Ghdl_E8'Image (Value.E8)); - when Iir_Value_E32 => - Put_Line ("e32:" & Ghdl_E32'Image (Value.E32)); - when Iir_Value_I64 => - Put_Line ("i64:" & Ghdl_I64'Image (Value.I64)); - when Iir_Value_F64 => - Put_Line ("F64:" & Ghdl_F64'Image (Value.F64)); - when Iir_Value_Access => - -- FIXME. - if Value.Val_Access = null then - Put_Line ("access: null"); - else - Put ("access: "); - Put_Line (Image (Value.Val_Access.all'Address)); - end if; - when Iir_Value_Array => - if Value.Val_Array = null then - Put_Line ("array, without elements"); - return; - else - Put_Line ("array, length: " - & Iir_Index32'Image (Value.Val_Array.Len)); - declare - Ntab: constant Count := Tab + Indentation; - begin - Set_Col (Ntab); - if Value.Bounds /= null then - Put_Line ("bounds 1 .." - & Iir_Index32'Image (Value.Bounds.Nbr_Dims) - & ':'); - for I in Value.Bounds.D'Range loop - Disp_Value_Tab (Value.Bounds.D (I), Ntab); - end loop; - else - Put_Line ("bounds = null"); - end if; - Set_Col (Ntab); - Put_Line ("values 1 .." - & Iir_Index32'Image (Value.Val_Array.Len) - & ':'); - for I in Value.Val_Array.V'Range loop - Disp_Value_Tab (Value.Val_Array.V (I), Ntab); - end loop; - end; - end if; - - when Iir_Value_Range => - Put_Line ("range:"); - Set_Col (Tab); - Put (" direction: "); - Put (Iir_Direction'Image (Value.Dir)); - Put (", length:"); - Put_Line (Iir_Index32'Image (Value.Length)); - if Value.Left /= null then - Set_Col (Tab); - Put (" left bound: "); - Disp_Value_Tab (Value.Left, Col); - end if; - if Value.Right /= null then - Set_Col (Tab); - Put (" right bound: "); - Disp_Value_Tab (Value.Right, Col); - end if; - - when Iir_Value_Record => - Put_Line ("record:"); - for I in Value.Val_Record.V'Range loop - Disp_Value_Tab (Value.Val_Record.V (I), Tab + Indentation); - end loop; - when Iir_Value_Signal => - Put ("signal: "); - if Value.Sig = null then - Put_Line ("(not created)"); - else - Put_Line (Image (Value.Sig.all'Address)); - end if; - - when Iir_Value_File => - Put_Line ("file:" & Grt.Files.Ghdl_File_Index'Image (Value.File)); - when Iir_Value_Protected => - Put_Line ("protected"); - when Iir_Value_Quantity => - Put_Line ("quantity"); - when Iir_Value_Terminal => - Put_Line ("terminal"); - when Iir_Value_Environment => - Put_Line ("environment"); - end case; - end Disp_Value_Tab; - - procedure Disp_Value (Value: Iir_Value_Literal_Acc) is - begin - Disp_Value_Tab (Value, 1); - end Disp_Value; - - -- Return TRUE if VALUE has an indirect value. - function Is_Indirect (Value : Iir_Value_Literal_Acc) return Boolean is - begin - case Value.Kind is - when Iir_Value_Scalars - | Iir_Value_Access - | Iir_Value_File - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - return False; - when Iir_Value_Range => - return Is_Indirect (Value.Left) - or else Is_Indirect (Value.Right); - when Iir_Value_Array => - for I in Value.Val_Array.V'Range loop - if Is_Indirect (Value.Val_Array.V (I)) then - return True; - end if; - end loop; - return False; - when Iir_Value_Record => - for I in Value.Val_Record.V'Range loop - if Is_Indirect (Value.Val_Record.V (I)) then - return True; - end if; - end loop; - return False; - when Iir_Value_Signal => - return True; - end case; - end Is_Indirect; - - procedure Disp_Iir_Value_Array (Value: Iir_Value_Literal_Acc; - A_Type: Iir; - Dim: Iir_Index32; - Off : in out Iir_Index32) - is - use Ada.Text_IO; - type Last_Enum_Type is (None, Char, Identifier); - Last_Enum: Last_Enum_Type; - El_Type: Iir; - Enum_List: Iir_Flist; - El_Id : Name_Id; - El_Pos : Natural; - begin - if Dim = Value.Bounds.Nbr_Dims then - -- Last dimension - El_Type := Get_Base_Type (Get_Element_Subtype (A_Type)); - - -- Pretty print vectors of enumerated types - if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition - and then not Is_Indirect (Value) - then - Last_Enum := None; - Enum_List := Get_Enumeration_Literal_List (El_Type); - for I in 1 .. Value.Bounds.D (Dim).Length loop - El_Pos := Get_Enum_Pos (Value.Val_Array.V (Off)); - Off := Off + 1; - El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); - if Name_Table.Is_Character (El_Id) then - case Last_Enum is - when None => - Put (""""); - when Identifier => - Put (" & """); - when Char => - null; - end case; - Put (Name_Table.Get_Character (El_Id)); - Last_Enum := Char; - else - case Last_Enum is - when None => - null; - when Identifier => - Put (" & "); - when Char => - Put (""" & "); - end case; - Put (Name_Table.Image (El_Id)); - Last_Enum := Identifier; - end if; - end loop; - case Last_Enum is - when None => - Put (""""""); -- Simply "" - when Identifier => - null; - when Char => - Put (""""); - end case; - else - Put ("("); - for I in 1 .. Value.Bounds.D (Dim).Length loop - if I /= 1 then - Put (", "); - end if; - Disp_Iir_Value (Value.Val_Array.V (Off), El_Type); - Off := Off + 1; - end loop; - Put (")"); - end if; - else - Put ("("); - for I in 1 .. Value.Bounds.D (Dim).Length loop - if I /= 1 then - Put (", "); - end if; - Disp_Iir_Value_Array (Value, A_Type, Dim + 1, Off); - end loop; - Put (")"); - end if; - end Disp_Iir_Value_Array; - - procedure Disp_Iir_Value_Record - (Value: Iir_Value_Literal_Acc; A_Type: Iir) - is - use Ada.Text_IO; - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (A_Type)); - El : Iir_Element_Declaration; - begin - Put ("("); - for I in Value.Val_Record.V'Range loop - El := Get_Nth_Element (List, Natural (I - 1)); - if I /= 1 then - Put (", "); - end if; - Put (Name_Table.Image (Get_Identifier (El))); - Put (" => "); - Disp_Iir_Value (Value.Val_Record.V (I), Get_Type (El)); - end loop; - Put (")"); - end Disp_Iir_Value_Record; - - procedure Disp_Iir_Value_Enum (Pos : Natural; A_Type : Iir) - is - Bt : constant Iir := Get_Base_Type (A_Type); - Id : Name_Id; - begin - Id := Get_Identifier - (Get_Nth_Element (Get_Enumeration_Literal_List (Bt), Pos)); - Ada.Text_IO.Put (Name_Table.Image (Id)); - end Disp_Iir_Value_Enum; - - procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir) is - use Ada.Text_IO; - begin - if Value = null then - Put ("!NULL!"); - return; - end if; - case Value.Kind is - when Iir_Value_I64 => - Put (Ghdl_I64'Image (Value.I64)); - when Iir_Value_F64 => - Put (Ghdl_F64'Image (Value.F64)); - when Iir_Value_E32 => - Disp_Iir_Value_Enum (Ghdl_E32'Pos (Value.E32), A_Type); - when Iir_Value_E8 => - Disp_Iir_Value_Enum (Ghdl_E8'Pos (Value.E8), A_Type); - when Iir_Value_B1 => - Disp_Iir_Value_Enum (Ghdl_B1'Pos (Value.B1), A_Type); - when Iir_Value_Access => - if Value.Val_Access = null then - Put ("null"); - else - -- FIXME. - Put ("*acc*"); - end if; - when Iir_Value_Array => - declare - Off : Iir_Index32; - begin - Off := 1; - Disp_Iir_Value_Array (Value, A_Type, 1, Off); - pragma Assert (Off = Value.Val_Array.Len + 1); - end; - when Iir_Value_File => - raise Internal_Error; - when Iir_Value_Record => - Disp_Iir_Value_Record (Value, A_Type); - when Iir_Value_Range => - -- FIXME. - raise Internal_Error; - when Iir_Value_Quantity => - Put ("[quantity]"); - when Iir_Value_Terminal => - Put ("[terminal]"); - when Iir_Value_Signal => - Put ("[signal]"); - when Iir_Value_Protected => - Put ("[protected]"); - when Iir_Value_Environment => - Put ("[environment]"); - end case; - end Disp_Iir_Value; -end Iir_Values; diff --git a/src/vhdl/simulate/iir_values.ads b/src/vhdl/simulate/iir_values.ads deleted file mode 100644 index 68b6d1326..000000000 --- a/src/vhdl/simulate/iir_values.ads +++ /dev/null @@ -1,481 +0,0 @@ --- Naive values for 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.Text_IO; -with Ada.Unchecked_Deallocation; -with Types; use Types; -with Iirs; use Iirs; -with Grt.Types; use Grt.Types; -with Grt.Signals; use Grt.Signals; -with Grt.Files; -with Areapools; use Areapools; --- with System.Debug_Pools; - -package Iir_Values is - -- During simulation, all values are contained into objects of type - -- iir_value_literal. The annotation pass creates such objects for every - -- literal of units. The elaboration pass creates such objects for - -- signals, variables, contants... - -- The simulator uses iir_value_literal for intermediate results, for - -- computed values... - - -- There is several kinds of iir_value_literal, mainly depending on the - -- type of the value: - -- - -- iir_value_e32: - -- the value is an enumeration literal. The enum field contains the - -- position of the literal (same as 'pos). - -- - -- iir_value_i64: - -- the value is an integer. - -- - -- iir_value_f64: - -- the value is a floating point. - -- - -- iir_value_range: - -- Boundaries and direction. - -- - -- iir_value_array: - -- All the values are contained in the array Val_Array. - -- Boundaries of the array are contained in the array BOUNDS, one element - -- per dimension, from 1 to number of dimensions. - -- - -- iir_value_signal: - -- Special case: the iir_value_literal designates a signal. - -- - -- iir_value_record - -- For records. - -- - -- iir_value_access - -- for accesses. - -- - -- iir_value_file - -- for files. - - -- Memory management: - -- The values are always allocated on areapool, which uses a mark/release - -- management. A release operation frees all the memory of the areapool - -- allocated since the mark. This memory management is very efficient. - -- - -- There is one areapool per processes; there is one mark per instances. - -- Objects (variables, signals, constants, iterators, ...) are allocated - -- on the per-process pool. When an activation frame is created (due - -- to a call to a subprogram), a mark is saved. When the activation frame - -- is removed (due to a return from subprogram), the memory is released to - -- the mark. That's simple. - -- - -- Objects for the process is allocated in that areapool, but never - -- released (could be if the process is waiting forever if the user don't - -- need to inspect values). - -- - -- Signals and constants for blocks/entity/architecture are allocated on - -- a global pool. - -- - -- In fact this is not so simple because of functions: they return a - -- value. The current solution is to compute every expressions on a - -- expression pool (only one is needed as the computation cannot be - -- suspended), use the result (copy in case of assignment or return), and - -- release that pool. - -- - -- It is highly recommended to share values as much as possible for - -- expressions (for example, alias the values of 'others =>'). Do not - -- share values for names, but be sure to keep the original nodes. - -- ??? In fact sharing is required to pass actual by references. - -- When an object is created, be sure to unshare the values. This is - -- usually achieved by Copy. - -- - -- Finally, a pool is also needed during elaboration (as elaboration is - -- not done within the context of a process). - - type Iir_Value_Kind is - (Iir_Value_B1, Iir_Value_E8, Iir_Value_E32, - Iir_Value_I64, Iir_Value_F64, - Iir_Value_Access, - Iir_Value_File, - Iir_Value_Range, - Iir_Value_Array, Iir_Value_Record, - Iir_Value_Protected, - Iir_Value_Signal, - Iir_Value_Terminal, - Iir_Value_Quantity, - Iir_Value_Environment); - - -- Uniq identifier for scalar signal. First identifier is 'First + 1. - type Signal_Index_Type is new Natural; - function Get_Last_Signal_Index return Signal_Index_Type; - - type Protected_Index_Type is new Natural; - type Quantity_Index_Type is new Natural; - type Terminal_Index_Type is new Natural; - type Environment_Index_Type is new Natural; - - -- Scalar values. Only these ones can be signals. - subtype Iir_Value_Scalars is - Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_F64; - - subtype Iir_Value_Discrete is - Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_I64; - - subtype Iir_Value_Enums is - Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_E32; - - -- Abstrace numeric types. - subtype Iir_Value_Numerics is - Iir_Value_Kind range Iir_Value_I64 .. Iir_Value_F64; - - subtype Iir_Value_Physicals is - Iir_Value_Kind range Iir_Value_I64 .. Iir_Value_I64; - - type Iir_Value_Literal (Kind: Iir_Value_Kind); - - type Iir_Value_Literal_Acc is access Iir_Value_Literal; - - -- Must start at 0. - -- Thus, length of the array is val_array'last - 1. - type Iir_Value_Literal_Array is array (Iir_Index32 range <>) of - Iir_Value_Literal_Acc; - - type Iir_Value_Literal_Array_Acc is access Iir_Value_Literal_Array; - - type Value_Bounds_Array (Nbr_Dims : Iir_Index32) is record - D : Iir_Value_Literal_Array (1 .. Nbr_Dims); - end record; - - type Value_Bounds_Array_Acc is access Value_Bounds_Array; - - type Value_Array (Len : Iir_Index32) is record - V : Iir_Value_Literal_Array (1 .. Len); - end record; - - type Value_Array_Acc is access Value_Array; - - -- A block instance with its architecture/entity declaration is an - -- instancied entity. - type Block_Instance_Type; - type Block_Instance_Acc is access Block_Instance_Type; - - type Iir_Value_Literal (Kind: Iir_Value_Kind) is record - case Kind is - when Iir_Value_B1 => - B1 : Ghdl_B1; - when Iir_Value_E8 => - E8 : Ghdl_E8; - when Iir_Value_E32 => - E32 : Ghdl_E32; - when Iir_Value_I64 => - I64 : Ghdl_I64; - when Iir_Value_F64 => - F64 : Ghdl_F64; - when Iir_Value_Access => - Val_Access: Iir_Value_Literal_Acc; - when Iir_Value_File => - File: Grt.Files.Ghdl_File_Index; - when Iir_Value_Array => - Val_Array: Value_Array_Acc; -- range 1 .. N - Bounds : Value_Bounds_Array_Acc; -- range 1 .. Dim - when Iir_Value_Record => - Val_Record: Value_Array_Acc; -- range 1 .. N - when Iir_Value_Signal => - Sig : Ghdl_Signal_Ptr; - -- Each signal has a uniq identifier. - Sig_Id : Signal_Index_Type; - when Iir_Value_Protected => - Prot : Protected_Index_Type; - when Iir_Value_Quantity => - Quantity : Quantity_Index_Type; - when Iir_Value_Terminal => - Terminal : Terminal_Index_Type; - when Iir_Value_Environment => - Environment : Environment_Index_Type; - when Iir_Value_Range => - Dir: Iir_Direction; - Length : Iir_Index32; - Left: Iir_Value_Literal_Acc; - Right: Iir_Value_Literal_Acc; - end case; - end record; - - type Object_Slot_Type is new Natural; - subtype Parameter_Slot_Type is Object_Slot_Type range 0 .. 2**15; - - type Pkg_Index_Type is new Natural; - - -- Scope corresponding to an object. - type Scope_Kind_Type is - ( - -- For a package, the depth is - Scope_Kind_Package, - Scope_Kind_Component, - Scope_Kind_Frame, - Scope_Kind_Pkg_Inst, - Scope_Kind_None - ); - type Scope_Depth_Type is range 0 .. 2**15; - type Scope_Type (Kind : Scope_Kind_Type := Scope_Kind_None) is record - case Kind is - when Scope_Kind_Package => - Pkg_Index : Pkg_Index_Type; - when Scope_Kind_Component => - null; - when Scope_Kind_Frame => - Depth : Scope_Depth_Type; - when Scope_Kind_Pkg_Inst => - Pkg_Param : Parameter_Slot_Type; - -- Pkg_Parent : Sim_Info_Acc; - when Scope_Kind_None => - null; - end case; - end record; - - type Block_Instance_Id is new Natural; - No_Block_Instance_Id : constant Block_Instance_Id := 0; - - type Objects_Array is array (Object_Slot_Type range <>) of - Iir_Value_Literal_Acc; - - type Block_Instance_Type (Max_Objs : Object_Slot_Type) is record - -- Flag for wait statement: true if not yet executed. - In_Wait_Flag : Boolean; - - -- Uniq number for a block instance. - Id : Block_Instance_Id; - - -- Useful informations for a dynamic block (ie, a frame). - -- The scope level and an access to the block of upper scope level. - Block_Scope : Scope_Type; - Up_Block : Block_Instance_Acc; - - -- Block, architecture, package, process, component instantiation for - -- this instance. - Label : Iir; - - -- For blocks: corresponding block (different from label for direct - -- component instantiation statement and generate iterator). - -- For packages: Null_Iir - -- For subprograms and processes: statement being executed. - Stmt : Iir; - - -- Instanciation tree. - - -- Parent is always set (but null for top-level block and packages) - Parent: Block_Instance_Acc; - - -- Chain of children. They are in declaration order after elaboration. - -- (in reverse order during elaboration). - -- Not null only for blocks and processes. - Children: Block_Instance_Acc; - Brother: Block_Instance_Acc; - - -- Port association map for this block, if any. - Ports_Map : Iir; - - -- Pool marker for the child (only for subprograms and processes). - Marker : Areapools.Mark_Type; - - -- Reference to the actuals, for copy-out when returning from a - -- procedure. - Actuals_Ref : Value_Array_Acc; - - -- Only for function frame; contains the result. - Result: Iir_Value_Literal_Acc; - - -- Last object elaborated (or number of objects elaborated). - -- Note: this is generally the slot index of the next object to be - -- elaborated (this may be wrong for dynamic objects due to execution - -- branches). - Elab_Objects : Object_Slot_Type := 0; - - -- Values of the objects in that frame. - Objects : Objects_Array (1 .. Max_Objs); - end record; - - procedure Free is new Ada.Unchecked_Deallocation - (Object => Block_Instance_Type, Name => Block_Instance_Acc); - - - -- What is chosen for time. - subtype Iir_Value_Time is Ghdl_I64; - - Global_Pool : aliased Areapool; - Expr_Pool : aliased Areapool; - - -- Areapool used by Create_*_Value - Current_Pool : Areapool_Acc := Expr_Pool'Access; - - -- Pool for objects allocated in the current instance. - Instance_Pool : Areapool_Acc; - - function Create_Signal_Value (Sig : Ghdl_Signal_Ptr) - return Iir_Value_Literal_Acc; - function Create_Terminal_Value (Terminal : Terminal_Index_Type) - return Iir_Value_Literal_Acc; - function Create_Quantity_Value (Quantity : Quantity_Index_Type) - return Iir_Value_Literal_Acc; - function Create_Environment_Value (Env : Environment_Index_Type) - return Iir_Value_Literal_Acc; - - function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc; - function Create_E8_Value (Val : Ghdl_E8) return Iir_Value_Literal_Acc; - function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc; - - -- Return an iir_value_literal_acc (iir_value_int64). - function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc; - - -- Return an iir_value_literal_acc (iir_value_fp64) - function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc; - - function Create_Access_Value (Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - function Create_File_Value (Val : Grt.Files.Ghdl_File_Index) - return Iir_Value_Literal_Acc; - - function Create_Protected_Value (Prot : Protected_Index_Type) - return Iir_Value_Literal_Acc; - - -- Return an iir_value_literal (iir_value_record) of NBR elements. - function Create_Record_Value - (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc; - - -- Allocate array and the dimension vector (but bounds and values aren't - -- allocated). - function Create_Array_Value (Dim : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc; - - -- Allocate the Val_Array vector. - procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc; - Len : Iir_Index32; - Pool : Areapool_Acc := Current_Pool); - - -- Return an array of length LENGTH and DIM bounds. - -- If DIM is 0, then the bounds array is not allocated. - function Create_Array_Value (Length: Iir_Index32; - Dim : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc; - - -- Create a range_value of life LIFE. - function Create_Range_Value - (Left, Right : Iir_Value_Literal_Acc; - Dir : Iir_Direction; - Length : Iir_Index32) - return Iir_Value_Literal_Acc; - - -- Create a range_value (compute the length) - function Create_Range_Value - (Left, Right : Iir_Value_Literal_Acc; - Dir : Iir_Direction) - return Iir_Value_Literal_Acc; - - -- Return true if the value of LEFT and RIGHT are equal. - -- Return false if they are not equal. - -- Raise constraint_error if the types differes. - -- Value or sub-value must not be indirect. - function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean; - - -- Return TRUE iif ARANGE is a null range. - function Is_Null_Range (Arange : Iir_Value_Literal_Acc) return Boolean; - - -- Get order of LEFT with RIGHT. - -- Must be discrete kind (enum, int, fp, physical) or array (uni dim). - type Order is (Less, Equal, Greater); - function Compare_Value (Left, Right : Iir_Value_Literal_Acc) - return Order; - - -- Check that SRC has the same structure as DEST. Report an error at - -- LOC if not. - procedure Check_Bounds (Dest : Iir_Value_Literal_Acc; - Src : Iir_Value_Literal_Acc; - Loc : Iir); - - -- Store (by copy) SRC into DEST. - -- The type must be equal (otherwise constraint_error is raised). - -- Life of DEST must be Target, otherwise program_error is raised. - -- Value or sub-value must not be indirect. - procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc); - - -- Create a copy of SRC allocated in POOL. - function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) - return Iir_Value_Literal_Acc; - - -- If SRC is an array, just copy the bounds in POOL and return it. - -- Otherwise return SRC. Values are always kept, so that this could - -- be used by alias declarations. - function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) - return Iir_Value_Literal_Acc; - - -- Create a copy of SRC on the heap. - function Unshare_Heap (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - -- Deallocate value accessed by ACC. - procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc); - - -- Increment. - -- VAL must be of kind integer or enumeration. - -- VAL must be of life temporary. - procedure Increment (Val : Iir_Value_Literal_Acc); - - -- Copy BOUNDS of SRC with a specified life. - -- Note: val_array is allocated but not filled. - function Copy_Array_Bound (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - -- Copy the bounds (well the array containing the values) of SRC. - -- Val_record is allocated but not filled. - function Copy_Record (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - -- Return the number of scalars elements in VALS. - function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural; - - -- Return the position of an enumerated type value. - function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural; - - -- Well known values. - -- Boolean_to_lit can be used to convert a boolean value from Ada to a - -- boolean value for vhdl. - type Lit_Enum_Type is array (Boolean) of Iir_Value_Literal_Acc; - Lit_Enum_0 : constant Iir_Value_Literal_Acc := - new Iir_Value_Literal'(Kind => Iir_Value_B1, - B1 => False); - Lit_Enum_1 : constant Iir_Value_Literal_Acc := - new Iir_Value_Literal'(Kind => Iir_Value_B1, - B1 => True); - Boolean_To_Lit: constant Lit_Enum_Type := - (False => Lit_Enum_0, True => Lit_Enum_1); - Lit_Boolean_False: Iir_Value_Literal_Acc - renames Boolean_To_Lit (False); - Lit_Boolean_True: Iir_Value_Literal_Acc - renames Boolean_To_Lit (True); - - -- Literal NULL. - Null_Lit: constant Iir_Value_Literal_Acc := - new Iir_Value_Literal'(Kind => Iir_Value_Access, - Val_Access => null); - - -- Disp a value_literal in raw form. - procedure Disp_Value (Value: Iir_Value_Literal_Acc); - procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; - Tab: Ada.Text_IO.Count); - - -- Disp a value_literal in readable form. - procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir); -end Iir_Values; diff --git a/src/vhdl/simulate/simul-annotations.adb b/src/vhdl/simulate/simul-annotations.adb new file mode 100644 index 000000000..de811e424 --- /dev/null +++ b/src/vhdl/simulate/simul-annotations.adb @@ -0,0 +1,1345 @@ +-- Annotations for 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 Tables; +with Ada.Text_IO; +with Std_Package; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; + +package body Simul.Annotations is + -- Current scope. Used when an object is created to indicate which scope + -- it belongs to. + Current_Scope: Scope_Type := (Kind => Scope_Kind_None); + + procedure Annotate_Declaration_List + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir); + procedure Annotate_Sequential_Statement_Chain + (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir); + procedure Annotate_Concurrent_Statements_List + (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir); + procedure Annotate_Block_Configuration + (Block : Iir_Block_Configuration); + procedure Annotate_Subprogram_Interfaces_Type + (Block_Info : Sim_Info_Acc; Subprg: Iir); + procedure Annotate_Subprogram_Specification + (Block_Info : Sim_Info_Acc; Subprg: Iir); + procedure Annotate_Interface_List + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir; With_Types : Boolean); + + procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir); + + -- Annotate type definition DEF only if it is anonymous. + procedure Annotate_Anonymous_Type_Definition + (Block_Info: Sim_Info_Acc; Def: Iir); + + procedure Increment_Current_Scope is + begin + case Current_Scope.Kind is + when Scope_Kind_None + | Scope_Kind_Package + | Scope_Kind_Pkg_Inst => + -- For a subprogram in a package + Current_Scope := (Scope_Kind_Frame, Scope_Depth_Type'First); + when Scope_Kind_Frame => + Current_Scope := (Scope_Kind_Frame, Current_Scope.Depth + 1); + when Scope_Kind_Component => + raise Internal_Error; + end case; + end Increment_Current_Scope; + + -- Add an annotation to object OBJ. + procedure Create_Object_Info (Block_Info : Sim_Info_Acc; + Obj : Iir; + Obj_Kind : Sim_Info_Kind := Kind_Object) + is + Info : Sim_Info_Acc; + begin + Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1; + case Obj_Kind is + when Kind_Object => + Info := new Sim_Info_Type'(Kind => Kind_Object, + Obj_Scope => Current_Scope, + Slot => Block_Info.Nbr_Objects); + when Kind_File => + Info := new Sim_Info_Type'(Kind => Kind_File, + Obj_Scope => Current_Scope, + Slot => Block_Info.Nbr_Objects); + when Kind_Signal => + Info := new Sim_Info_Type'(Kind => Kind_Signal, + Obj_Scope => Current_Scope, + Slot => Block_Info.Nbr_Objects); + -- Reserve one more slot for value. + Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1; + when Kind_Terminal => + Info := new Sim_Info_Type'(Kind => Kind_Terminal, + Obj_Scope => Current_Scope, + Slot => Block_Info.Nbr_Objects); + when Kind_Quantity => + Info := new Sim_Info_Type'(Kind => Kind_Quantity, + Obj_Scope => Current_Scope, + Slot => Block_Info.Nbr_Objects); + when Kind_PSL => + Info := new Sim_Info_Type'(Kind => Kind_PSL, + Obj_Scope => Current_Scope, + Slot => Block_Info.Nbr_Objects); + when Kind_Environment => + Info := new Sim_Info_Type'(Kind => Kind_Environment, + Env_Slot => Block_Info.Nbr_Objects, + Frame_Scope => Current_Scope, + Nbr_Objects => 0); + when Kind_Block + | Kind_Process + | Kind_Frame + | Kind_Scalar_Type + | Kind_File_Type + | Kind_Extra => + raise Internal_Error; + end case; + Set_Info (Obj, Info); + end Create_Object_Info; + + -- Add an annotation to SIGNAL. + procedure Create_Signal_Info (Block_Info: Sim_Info_Acc; Signal: Iir) is + begin + Create_Object_Info (Block_Info, Signal, Kind_Signal); + end Create_Signal_Info; + + procedure Add_Terminal_Info (Block_Info: Sim_Info_Acc; Terminal : Iir) is + begin + Create_Object_Info (Block_Info, Terminal, Kind_Terminal); + end Add_Terminal_Info; + + procedure Add_Quantity_Info (Block_Info: Sim_Info_Acc; Quantity : Iir) is + begin + Create_Object_Info (Block_Info, Quantity, Kind_Quantity); + end Add_Quantity_Info; + + -- If EXPR has not a literal value, create one. + -- This is necessary for subtype bounds. + procedure Annotate_Range_Expression + (Block_Info: Sim_Info_Acc; Expr: Iir_Range_Expression) + is + begin + if Get_Info (Expr) /= null then + return; + end if; +-- if Expr = null or else Get_Info (Expr) /= null then +-- return; +-- end if; + Create_Object_Info (Block_Info, Expr); + end Annotate_Range_Expression; + + -- Annotate type definition DEF only if it is anonymous. + procedure Annotate_Anonymous_Type_Definition + (Block_Info: Sim_Info_Acc; Def: Iir) + is + begin + if Is_Anonymous_Type_Definition (Def) then + Annotate_Type_Definition (Block_Info, Def); + end if; + end Annotate_Anonymous_Type_Definition; + + function Get_File_Signature_Length (Def : Iir) return Natural is + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_And_Subtype_Definition => + return 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + return 2 + + Get_File_Signature_Length (Get_Element_Subtype (Def)); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (Def)); + El : Iir; + Res : Natural; + begin + Res := 2; + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Res := Res + Get_File_Signature_Length (Get_Type (El)); + end loop; + return Res; + end; + when others => + Error_Kind ("get_file_signature_length", Def); + end case; + end Get_File_Signature_Length; + + procedure Get_File_Signature (Def : Iir; + Res : in out String; + Off : in out Natural) + is + Scalar_Map : constant array (Iir_Value_Scalars) of Character := "beEIF"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_And_Subtype_Definition => + Res (Off) := + Scalar_Map (Get_Info (Get_Base_Type (Def)).Scalar_Mode); + Off := Off + 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + Res (Off) := '['; + Off := Off + 1; + Get_File_Signature (Get_Element_Subtype (Def), Res, Off); + Res (Off) := ']'; + Off := Off + 1; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (Def)); + El : Iir; + begin + Res (Off) := '<'; + Off := Off + 1; + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Get_File_Signature (Get_Type (El), Res, Off); + end loop; + Res (Off) := '>'; + Off := Off + 1; + end; + when others => + Error_Kind ("get_file_signature", Def); + end case; + end Get_File_Signature; + + procedure Annotate_Protected_Type_Declaration (Block_Info : Sim_Info_Acc; + Prot: Iir) + is + Prev_Scope : constant Scope_Type := Current_Scope; + Decl : Iir; + Prot_Info: Sim_Info_Acc; + begin + -- First the interfaces type (they are elaborated in their context). + Decl := Get_Declaration_Chain (Prot); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Annotate_Subprogram_Interfaces_Type (Block_Info, Decl); + when Iir_Kind_Use_Clause => + null; + when others => + -- FIXME: attribute + Error_Kind ("annotate_protected_type_declaration", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + + -- Then the interfaces object. Increment the scope to reserve a scope + -- for the protected object. + Increment_Current_Scope; + + Prot_Info := + new Sim_Info_Type'(Kind => Kind_Frame, + Frame_Scope => Current_Scope, + Nbr_Objects => 0); + Set_Info (Prot, Prot_Info); + + Decl := Get_Declaration_Chain (Prot); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Annotate_Subprogram_Specification (Block_Info, Decl); + when Iir_Kind_Use_Clause => + null; + when others => + Error_Kind ("annotate_protected_type_declaration", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + + Current_Scope := Prev_Scope; + end Annotate_Protected_Type_Declaration; + + procedure Annotate_Protected_Type_Body (Block_Info : Sim_Info_Acc; + Prot: Iir) + is + pragma Unreferenced (Block_Info); + Prot_Info: Sim_Info_Acc; + Prev_Scope : constant Scope_Type := Current_Scope; + begin + Prot_Info := Get_Info (Get_Protected_Type_Declaration (Prot)); + Set_Info (Prot, Prot_Info); + + Current_Scope := Prot_Info.Frame_Scope; + + Annotate_Declaration_List (Prot_Info, Get_Declaration_Chain (Prot)); + + Current_Scope := Prev_Scope; + end Annotate_Protected_Type_Body; + + procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir) + is + El: Iir; + begin + -- Happen only with universal types. + if Def = Null_Iir then + return; + end if; + + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + declare + Mode : Iir_Value_Kind; + begin + if Def = Std_Package.Boolean_Type_Definition + or else Def = Std_Package.Bit_Type_Definition + then + Mode := Iir_Value_B1; + elsif (Get_Nbr_Elements (Get_Enumeration_Literal_List (Def)) + <= 256) + then + Mode := Iir_Value_E8; + else + Mode := Iir_Value_E32; + end if; + Set_Info (Def, new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Mode)); + Annotate_Range_Expression + (Block_Info, Get_Range_Constraint (Def)); + end; + + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + El := Get_Range_Constraint (Def); + if El /= Null_Iir then + case Get_Kind (El) is + when Iir_Kind_Range_Expression => + Annotate_Range_Expression (Block_Info, El); + -- A physical subtype may be defined by an integer range. + if Get_Kind (Def) = Iir_Kind_Physical_Subtype_Definition + then + null; + -- FIXME + -- Convert_Int_To_Phys (Get_Info (El).Value); + end if; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + null; + when others => + Error_Kind ("annotate_type_definition (rc)", El); + end case; + end if; + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Base_Type (Def)); + + when Iir_Kind_Integer_Type_Definition => + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_I64)); + + when Iir_Kind_Floating_Type_Definition => + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_F64)); + + when Iir_Kind_Physical_Type_Definition => + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_Scalar_Type, + Scalar_Mode => Iir_Value_I64)); + + when Iir_Kind_Array_Type_Definition => + El := Get_Element_Subtype (Def); + Annotate_Anonymous_Type_Definition (Block_Info, El); + + when Iir_Kind_Array_Subtype_Definition => + declare + List : constant Iir_Flist := Get_Index_Subtype_List (Def); + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Index_Type (List, I); + Annotate_Anonymous_Type_Definition (Block_Info, El); + end loop; + end; + + when Iir_Kind_Record_Type_Definition => + declare + List : constant Iir_Flist := + Get_Elements_Declaration_List (Def); + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Type (El)); + end loop; + end; + + when Iir_Kind_Record_Subtype_Definition => + null; + + when Iir_Kind_Access_Type_Definition => + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Designated_Type (Def)); + + when Iir_Kind_Access_Subtype_Definition => + null; + + when Iir_Kind_File_Type_Definition => + declare + Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); + Res : String_Acc; + begin + if Get_Text_File_Flag (Def) + or else + (Get_Kind (Type_Name) + in Iir_Kinds_Scalar_Type_And_Subtype_Definition) + then + Res := null; + else + declare + Sig : String + (1 .. Get_File_Signature_Length (Type_Name) + 2); + Off : Natural := Sig'First; + begin + Get_File_Signature (Type_Name, Sig, Off); + Sig (Off + 0) := '.'; + Sig (Off + 1) := ASCII.NUL; + Res := new String'(Sig); + end; + end if; + Set_Info (Def, + new Sim_Info_Type'(Kind => Kind_File_Type, + File_Signature => Res)); + end; + + when Iir_Kind_Protected_Type_Declaration => + Annotate_Protected_Type_Declaration (Block_Info, Def); + + when Iir_Kind_Incomplete_Type_Definition => + null; + + when others => + Error_Kind ("annotate_type_definition", Def); + end case; + end Annotate_Type_Definition; + + procedure Annotate_Interface_List_Subtype + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir) + is + El: Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El)); + when others => + Error_Kind ("annotate_interface_list", El); + end case; + El := Get_Chain (El); + end loop; + end Annotate_Interface_List_Subtype; + + procedure Annotate_Interface_Package_Declaration + (Block_Info: Sim_Info_Acc; Inter : Iir) + is + Prev_Scope : constant Scope_Type := Current_Scope; + Package_Info : Sim_Info_Acc; + begin + Create_Object_Info (Block_Info, Inter, Kind_Environment); + Package_Info := Get_Info (Inter); + + Current_Scope := (Kind => Scope_Kind_Pkg_Inst, + Pkg_Param => 0); +-- Pkg_Parent => Package_Info); + + Annotate_Interface_List + (Package_Info, Get_Generic_Chain (Inter), True); + Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Inter)); + + Current_Scope := Prev_Scope; + end Annotate_Interface_Package_Declaration; + + procedure Annotate_Interface_List + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir; With_Types : Boolean) + is + Decl : Iir; + begin + Decl := Decl_Chain; + while Decl /= Null_Iir loop + if With_Types + and then Get_Kind (Decl) in Iir_Kinds_Interface_Object_Declaration + then + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + end if; + case Get_Kind (Decl) is + when Iir_Kind_Interface_Signal_Declaration => + Create_Signal_Info (Block_Info, Decl); + when Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + Create_Object_Info (Block_Info, Decl); + when Iir_Kind_Interface_Package_Declaration => + Annotate_Interface_Package_Declaration (Block_Info, Decl); + when others => + Error_Kind ("annotate_interface_list", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Annotate_Interface_List; + + procedure Annotate_Subprogram_Interfaces_Type + (Block_Info : Sim_Info_Acc; Subprg: Iir) + is + Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg); + begin + -- See LRM93 12.3.1.1 (Subprogram declarations and bodies). The type + -- of the interfaces are elaborated in the outer context. + Annotate_Interface_List_Subtype (Block_Info, Interfaces); + + if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then + -- FIXME: can this create a new annotation ? + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Return_Type (Subprg)); + end if; + end Annotate_Subprogram_Interfaces_Type; + + procedure Annotate_Subprogram_Specification + (Block_Info : Sim_Info_Acc; Subprg: Iir) + is + pragma Unreferenced (Block_Info); + Subprg_Info: Sim_Info_Acc; + Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg); + Prev_Scope : constant Scope_Type := Current_Scope; + begin + Increment_Current_Scope; + + Subprg_Info := + new Sim_Info_Type'(Kind => Kind_Frame, + Frame_Scope => Current_Scope, + Nbr_Objects => 0); + Set_Info (Subprg, Subprg_Info); + + Annotate_Interface_List (Subprg_Info, Interfaces, False); + + Current_Scope := Prev_Scope; + end Annotate_Subprogram_Specification; + + procedure Annotate_Subprogram_Body + (Block_Info : Sim_Info_Acc; Subprg: Iir) + is + pragma Unreferenced (Block_Info); + Spec : constant Iir := Get_Subprogram_Specification (Subprg); + Subprg_Info : constant Sim_Info_Acc := Get_Info (Spec); + Prev_Scope : constant Scope_Type := Current_Scope; + begin + -- Do not annotate body of foreign subprograms. + if Get_Foreign_Flag (Spec) then + return; + end if; + + Set_Info (Subprg, Subprg_Info); + + Current_Scope := Subprg_Info.Frame_Scope; + + Annotate_Declaration_List + (Subprg_Info, Get_Declaration_Chain (Subprg)); + + Annotate_Sequential_Statement_Chain + (Subprg_Info, Get_Sequential_Statement_Chain (Subprg)); + + Current_Scope := Prev_Scope; + end Annotate_Subprogram_Body; + + procedure Annotate_Component_Declaration (Comp: Iir_Component_Declaration) + is + Prev_Scope : constant Scope_Type := Current_Scope; + Info : Sim_Info_Acc; + begin + Current_Scope := (Kind => Scope_Kind_Component); + + Info := new Sim_Info_Type'(Kind => Kind_Block, + Frame_Scope => Current_Scope, + Inst_Slot => Invalid_Instance_Slot, + Nbr_Objects => 0, + Nbr_Instances => 1); -- For the instance. + Set_Info (Comp, Info); + + Annotate_Interface_List (Info, Get_Generic_Chain (Comp), True); + Annotate_Interface_List (Info, Get_Port_Chain (Comp), True); + + Current_Scope := Prev_Scope; + end Annotate_Component_Declaration; + + procedure Annotate_Declaration (Block_Info: Sim_Info_Acc; Decl: Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Signal_Attribute_Declaration => + declare + Attr : Iir; + begin + Attr := Get_Signal_Attribute_Chain (Decl); + while Is_Valid (Attr) loop + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Type (Attr)); + Create_Signal_Info (Block_Info, Attr); + Attr := Get_Attr_Chain (Attr); + end loop; + end; + + when Iir_Kind_Signal_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Signal_Info (Block_Info, Decl); + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Iterator_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl); + + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration (Decl) = Null_Iir + or else Get_Deferred_Declaration_Flag (Decl) + then + -- Create the slot only if the constant is not a full constant + -- declaration. + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl); + end if; + + when Iir_Kind_File_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl, Kind_File); + + when Iir_Kind_Terminal_Declaration => + Add_Terminal_Info (Block_Info, Decl); + when Iir_Kinds_Branch_Quantity_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Add_Quantity_Info (Block_Info, Decl); + + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Annotate_Type_Definition (Block_Info, Get_Type_Definition (Decl)); + when Iir_Kind_Subtype_Declaration => + Annotate_Type_Definition (Block_Info, Get_Type (Decl)); + + when Iir_Kind_Protected_Type_Body => + Annotate_Protected_Type_Body (Block_Info, Decl); + + when Iir_Kind_Component_Declaration => + Annotate_Component_Declaration (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Implicit_Definition (Decl) in Iir_Predefined_Explicit + and then not Is_Second_Subprogram_Specification (Decl) + then + Annotate_Subprogram_Interfaces_Type (Block_Info, Decl); + Annotate_Subprogram_Specification (Block_Info, Decl); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Annotate_Subprogram_Body (Block_Info, Decl); + + when Iir_Kind_Object_Alias_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Attribute_Specification => + declare + Value : Iir_Attribute_Value; + begin + Value := Get_Attribute_Value_Spec_Chain (Decl); + while Value /= Null_Iir loop + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Type (Value)); + Create_Object_Info (Block_Info, Value); + Value := Get_Spec_Chain (Value); + end loop; + end; + when Iir_Kind_Disconnection_Specification => + null; + + when Iir_Kind_Group_Template_Declaration => + null; + when Iir_Kind_Group_Declaration => + null; + when Iir_Kind_Use_Clause => + null; + + when Iir_Kind_Configuration_Specification => + null; + +-- when Iir_Kind_Implicit_Signal_Declaration => +-- declare +-- Nsig : Iir; +-- begin +-- Nsig := Decl; +-- loop +-- Nsig := Get_Implicit_Signal_Chain (Nsig); +-- exit when Nsig = Null_Iir; +-- Add_Signal_Info (Block_Info, Nsig); +-- end loop; +-- end; + + when Iir_Kind_Nature_Declaration => + null; + + when others => + Error_Kind ("annotate_declaration", Decl); + end case; + end Annotate_Declaration; + + procedure Annotate_Declaration_List + (Block_Info: Sim_Info_Acc; Decl_Chain: Iir) + is + El: Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + Annotate_Declaration (Block_Info, El); + El := Get_Chain (El); + end loop; + end Annotate_Declaration_List; + + procedure Annotate_Sequential_Statement_Chain + (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir) + is + El: Iir; + Max_Nbr_Objects : Object_Slot_Type; + Current_Nbr_Objects : Object_Slot_Type; + + procedure Save_Nbr_Objects is + begin + -- Objects used by loop statements can be reused later by + -- other (ie following) loop statements. + -- Furthermore, this allow to correctly check elaboration + -- order. + Max_Nbr_Objects := Object_Slot_Type'Max + (Block_Info.Nbr_Objects, Max_Nbr_Objects); + Block_Info.Nbr_Objects := Current_Nbr_Objects; + end Save_Nbr_Objects; + begin + Current_Nbr_Objects := Block_Info.Nbr_Objects; + Max_Nbr_Objects := Current_Nbr_Objects; + + El := Stmt_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Null_Statement => + null; + when Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement => + null; + when Iir_Kind_Return_Statement => + null; + when Iir_Kind_Simple_Signal_Assignment_Statement + | Iir_Kind_Variable_Assignment_Statement => + null; + when Iir_Kind_Procedure_Call_Statement => + null; + when Iir_Kind_Exit_Statement + | Iir_Kind_Next_Statement => + null; + when Iir_Kind_Wait_Statement => + null; + + when Iir_Kind_If_Statement => + declare + Clause: Iir := El; + begin + loop + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + exit when Clause = Null_Iir; + Save_Nbr_Objects; + end loop; + end; + + when Iir_Kind_Case_Statement => + declare + Assoc: Iir; + begin + Assoc := Get_Case_Statement_Alternative_Chain (El); + loop + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Associated_Chain (Assoc)); + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + Save_Nbr_Objects; + end loop; + end; + + when Iir_Kind_For_Loop_Statement => + Annotate_Declaration + (Block_Info, Get_Parameter_Specification (El)); + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (El)); + + when Iir_Kind_While_Loop_Statement => + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (El)); + + when others => + Error_Kind ("annotate_sequential_statement_chain", El); + end case; + + Save_Nbr_Objects; + + El := Get_Chain (El); + end loop; + Block_Info.Nbr_Objects := Max_Nbr_Objects; + end Annotate_Sequential_Statement_Chain; + + procedure Annotate_Block_Statement + (Block_Info : Sim_Info_Acc; Block : Iir_Block_Statement) + is + Info : Sim_Info_Acc; + Header : Iir_Block_Header; + Guard : Iir; + Prev_Scope : constant Scope_Type := Current_Scope; + begin + Increment_Current_Scope; + + Info := new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Block_Info.Nbr_Instances, + Frame_Scope => Current_Scope, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Block, Info); + + Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; + + Guard := Get_Guard_Decl (Block); + if Guard /= Null_Iir then + Create_Signal_Info (Info, Guard); + end if; + Header := Get_Block_Header (Block); + if Header /= Null_Iir then + Annotate_Interface_List (Info, Get_Generic_Chain (Header), True); + Annotate_Interface_List (Info, Get_Port_Chain (Header), True); + end if; + Annotate_Declaration_List (Info, Get_Declaration_Chain (Block)); + Annotate_Concurrent_Statements_List + (Info, Get_Concurrent_Statement_Chain (Block)); + + Current_Scope := Prev_Scope; + end Annotate_Block_Statement; + + procedure Annotate_Generate_Statement_Body + (Block_Info : Sim_Info_Acc; Bod : Iir; It : Iir) + is + Info : Sim_Info_Acc; + Prev_Scope : constant Scope_Type := Current_Scope; + begin + Increment_Current_Scope; + + Info := new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Block_Info.Nbr_Instances, + Frame_Scope => Current_Scope, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Bod, Info); + + Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; + + if It /= Null_Iir then + Annotate_Declaration (Info, It); + end if; + Annotate_Declaration_List (Info, Get_Declaration_Chain (Bod)); + Annotate_Concurrent_Statements_List + (Info, Get_Concurrent_Statement_Chain (Bod)); + + Current_Scope := Prev_Scope; + end Annotate_Generate_Statement_Body; + + procedure Annotate_If_Generate_Statement + (Block_Info : Sim_Info_Acc; Stmt : Iir) + is + Clause : Iir; + begin + Clause := Stmt; + while Clause /= Null_Iir loop + Annotate_Generate_Statement_Body + (Block_Info, Get_Generate_Statement_Body (Clause), Null_Iir); + Clause := Get_Generate_Else_Clause (Clause); + end loop; + end Annotate_If_Generate_Statement; + + procedure Annotate_For_Generate_Statement + (Block_Info : Sim_Info_Acc; Stmt : Iir) is + begin + Annotate_Generate_Statement_Body + (Block_Info, + Get_Generate_Statement_Body (Stmt), + Get_Parameter_Specification (Stmt)); + end Annotate_For_Generate_Statement; + + procedure Annotate_Component_Instantiation_Statement + (Block_Info : Sim_Info_Acc; Stmt : Iir) + is + Info: Sim_Info_Acc; + Prev_Scope : constant Scope_Type := Current_Scope; + begin + Increment_Current_Scope; + + -- Add a slot just to put the instance. + Info := new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Block_Info.Nbr_Instances, + Frame_Scope => Current_Scope, + Nbr_Objects => 0, + Nbr_Instances => 1); + Set_Info (Stmt, Info); + Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1; + + Current_Scope := Prev_Scope; + end Annotate_Component_Instantiation_Statement; + + procedure Annotate_Process_Statement (Block_Info : Sim_Info_Acc; Stmt : Iir) + is + pragma Unreferenced (Block_Info); + Prev_Scope : constant Scope_Type := Current_Scope; + Info : Sim_Info_Acc; + begin + Increment_Current_Scope; + + Info := new Sim_Info_Type'(Kind => Kind_Process, + Frame_Scope => Current_Scope, + Nbr_Objects => 0); + Set_Info (Stmt, Info); + + Annotate_Declaration_List + (Info, Get_Declaration_Chain (Stmt)); + Annotate_Sequential_Statement_Chain + (Info, Get_Sequential_Statement_Chain (Stmt)); + + Current_Scope := Prev_Scope; + end Annotate_Process_Statement; + + procedure Annotate_Concurrent_Statements_List + (Block_Info: Sim_Info_Acc; Stmt_Chain : Iir) + is + El : Iir; + begin + El := Stmt_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Annotate_Process_Statement (Block_Info, El); + + when Iir_Kind_Component_Instantiation_Statement => + Annotate_Component_Instantiation_Statement (Block_Info, El); + + when Iir_Kind_Block_Statement => + Annotate_Block_Statement (Block_Info, El); + + when Iir_Kind_If_Generate_Statement => + Annotate_If_Generate_Statement (Block_Info, El); + when Iir_Kind_For_Generate_Statement => + Annotate_For_Generate_Statement (Block_Info, El); + + when Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Declaration => + null; + + when Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Psl_Assert_Statement => + Create_Object_Info (Block_Info, El, Kind_PSL); + + when Iir_Kind_Simple_Simultaneous_Statement => + null; + + when Iir_Kind_Concurrent_Simple_Signal_Assignment => + -- In case concurrent signal assignemnts were not + -- canonicalized. + null; + + when others => + Error_Kind ("annotate_concurrent_statements_list", El); + end case; + El := Get_Chain (El); + end loop; + end Annotate_Concurrent_Statements_List; + + procedure Annotate_Entity (Decl: Iir_Entity_Declaration) + is + Entity_Info: Sim_Info_Acc; + begin + pragma Assert (Current_Scope.Kind = Scope_Kind_None); + Increment_Current_Scope; + + Entity_Info := + new Sim_Info_Type'(Kind => Kind_Block, + Inst_Slot => Invalid_Instance_Slot, + Frame_Scope => Current_Scope, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Decl, Entity_Info); + + -- generic list. + Annotate_Interface_List (Entity_Info, Get_Generic_Chain (Decl), True); + + -- Port list. + Annotate_Interface_List (Entity_Info, Get_Port_Chain (Decl), True); + + -- declarations + Annotate_Declaration_List (Entity_Info, Get_Declaration_Chain (Decl)); + + -- processes. + Annotate_Concurrent_Statements_List + (Entity_Info, Get_Concurrent_Statement_Chain (Decl)); + + Current_Scope := (Kind => Scope_Kind_None); + end Annotate_Entity; + + procedure Annotate_Architecture (Decl: Iir_Architecture_Body) + is + Entity_Info : constant Sim_Info_Acc := Get_Info (Get_Entity (Decl)); + Arch_Info: Sim_Info_Acc; + begin + pragma Assert (Current_Scope.Kind = Scope_Kind_None); + Current_Scope := Entity_Info.Frame_Scope; + + -- No blocks nor instantiation in entities. + pragma Assert (Entity_Info.Nbr_Instances = 0); + + Arch_Info := new Sim_Info_Type' + (Kind => Kind_Block, + Inst_Slot => 0, -- Slot for a component + Frame_Scope => Current_Scope, + Nbr_Objects => Entity_Info.Nbr_Objects, + Nbr_Instances => Entity_Info.Nbr_Instances); -- Should be 0. + Set_Info (Decl, Arch_Info); + + -- FIXME: annotate the default configuration for the arch ? + + -- declarations + Annotate_Declaration_List (Arch_Info, Get_Declaration_Chain (Decl)); + + -- processes. + Annotate_Concurrent_Statements_List + (Arch_Info, Get_Concurrent_Statement_Chain (Decl)); + + Current_Scope := (Kind => Scope_Kind_None); + end Annotate_Architecture; + + procedure Annotate_Package (Decl: Iir_Package_Declaration) + is + Prev_Scope : constant Scope_Type := Current_Scope; + Package_Info: Sim_Info_Acc; + Header : Iir; + begin + pragma Assert (Current_Scope.Kind = Scope_Kind_None); + + if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration + or else not Is_Uninstantiated_Package (Decl) + then + Nbr_Packages := Nbr_Packages + 1; + Current_Scope := (Scope_Kind_Package, Nbr_Packages); + else + Increment_Current_Scope; + end if; + + Package_Info := new Sim_Info_Type' + (Kind => Kind_Block, + Inst_Slot => Invalid_Instance_Slot, + Frame_Scope => Current_Scope, + Nbr_Objects => 0, + Nbr_Instances => 0); + + Set_Info (Decl, Package_Info); + + if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then + Annotate_Interface_List + (Package_Info, Get_Generic_Chain (Decl), True); + else + Header := Get_Package_Header (Decl); + if Header /= Null_Iir then + Annotate_Interface_List + (Package_Info, Get_Generic_Chain (Header), True); + end if; + end if; + -- declarations + Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl)); + + if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then + declare + Uninst : constant Iir := Get_Uninstantiated_Package_Decl (Decl); + Uninst_Info : constant Sim_Info_Acc := Get_Info (Uninst); + begin + -- There is not corresponding body for an instantiation, so + -- also add objects for the shared body. + Package_Info.Nbr_Objects := Uninst_Info.Nbr_Objects; + end; + end if; + + Current_Scope := Prev_Scope; + end Annotate_Package; + + procedure Annotate_Package_Body (Decl: Iir) + is + Package_Info: Sim_Info_Acc; + begin + pragma Assert (Current_Scope.Kind = Scope_Kind_None); + + -- Set info field of package body declaration. + Package_Info := Get_Info (Get_Package (Decl)); + Set_Info (Decl, Package_Info); + + Current_Scope := Package_Info.Frame_Scope; + + -- declarations + Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl)); + + Current_Scope := (Kind => Scope_Kind_None); + end Annotate_Package_Body; + + procedure Annotate_Component_Configuration + (Conf : Iir_Component_Configuration) + is + Block : constant Iir := Get_Block_Configuration (Conf); + begin + Annotate_Block_Configuration (Block); + end Annotate_Component_Configuration; + + procedure Annotate_Block_Configuration (Block : Iir_Block_Configuration) + is + El : Iir; + begin + if Block = Null_Iir then + return; + end if; + + -- Declaration are use_clause only. + El := Get_Configuration_Item_Chain (Block); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Block_Configuration => + Annotate_Block_Configuration (El); + when Iir_Kind_Component_Configuration => + Annotate_Component_Configuration (El); + when others => + Error_Kind ("annotate_block_configuration", El); + end case; + El := Get_Chain (El); + end loop; + end Annotate_Block_Configuration; + + procedure Annotate_Configuration_Declaration + (Decl : Iir_Configuration_Declaration) + is + Config_Info: Sim_Info_Acc; + begin + pragma Assert (Current_Scope.Kind = Scope_Kind_None); + + Nbr_Packages := Nbr_Packages + 1; + Current_Scope := (Scope_Kind_Package, Nbr_Packages); + + Config_Info := new Sim_Info_Type' + (Kind => Kind_Block, + Inst_Slot => Invalid_Instance_Slot, + Frame_Scope => Current_Scope, + Nbr_Objects => 0, + Nbr_Instances => 0); + + Set_Info (Decl, Config_Info); + + Annotate_Declaration_List (Config_Info, Get_Declaration_Chain (Decl)); + Annotate_Block_Configuration (Get_Block_Configuration (Decl)); + + Current_Scope := (Kind => Scope_Kind_None); + end Annotate_Configuration_Declaration; + + package Info_Node is new Tables + (Table_Component_Type => Sim_Info_Acc, + Table_Index_Type => Iir, + Table_Low_Bound => 2, + Table_Initial => 1024); + + procedure Annotate_Expand_Table + is + El: Iir; + begin + Info_Node.Increment_Last; + El := Info_Node.Last; + Info_Node.Set_Last (Get_Last_Node); + for I in El .. Info_Node.Last loop + Info_Node.Table (I) := null; + end loop; + end Annotate_Expand_Table; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Annotate (Unit : Iir_Design_Unit) + is + El : constant Iir := Get_Library_Unit (Unit); + begin + -- Expand info table. + Annotate_Expand_Table; + + case Get_Kind (El) is + when Iir_Kind_Entity_Declaration => + Annotate_Entity (El); + when Iir_Kind_Architecture_Body => + Annotate_Architecture (El); + when Iir_Kind_Package_Declaration => + Annotate_Package (El); + declare + use Std_Package; + begin + if El = Standard_Package then + -- These types are not in std.standard! + Annotate_Type_Definition + (Get_Info (El), Convertible_Integer_Type_Definition); + Annotate_Type_Definition + (Get_Info (El), Convertible_Real_Type_Definition); + end if; + end; + when Iir_Kind_Package_Body => + Annotate_Package_Body (El); + when Iir_Kind_Configuration_Declaration => + Annotate_Configuration_Declaration (El); + when Iir_Kind_Package_Instantiation_Declaration => + Annotate_Package (El); + when Iir_Kind_Context_Declaration => + null; + when others => + Error_Kind ("annotate2", El); + end case; + end Annotate; + + function Image (Scope : Scope_Type) return String is + begin + case Scope.Kind is + when Scope_Kind_None => + return "none"; + when Scope_Kind_Component => + return "component"; + when Scope_Kind_Frame => + return "frame" & Scope_Depth_Type'Image (Scope.Depth); + when Scope_Kind_Package => + return "package" & Pkg_Index_Type'Image (Scope.Pkg_Index); + when Scope_Kind_Pkg_Inst => + return "pkg inst" & Parameter_Slot_Type'Image (Scope.Pkg_Param); + end case; + end Image; + + -- Disp annotations for an iir node. + procedure Disp_Vhdl_Info (Node: Iir) is + use Ada.Text_IO; + Info : constant Sim_Info_Acc := Get_Info (Node); + Indent : Count; + begin + if Info = null then + return; + end if; + + Indent := Col; + case Info.Kind is + when Kind_Block => + Put_Line + ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects)); + + when Kind_Frame | Kind_Process => + Put_Line ("-- scope:" & Image (Info.Frame_Scope)); + Set_Col (Indent); + Put_Line + ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects)); + + when Kind_Object | Kind_Signal | Kind_File + | Kind_Terminal + | Kind_Quantity + | Kind_Environment + | Kind_PSL => + Put_Line ("-- slot:" & Object_Slot_Type'Image (Info.Slot) + & ", scope:" & Image (Info.Obj_Scope)); + when Kind_Scalar_Type + | Kind_File_Type + | Kind_Extra => + null; + end case; + end Disp_Vhdl_Info; + + procedure Disp_Info (Info : Sim_Info_Acc) + is + use Ada.Text_IO; + Indent: Count; + begin + Indent := Col + 2; + Set_Col (Indent); + if Info = null then + Put_Line ("*null*"); + return; + end if; + case Info.Kind is + when Kind_Block | Kind_Frame | Kind_Process => + Put_Line ("scope:" & Image (Info.Frame_Scope)); + Set_Col (Indent); + Put_Line ("inst_slot:" + & Instance_Slot_Type'Image (Info.Inst_Slot)); + Set_Col (Indent); + Put_Line ("nbr objects:" + & Object_Slot_Type'Image (Info.Nbr_Objects)); + Set_Col (Indent); + Put_Line ("nbr instance:" + & Instance_Slot_Type'Image (Info.Nbr_Instances)); + when Kind_Object | Kind_Signal | Kind_File + | Kind_Terminal | Kind_Quantity | Kind_Environment + | Kind_PSL => + Put_Line ("slot:" & Object_Slot_Type'Image (Info.Slot) + & ", scope:" & Image (Info.Obj_Scope)); + when Kind_Extra => + Put_Line ("extra:" & Extra_Slot_Type'Image (Info.Extra_Slot)); + when Kind_Scalar_Type => + Put_Line ("scalar type: " + & Iir_Value_Kind'Image (Info.Scalar_Mode)); + when Kind_File_Type => + Put ("file type: "); + if Info.File_Signature = null then + Put ("(no sig)"); + else + Put (Info.File_Signature.all); + end if; + New_Line; + end case; + end Disp_Info; + + procedure Disp_Tree_Info (Node: Iir) is + begin + Disp_Info (Get_Info (Node)); + end Disp_Tree_Info; + + procedure Set_Info (Target: Iir; Info: Sim_Info_Acc) is + begin + pragma Assert (Info_Node.Table (Target) = null); + Info_Node.Table (Target) := Info; + end Set_Info; + + function Get_Info (Target: Iir) return Sim_Info_Acc is + begin + return Info_Node.Table (Target); + end Get_Info; +end Simul.Annotations; diff --git a/src/vhdl/simulate/simul-annotations.ads b/src/vhdl/simulate/simul-annotations.ads new file mode 100644 index 000000000..46b38d674 --- /dev/null +++ b/src/vhdl/simulate/simul-annotations.ads @@ -0,0 +1,120 @@ +-- Annotations for 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 Iirs; use Iirs; +with Simul.Environments; use Simul.Environments; +with Types; use Types; + +package Simul.Annotations is + -- Decorate the tree in order to be usable with the internal simulator. + procedure Annotate (Unit : Iir_Design_Unit); + + -- Disp annotations for an iir node. + procedure Disp_Vhdl_Info (Node : Iir); + procedure Disp_Tree_Info (Node : Iir); + + -- For Kind_Extra: a number. Kind_Extra is not used by annotations, and + -- is free for another pass like preelab. + type Extra_Slot_Type is new Natural; + + Nbr_Packages : Pkg_Index_Type := 0; + + -- Annotations are used to collect informations for elaboration and to + -- locate iir_value_literal for signals, variables or constants. + + -- The annotation depends on the kind of the node. + type Sim_Info_Kind is + (Kind_Block, Kind_Process, Kind_Frame, + Kind_Scalar_Type, Kind_File_Type, + Kind_Object, Kind_Signal, + Kind_File, + Kind_Terminal, Kind_Quantity, + Kind_Environment, + Kind_PSL, + Kind_Extra); + + type Sim_Info_Type (Kind : Sim_Info_Kind); + type Sim_Info_Acc is access all Sim_Info_Type; + + type Instance_Slot_Type is new Integer; + Invalid_Instance_Slot : constant Instance_Slot_Type := -1; + + -- Annotation for an iir node in order to be able to simulate it. + type Sim_Info_Type (Kind: Sim_Info_Kind) is record + case Kind is + when Kind_Block + | Kind_Frame + | Kind_Process + | Kind_Environment => + -- Scope level for this frame. + Frame_Scope : Scope_Type; + + -- Number of objects/signals. + Nbr_Objects : Object_Slot_Type; + + case Kind is + when Kind_Block => + -- Slot number in the parent (for blocks). + Inst_Slot : Instance_Slot_Type; + + -- Number of children (blocks, generate, instantiation). + Nbr_Instances : Instance_Slot_Type; + + when Kind_Environment => + Env_Slot : Object_Slot_Type; + + when others => + null; + end case; + + when Kind_Object + | Kind_Signal + | Kind_File + | Kind_Terminal + | Kind_Quantity + | Kind_PSL => + -- Block in which this object is declared in. + Obj_Scope : Scope_Type; + + -- Variable index in the block. + Slot: Object_Slot_Type; + + when Kind_Scalar_Type => + Scalar_Mode : Iir_Value_Kind; + + when Kind_File_Type => + File_Signature : String_Acc; + + when Kind_Extra => + Extra_Slot : Extra_Slot_Type; + end case; + end record; + + -- Get/Set annotation fied from/to an iir. + procedure Set_Info (Target : Iir; Info : Sim_Info_Acc); + pragma Inline (Set_Info); + function Get_Info (Target : Iir) return Sim_Info_Acc; + pragma Inline (Get_Info); + + -- Expand the annotation table. This is automatically done by Annotate, + -- to be used only by debugger. + procedure Annotate_Expand_Table; + + -- For debugging. + function Image (Scope : Scope_Type) return String; +end Simul.Annotations; diff --git a/src/vhdl/simulate/simul-debugger-ams.adb b/src/vhdl/simulate/simul-debugger-ams.adb new file mode 100644 index 000000000..2c7c86316 --- /dev/null +++ b/src/vhdl/simulate/simul-debugger-ams.adb @@ -0,0 +1,85 @@ +-- Interpreter AMS 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 Iirs_Utils; use Iirs_Utils; +with Ada.Text_IO; use Ada.Text_IO; +with Disp_Vhdl; + +package body Simul.Debugger.AMS is + procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type) + is + Obj : Scalar_Quantity renames Scalar_Quantities.Table (Quantity); + begin + Disp_Instance_Name (Obj.Instance, True); + Put ('.'); + Put (Image_Identifier (Obj.Decl)); + if Obj.Kind = Quantity_Reference then + Put ("'Ref"); + end if; + end Disp_Quantity_Name; + + procedure Disp_Term (Term : Ams_Term_Acc) is + begin + case Term.Sign is + when Op_Plus => + Put (" + "); + when Op_Minus => + Put (" - "); + end case; + + case Term.Op is + when Op_Quantity => + Disp_Quantity_Name (Term.Quantity); + when Op_Vhdl_Expr => + Disp_Vhdl.Disp_Expression (Term.Vhdl_Expr); + end case; + end Disp_Term; + + procedure Disp_Characteristic_Expression + (Ce : Characteristic_Expressions_Index) + is + Obj : Characteristic_Expr renames + Characteristic_Expressions.Table (Ce); + Expr : Ams_Term_Acc := Obj.Expr; + begin + case Obj.Kind is + when Explicit => + Put ("Explic:"); + when Contribution => + Put ("Contri:"); + when Structural => + Put ("Struct:"); + end case; + + while Expr /= null loop + Disp_Term (Expr); + Expr := Expr.Next; + end loop; + New_Line; + end Disp_Characteristic_Expression; + + procedure Disp_Characteristic_Expressions is + begin + Put_Line ("Characteristic expressions:"); + for I in Characteristic_Expressions.First + .. Characteristic_Expressions.Last + loop + Disp_Characteristic_Expression (I); + end loop; + end Disp_Characteristic_Expressions; +end Simul.Debugger.AMS; diff --git a/src/vhdl/simulate/simul-debugger-ams.ads b/src/vhdl/simulate/simul-debugger-ams.ads new file mode 100644 index 000000000..43c094d9c --- /dev/null +++ b/src/vhdl/simulate/simul-debugger-ams.ads @@ -0,0 +1,28 @@ +-- Interpreter AMS 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 Simul.Elaboration.AMS; use Simul.Elaboration.AMS; + +package Simul.Debugger.AMS is + procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type); + + procedure Disp_Characteristic_Expression + (Ce : Characteristic_Expressions_Index); + + procedure Disp_Characteristic_Expressions; +end Simul.Debugger.AMS; diff --git a/src/vhdl/simulate/simul-debugger.adb b/src/vhdl/simulate/simul-debugger.adb new file mode 100644 index 000000000..105b16e81 --- /dev/null +++ b/src/vhdl/simulate/simul-debugger.adb @@ -0,0 +1,2283 @@ +-- Debugger for interpreter +-- 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 System; +with Ada.Text_IO; use Ada.Text_IO; +with Tables; +with Types; use Types; +with Name_Table; +with Str_Table; +with Files_Map; +with Parse; +with Scanner; +with Tokens; +with Sem_Expr; +with Sem_Scopes; +with Canon; +with Std_Names; +with Libraries; +with Std_Package; +with Simul.Annotations; use Simul.Annotations; +with Simul.Elaboration; use Simul.Elaboration; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Disp_Vhdl; +with Simul.Execution; use Simul.Execution; +with Iirs_Walk; use Iirs_Walk; +with Areapools; use Areapools; +with Grt.Types; +with Grt.Disp; +with Grt.Readline; +with Grt.Errors; +with Grt.Disp_Signals; + +package body Simul.Debugger is + -- This exception can be raised by a debugger command to directly return + -- to the prompt. + Command_Error : exception; + + type Menu_Procedure is access procedure (Line : String); + + -- If set (by commands), call this procedure on empty line to repeat + -- last command. + Cmd_Repeat : Menu_Procedure; + + -- For the list command: current file and current line. + List_Current_File : Source_File_Entry := No_Source_File_Entry; + List_Current_Line : Natural := 0; + List_Current_Line_Pos : Source_Ptr := 0; + + -- Set List_Current_* from a location. To be called after program break + -- to indicate current location. + procedure Set_List_Current (Loc : Location_Type) + is + Offset : Natural; + begin + Files_Map.Location_To_Coord + (Loc, List_Current_File, List_Current_Line_Pos, + List_Current_Line, Offset); + end Set_List_Current; + + Dbg_Top_Frame : Block_Instance_Acc; + Dbg_Cur_Frame : Block_Instance_Acc; + + procedure Set_Cur_Frame (Frame : Block_Instance_Acc) is + begin + Dbg_Cur_Frame := Frame; + end Set_Cur_Frame; + + procedure Set_Top_Frame (Frame : Block_Instance_Acc) is + begin + Dbg_Top_Frame := Frame; + Set_Cur_Frame (Frame); + end Set_Top_Frame; + + type Breakpoint_Entry is record + Stmt : Iir; + end record; + + package Breakpoints is new Tables + (Table_Index_Type => Natural, + Table_Component_Type => Breakpoint_Entry, + Table_Low_Bound => 1, + Table_Initial => 16); + + -- Current execution state, or reason to stop execution (set by the + -- last debugger command). + type Exec_State_Type is + (-- Execution should continue until a breakpoint is reached or assertion + -- failure. + Exec_Run, + + -- Execution will stop at the next statement. + Exec_Single_Step, + + -- Execution will stop at the next simple statement in the same frame. + Exec_Next, + + -- Execution will stop at the next statement in the same frame. In + -- case of compound statement, stop after the compound statement. + Exec_Next_Stmt); + + Exec_State : Exec_State_Type := Exec_Run; + + -- Current frame for next. + Exec_Instance : Block_Instance_Acc; + + -- Current statement for next_stmt. + Exec_Statement : Iir; + + procedure Disp_Iir_Location (N : Iir) is + begin + if N = Null_Iir then + Put (Standard_Error, "??:??:??"); + else + Put (Standard_Error, Disp_Location (N)); + end if; + Put (Standard_Error, ": "); + end Disp_Iir_Location; + + -- Disp a message during execution. + procedure Error_Msg_Exec (Msg: String; Loc: in Iir) is + begin + Disp_Iir_Location (Loc); + Put_Line (Standard_Error, Msg); + Grt.Errors.Fatal_Error; + end Error_Msg_Exec; + + procedure Warning_Msg_Exec (Msg: String; Loc: Iir) is + begin + Disp_Iir_Location (Loc); + Put (Standard_Error, "warning: "); + Put_Line (Standard_Error, Msg); + end Warning_Msg_Exec; + + -- Disp a message for a constraint error. + procedure Error_Msg_Constraint (Expr: in Iir) is + begin + if Expr /= Null_Iir then + Disp_Iir_Location (Expr); + end if; + Put (Standard_Error, "constraint violation"); + if Expr /= Null_Iir then + case Get_Kind (Expr) is + when Iir_Kind_Addition_Operator => + Put_Line (Standard_Error, " in the ""+"" operation"); + when Iir_Kind_Substraction_Operator => + Put_Line (Standard_Error, " in the ""-"" operation"); + when Iir_Kind_Integer_Literal => + Put_Line (Standard_Error, ", literal out of range"); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration => + Put_Line (Standard_Error, " for " & Disp_Node (Expr)); + when others => + New_Line (Standard_Error); + end case; + end if; + Grt.Errors.Fatal_Error; + end Error_Msg_Constraint; + + function Get_Instance_Local_Name (Instance : Block_Instance_Acc; + Short : Boolean := False) + return String + is + Name : constant Iir := Instance.Label; + begin + if Name = Null_Iir then + return ""; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Block_Statement + | Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Procedure_Declaration + | Iir_Kinds_Process_Statement + | Iir_Kind_Package_Declaration + | Iir_Kind_Configuration_Declaration => + return Image_Identifier (Name); + when Iir_Kind_Generate_Statement_Body => + return Image_Identifier (Get_Parent (Name)) + & '(' & Image_Identifier (Name) & ')'; + when Iir_Kind_Iterator_Declaration => + return Image_Identifier (Get_Parent (Name)) & '(' + & Execute_Image_Attribute + (Instance.Objects (Get_Info (Name).Slot), Get_Type (Name)) + & ')'; + when Iir_Kind_Architecture_Body => + if Short then + return Image_Identifier (Get_Entity (Name)); + else + return Image_Identifier (Get_Entity (Name)) + & '(' & Image_Identifier (Name) & ')'; + end if; + when others => + Error_Kind ("disp_instance_local_name", Name); + end case; + end Get_Instance_Local_Name; + + -- Disp the name of an instance, without newline. + procedure Disp_Instance_Name (Instance: Block_Instance_Acc; + Short : Boolean := False) is + begin + if Instance.Parent /= null then + Disp_Instance_Name (Instance.Parent); + Put ('.'); + end if; + Put (Get_Instance_Local_Name (Instance, Short)); + end Disp_Instance_Name; + + function Get_Instance_Name (Instance: Block_Instance_Acc) return String + is + function Parent_Name return String is + begin + if Instance.Parent /= null then + return Get_Instance_Name (Instance.Parent) & '.'; + else + return ""; + end if; + end Parent_Name; + begin + return Parent_Name & Get_Instance_Local_Name (Instance); + end Get_Instance_Name; + + procedure Disp_Instances_Tree_Name (Inst : Block_Instance_Acc) is + begin + if Inst = null then + Put ("*null*"); + New_Line; + return; + end if; + Put (Get_Instance_Local_Name (Inst)); + + Put (" "); + case Get_Kind (Inst.Label) is + when Iir_Kind_Block_Statement => + Put ("[block]"); + when Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement + | Iir_Kind_Generate_Statement_Body => + Put ("[generate]"); + when Iir_Kind_Iterator_Declaration => + Put ("[iterator]"); + when Iir_Kind_Component_Instantiation_Statement => + Put ("[component]"); + when Iir_Kinds_Process_Statement => + Put ("[process]"); + when Iir_Kind_Architecture_Body => + Put ("[entity]"); + when Iir_Kind_Package_Declaration => + Put ("[package]"); + when Iir_Kind_Configuration_Declaration => + Put ("[configuration]"); + when others => + Error_Kind ("disp_instances_tree_name", Inst.Label); + end case; + New_Line; + end Disp_Instances_Tree_Name; + + procedure Disp_Instances_Tree1 (Inst : Block_Instance_Acc; Pfx : String) + is + Child : Block_Instance_Acc; + begin + Child := Inst.Children; + if Child = null then + return; + end if; + + loop + if Child.Brother /= null then + Put (Pfx & "+-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & "| "); + Child := Child.Brother; + else + Put (Pfx & "`-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & " "); + exit; + end if; + end loop; + end Disp_Instances_Tree1; + + procedure Disp_Instances_Tree is + begin + for I in Package_Instances'Range loop + if Package_Instances (I) /= null then + Disp_Instances_Tree_Name (Package_Instances (I)); + end if; + end loop; + Disp_Instances_Tree_Name (Top_Instance); + Disp_Instances_Tree1 (Top_Instance, ""); + end Disp_Instances_Tree; + + -- Disp a block instance, in a human readable way. + -- Used to debug. + procedure Disp_Block_Instance (Instance: Block_Instance_Acc) is + begin + Put_Line ("scope:" & Image (Instance.Block_Scope)); + Put_Line ("Objects:"); + for I in Instance.Objects'Range loop + Put (Object_Slot_Type'Image (I) & ": "); + Disp_Value_Tab (Instance.Objects (I), 3); + New_Line; + end loop; + end Disp_Block_Instance; + + procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir); + + procedure Disp_Signal_Array (Value : Iir_Value_Literal_Acc; + A_Type : Iir; + Dim : Natural) + is + begin + if Dim = Get_Nbr_Elements (Get_Index_Subtype_List (A_Type)) then + Put ("("); + for I in Value.Val_Array.V'Range loop + if I /= 1 then + Put (", "); + end if; + Disp_Signal (Value.Val_Array.V (I), Get_Element_Subtype (A_Type)); + end loop; + Put (")"); + else + Put ("("); + Disp_Signal_Array (Value, A_Type, Dim + 1); + Put (")"); + end if; + end Disp_Signal_Array; + + procedure Disp_Signal_Record (Value : Iir_Value_Literal_Acc; A_Type : Iir) + is + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (A_Type)); + El : Iir_Element_Declaration; + begin + Put ("("); + for I in Value.Val_Record.V'Range loop + El := Get_Nth_Element (List, Natural (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Name_Table.Image (Get_Identifier (El))); + Put (" => "); + Disp_Signal (Value.Val_Record.V (I), Get_Type (El)); + end loop; + Put (")"); + end Disp_Signal_Record; + + procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir) is + begin + if Value = null then + Put ("!NULL!"); + return; + end if; + case Value.Kind is + when Iir_Value_Scalars + | Iir_Value_Access => + Disp_Iir_Value (Value, A_Type); + when Iir_Value_Array => + Disp_Signal_Array (Value, A_Type, 1); + when Iir_Value_Record => + Disp_Signal_Record (Value, A_Type); + when Iir_Value_Range => + -- FIXME. + raise Internal_Error; + when Iir_Value_Signal => + Grt.Disp_Signals.Disp_A_Signal (Value.Sig); + when Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Disp_Signal; + + procedure Disp_Instance_Signal (Instance: Block_Instance_Acc; Decl : Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Put (" "); + Put (Name_Table.Image (Get_Identifier (Decl))); + Put (" = "); + Disp_Signal (Instance.Objects (Info.Slot), Get_Type (Decl)); + end Disp_Instance_Signal; + + procedure Disp_Instance_Signals_Of_Chain (Instance: Block_Instance_Acc; + Chain : Iir) + is + El : Iir; + begin + El := Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Disp_Instance_Signal (Instance, El); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Disp_Instance_Signals_Of_Chain; + + procedure Disp_Instance_Signals (Instance: Block_Instance_Acc) + is + Blk : constant Iir := Instance.Label; + Child: Block_Instance_Acc; + begin + case Get_Kind (Blk) is + when Iir_Kind_Architecture_Body => + declare + Ent : constant Iir := Get_Entity (Blk); + begin + Disp_Instance_Name (Instance); + Put_Line (" [architecture]:"); + + Disp_Instance_Signals_Of_Chain + (Instance, Get_Port_Chain (Ent)); + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Ent)); + end; + when Iir_Kind_Block_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [block]:"); + + -- FIXME: ports. + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + + when Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [generate]:"); + + when Iir_Kind_Generate_Statement_Body => + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + when Iir_Kind_Component_Instantiation_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [component]:"); + Disp_Instance_Signals_Of_Chain + (Instance, Get_Port_Chain (Instance.Stmt)); + when Iir_Kinds_Process_Statement => + null; + when Iir_Kind_Iterator_Declaration => + null; + when others => + Error_Kind ("disp_instance_signals", Instance.Label); + end case; + + Child := Instance.Children; + while Child /= null loop + Disp_Instance_Signals (Child); + Child := Child.Brother; + end loop; + end Disp_Instance_Signals; + + -- Disp all signals name and values. + procedure Disp_Signals_Value is + begin + if Disp_Time_Before_Values then + Grt.Disp.Disp_Now; + end if; + Disp_Instance_Signals (Top_Instance); + end Disp_Signals_Value; + + procedure Disp_Label (Process : Iir) + is + Label : Name_Id; + begin + Label := Get_Label (Process); + if Label = Null_Identifier then + Put (""); + else + Put (Name_Table.Image (Label)); + end if; + end Disp_Label; + + procedure Disp_Declaration_Object + (Instance : Block_Instance_Acc; Decl : Iir) is + begin + case Get_Kind (Decl) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Object_Alias_Declaration => + Put (Disp_Node (Decl)); + Put (" = "); + Disp_Value_Tab (Instance.Objects (Get_Info (Decl).Slot), 3); + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration => + declare + Sig : Iir_Value_Literal_Acc; + begin + Sig := Instance.Objects (Get_Info (Decl).Slot); + Put (Disp_Node (Decl)); + Put (" = "); + Disp_Signal (Sig, Get_Type (Decl)); + New_Line; + end; + when Iir_Kinds_Signal_Attribute => + -- FIXME: todo ? + null; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + -- FIXME: disp ranges + null; + when others => + Error_Kind ("disp_declaration_object", Decl); + end case; + end Disp_Declaration_Object; + + procedure Disp_Declaration_Objects + (Instance : Block_Instance_Acc; Decl_Chain : Iir) + is + El : Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + Disp_Declaration_Object (Instance, El); + El := Get_Chain (El); + end loop; + end Disp_Declaration_Objects; + + procedure Disp_Objects (Instance : Block_Instance_Acc) + is + Decl : constant Iir := Instance.Label; + begin + Disp_Instance_Name (Instance); + New_Line; + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + Disp_Declaration_Objects + (Instance, Get_Interface_Declaration_Chain (Decl)); + Disp_Declaration_Objects + (Instance, + Get_Declaration_Chain (Get_Subprogram_Body (Decl))); + when Iir_Kind_Architecture_Body => + declare + Entity : constant Iir_Entity_Declaration := Get_Entity (Decl); + begin + Disp_Declaration_Objects + (Instance, Get_Generic_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Port_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Decl)); + -- FIXME: processes. + end; + when Iir_Kind_Component_Instantiation_Statement => + null; + when others => + Error_Kind ("disp_objects", Decl); + end case; + end Disp_Objects; + pragma Unreferenced (Disp_Objects); + + procedure Disp_Process_Stats + is + Proc : Iir; + Stmt : Iir; + Nbr_User_Sensitized_Processes : Natural := 0; + Nbr_User_If_Sensitized_Processes : Natural := 0; + Nbr_Conc_Sensitized_Processes : Natural := 0; + Nbr_User_Non_Sensitized_Processes : Natural := 0; + Nbr_Conc_Non_Sensitized_Processes : Natural := 0; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Proc := Processes_Table.Table (I).Label; + case Get_Kind (Proc) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Stmt := Get_Sequential_Statement_Chain (Proc); + if Stmt /= Null_Iir + and then Get_Kind (Stmt) = Iir_Kind_If_Statement + and then Get_Chain (Stmt) = Null_Iir + then + Nbr_User_If_Sensitized_Processes := + Nbr_User_If_Sensitized_Processes + 1; + else + Nbr_User_Sensitized_Processes := + Nbr_User_Sensitized_Processes + 1; + end if; + else + Nbr_Conc_Sensitized_Processes := + Nbr_Conc_Sensitized_Processes + 1; + end if; + when Iir_Kind_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Nbr_User_Non_Sensitized_Processes := + Nbr_User_Non_Sensitized_Processes + 1; + else + Nbr_Conc_Non_Sensitized_Processes := + Nbr_Conc_Non_Sensitized_Processes + 1; + end if; + when others => + raise Internal_Error; + end case; + end loop; + + Put (Natural'Image (Nbr_User_If_Sensitized_Processes)); + Put_Line (" user sensitized processes with only a if stmt"); + Put (Natural'Image (Nbr_User_Sensitized_Processes)); + Put_Line (" user sensitized processes (others)"); + Put (Natural'Image (Nbr_User_Non_Sensitized_Processes)); + Put_Line (" user non sensitized processes"); + Put (Natural'Image (Nbr_Conc_Sensitized_Processes)); + Put_Line (" sensitized concurrent statements"); + Put (Natural'Image (Nbr_Conc_Non_Sensitized_Processes)); + Put_Line (" non sensitized concurrent statements"); + Put (Process_Index_Type'Image (Processes_Table.Last)); + Put_Line (" processes (total)"); + end Disp_Process_Stats; + + procedure Disp_Signals_Stats + is + use Grt.Types; + type Counters_Type is array (Mode_Signal_Type) of Natural; + Counters : Counters_Type := (others => 0); + Nbr_User_Signals : Natural := 0; + Nbr_Signal_Elements : Natural := 0; + begin + for I in Signals_Table.First .. Signals_Table.Last loop + declare + Ent : Signal_Entry renames Signals_Table.Table (I); + begin + if Ent.Kind in Mode_Signal_User then + Nbr_User_Signals := Nbr_User_Signals + 1; + Nbr_Signal_Elements := Nbr_Signal_Elements + + Get_Nbr_Of_Scalars (Signals_Table.Table (I).Sig); + end if; + Counters (Ent.Kind) := Counters (Ent.Kind) + 1; + end; + end loop; + Put (Integer'Image (Nbr_User_Signals)); + Put_Line (" declared user signals or ports"); + Put (Integer'Image (Nbr_Signal_Elements)); + Put_Line (" user signals sub-elements"); + Put (Integer'Image (Counters (Mode_Quiet))); + Put_Line (" 'quiet implicit signals"); + Put (Integer'Image (Counters (Mode_Stable))); + Put_Line (" 'stable implicit signals"); + Put (Integer'Image (Counters (Mode_Delayed))); + Put_Line (" 'delayed implicit signals"); + Put (Integer'Image (Counters (Mode_Transaction))); + Put_Line (" 'transaction implicit signals"); + Put (Integer'Image (Counters (Mode_Guard))); + Put_Line (" guard signals"); + end Disp_Signals_Stats; + + procedure Disp_Design_Stats is + begin + Disp_Process_Stats; + + New_Line; + + Disp_Signals_Stats; + + New_Line; + + Put (Integer'Image (Connect_Table.Last)); + Put_Line (" connections"); + end Disp_Design_Stats; + + procedure Disp_Design_Non_Sensitized + is + Instance : Block_Instance_Acc; + Proc : Iir; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Instance := Processes_Table.Table (I); + Proc := Processes_Table.Table (I).Label; + if Get_Kind (Proc) = Iir_Kind_Process_Statement then + Disp_Instance_Name (Instance); + New_Line; + Put_Line (" at " & Disp_Location (Proc)); + end if; + end loop; + end Disp_Design_Non_Sensitized; + + procedure Disp_Design_Connections is + begin + for I in Connect_Table.First .. Connect_Table.Last loop + declare + Conn : Connect_Entry renames Connect_Table.Table (I); + begin + Disp_Iir_Location (Conn.Assoc); + New_Line; + end; + end loop; + end Disp_Design_Connections; + + function Walk_Files (Cb : Walk_Cb) return Walk_Status + is + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + File : Iir_Design_File; + begin + while Lib /= Null_Iir loop + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + case Cb.all (File) is + when Walk_Continue => + null; + when Walk_Up => + exit; + when Walk_Abort => + return Walk_Abort; + end case; + File := Get_Chain (File); + end loop; + Lib := Get_Chain (Lib); + end loop; + return Walk_Continue; + end Walk_Files; + + Walk_Units_Cb : Walk_Cb; + + function Cb_Walk_Units (Design_File : Iir) return Walk_Status + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is + when Walk_Continue => + null; + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + exit; + end case; + Unit := Get_Chain (Unit); + end loop; + return Walk_Continue; + end Cb_Walk_Units; + + function Walk_Units (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Units_Cb := Cb; + return Walk_Files (Cb_Walk_Units'Access); + end Walk_Units; + + Walk_Declarations_Cb : Walk_Cb; + + function Cb_Walk_Declarations (Unit : Iir) return Walk_Status + is + function Walk_Decl_Chain (Chain : Iir) return Walk_Status + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Walk_Declarations_Cb.all (Decl) is + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + return Walk_Continue; + when Walk_Continue => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return Walk_Continue; + end Walk_Decl_Chain; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status; + + function Walk_Generate_Statement_Body (Bod : Iir) return Walk_Status is + begin + if Walk_Decl_Chain (Get_Declaration_Chain (Bod)) = Walk_Abort then + return Walk_Abort; + end if; + if Walk_Conc_Chain (Get_Concurrent_Statement_Chain (Bod)) = Walk_Abort + then + return Walk_Abort; + end if; + return Walk_Continue; + end Walk_Generate_Statement_Body; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status + is + Stmt : Iir := Chain; + begin + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kinds_Process_Statement => + if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) + = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_For_Generate_Statement => + if Walk_Declarations_Cb.all + (Get_Parameter_Specification (Stmt)) = Walk_Abort + or else Walk_Generate_Statement_Body + (Get_Generate_Statement_Body (Stmt)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_If_Generate_Statement => + declare + Stmt1 : Iir; + begin + Stmt1 := Stmt; + while Stmt1 /= Null_Iir loop + if Walk_Generate_Statement_Body + (Get_Generate_Statement_Body (Stmt)) = Walk_Abort + then + return Walk_Abort; + end if; + Stmt1 := Get_Generate_Else_Clause (Stmt1); + end loop; + end; + when Iir_Kind_Component_Instantiation_Statement => + null; + when Iir_Kind_Block_Statement => + -- FIXME: header + if (Walk_Decl_Chain + (Get_Declaration_Chain (Stmt)) = Walk_Abort) + or else + (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Stmt)) = Walk_Abort) + then + return Walk_Abort; + end if; + when others => + Error_Kind ("walk_conc_chain", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + return Walk_Continue; + end Walk_Conc_Chain; + begin + case Get_Kind (Unit) is + when Iir_Kind_Entity_Declaration => + if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort + or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort + or else (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Architecture_Body => + if (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_Configuration_Declaration => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + -- FIXME: block configuration ? + when Iir_Kind_Context_Declaration => + null; + when others => + Error_Kind ("Cb_Walk_Declarations", Unit); + end case; + return Walk_Continue; + end Cb_Walk_Declarations; + + function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Declarations_Cb := Cb; + return Walk_Units (Cb_Walk_Declarations'Access); + end Walk_Declarations; + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + function Skip_Blanks (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P; + end Skip_Blanks; + + -- Return the position of the last character of the word (the last + -- non-blank character). + function Get_Word (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then not Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P - 1; + end Get_Word; + + procedure Disp_A_Frame (Instance: Block_Instance_Acc) is + begin + Put (Disp_Node (Instance.Label)); + if Instance.Stmt /= Null_Iir then + Put (" at "); + Put (Files_Map.Image (Get_Location (Instance.Stmt))); + end if; + New_Line; + end Disp_A_Frame; + + procedure Disp_Current_Lines + is + use Files_Map; + -- Number of lines to display before and after the current line. + Radius : constant := 5; + + Buf : File_Buffer_Acc; + + Pos : Source_Ptr; + Line : Natural; + Len : Source_Ptr; + C : Character; + begin + if List_Current_Line > Radius then + Line := List_Current_Line - Radius; + else + Line := 1; + end if; + + Pos := Line_To_Position (List_Current_File, Line); + Buf := Get_File_Source (List_Current_File); + + while Line < List_Current_Line + Radius loop + -- Compute line length. + Len := 0; + loop + C := Buf (Pos + Len); + exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; + Len := Len + 1; + end loop; + + -- Disp line number. + declare + Str : constant String := Natural'Image (Line); + begin + if Line = List_Current_Line then + Put ('*'); + else + Put (' '); + end if; + Put ((Str'Length .. 5 => ' ')); + Put (Str (Str'First + 1 .. Str'Last)); + Put (' '); + end; + + -- Disp line. + Put_Line (String (Buf (Pos .. Pos + Len - 1))); + + -- Skip EOL. + exit when C = ASCII.EOT; + Pos := Pos + Len + 1; + if C = ASCII.CR then + if Buf (Pos) = ASCII.LF then + Pos := Pos + 1; + end if; + else + pragma Assert (C = ASCII.LF); + if Buf (Pos) = ASCII.CR then + Pos := Pos + 1; + end if; + end if; + + Line := Line + 1; + end loop; + end Disp_Current_Lines; + + procedure Disp_Source_Line (Loc : Location_Type) + is + use Files_Map; + + File : Source_File_Entry; + Line_Pos : Source_Ptr; + Line : Natural; + Offset : Natural; + Buf : File_Buffer_Acc; + Next_Line_Pos : Source_Ptr; + begin + Location_To_Coord (Loc, File, Line_Pos, Line, Offset); + Buf := Get_File_Source (File); + Next_Line_Pos := Line_To_Position (File, Line + 1); + Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); + end Disp_Source_Line; + + type Menu_Kind is (Menu_Command, Menu_Submenu); + type Menu_Entry (Kind : Menu_Kind); + type Menu_Entry_Acc is access all Menu_Entry; + + type Cst_String_Acc is access constant String; + + type Menu_Entry (Kind : Menu_Kind) is record + Name : Cst_String_Acc; + Next : Menu_Entry_Acc; + + case Kind is + when Menu_Command => + Proc : Menu_Procedure; + when Menu_Submenu => + First, Last : Menu_Entry_Acc := null; + end case; + end record; + + -- Check there is a current process. + procedure Check_Current_Process is + begin + if Current_Process = null then + Put_Line ("no current process"); + raise Command_Error; + end if; + end Check_Current_Process; + + -- The status of the debugger. This status can be modified by a command + -- as a side effect to resume or quit the debugger. + type Command_Status_Type is (Status_Default, Status_Quit); + Command_Status : Command_Status_Type; + + procedure Help_Proc (Line : String); + + procedure Disp_Process_Loc (Proc : Process_State_Type) is + begin + Disp_Instance_Name (Proc.Top_Instance); + Put (" (" & Files_Map.Image (Get_Location (Proc.Proc)) & ")"); + New_Line; + end Disp_Process_Loc; + + -- Disp the list of processes (and its state) + procedure Ps_Proc (Line : String) is + pragma Unreferenced (Line); + Process : Iir; + begin + if Processes_State = null then + Put_Line ("no processes"); + return; + end if; + + for I in Processes_State'Range loop + Put (Process_Index_Type'Image (I) & ": "); + Process := Processes_State (I).Proc; + if Process /= Null_Iir then + Disp_Process_Loc (Processes_State (I)); + Disp_A_Frame (Processes_State (I).Instance); + else + Put_Line ("not yet elaborated"); + end if; + end loop; + end Ps_Proc; + + procedure List_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Disp_Current_Lines; + end List_Proc; + + procedure Up_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Check_Current_Process; + if Dbg_Cur_Frame.Parent = null then + Put_Line ("top of frames reached"); + else + Set_Cur_Frame (Dbg_Cur_Frame.Parent); + end if; + end Up_Proc; + + procedure Down_Proc (Line : String) + is + pragma Unreferenced (Line); + Inst : Block_Instance_Acc; + begin + Check_Current_Process; + if Dbg_Cur_Frame = Dbg_Top_Frame then + Put_Line ("bottom of frames reached"); + else + Inst := Dbg_Top_Frame; + while Inst.Parent /= Dbg_Cur_Frame loop + Inst := Inst.Parent; + end loop; + Set_Cur_Frame (Inst); + end if; + end Down_Proc; + + procedure Set_Breakpoint (Stmt : Iir) is + begin + Put_Line ("set breakpoint at: " & Files_Map.Image (Get_Location (Stmt))); + Breakpoints.Append (Breakpoint_Entry'(Stmt => Stmt)); + Flag_Need_Debug := True; + end Set_Breakpoint; + + function Is_Within_Statement (Stmt : Iir; Cur : Iir) return Boolean + is + Parent : Iir; + begin + Parent := Cur; + loop + if Parent = Stmt then + return True; + end if; + case Get_Kind (Parent) is + when Iir_Kinds_Sequential_Statement => + Parent := Get_Parent (Parent); + when others => + return False; + end case; + end loop; + end Is_Within_Statement; + + -- Next statement in the same frame, but handle compound statements as + -- one statement. + procedure Next_Stmt_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next_Stmt; + Exec_Instance := Dbg_Top_Frame; + Exec_Statement := Dbg_Top_Frame.Stmt; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Next_Stmt_Proc; + + -- Finish parent statement. + procedure Finish_Stmt_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next_Stmt; + Exec_Instance := Dbg_Top_Frame; + Exec_Statement := Get_Parent (Dbg_Top_Frame.Stmt); + Flag_Need_Debug := True; + Command_Status := Status_Quit; + end Finish_Stmt_Proc; + + procedure Next_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next; + Exec_Instance := Dbg_Top_Frame; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + Cmd_Repeat := Next_Proc'Access; + end Next_Proc; + + procedure Step_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Single_Step; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + Cmd_Repeat := Step_Proc'Access; + end Step_Proc; + + Break_Id : Name_Id; + + function Cb_Set_Break (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Identifier (El) = Break_Id + and then + Get_Implicit_Definition (El) not in Iir_Predefined_Implicit + then + Set_Breakpoint + (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El))); + end if; + when others => + null; + end case; + return Walk_Continue; + end Cb_Set_Break; + + procedure Break_Proc (Line : String) + is + Status : Walk_Status; + P : Natural; + begin + P := Skip_Blanks (Line); + if Line (P) = '"' then + -- An operator name. + declare + use Str_Table; + Str : String8_Id; + Len : Nat32; + begin + Str := Create_String8; + Len := 0; + P := P + 1; + while Line (P) /= '"' loop + Append_String8_Char (Line (P)); + Len := Len + 1; + P := P + 1; + end loop; + Break_Id := Parse.Str_To_Operator_Name (Str, Len, No_Location); + -- FIXME: free string. + -- FIXME: catch error. + end; + else + Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); + end if; + Status := Walk_Declarations (Cb_Set_Break'Access); + pragma Assert (Status = Walk_Continue); + end Break_Proc; + + procedure Where_Proc (Line : String) is + pragma Unreferenced (Line); + Frame : Block_Instance_Acc; + begin + Check_Current_Process; + Frame := Dbg_Top_Frame; + while Frame /= null loop + if Frame = Dbg_Cur_Frame then + Put ("* "); + else + Put (" "); + end if; + Disp_A_Frame (Frame); + Frame := Frame.Parent; + end loop; + end Where_Proc; + + procedure Info_Tree_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + if Top_Instance = null then + Put_Line ("design not yet fully elaborated"); + else + Disp_Instances_Tree; + end if; + end Info_Tree_Proc; + + procedure Info_Instances_Proc (Line : String) + is + pragma Unreferenced (Line); + procedure Disp_Instances (Inst : Block_Instance_Acc) + is + Child : Block_Instance_Acc; + begin + case Get_Kind (Inst.Label) is + when Iir_Kind_Architecture_Body => + Disp_Instances_Tree_Name (Inst); + when others => + null; + end case; + + Child := Inst.Children; + while Child /= null loop + if Get_Kind (Child.Label) not in Iir_Kinds_Process_Statement then + Disp_Instances (Child); + end if; + Child := Child.Brother; + end loop; + + end Disp_Instances; + begin + if Top_Instance = null then + Put_Line ("design not yet fully elaborated"); + return; + end if; + for I in Package_Instances'Range loop + if Package_Instances (I) /= null then + Put (Get_Instance_Local_Name (Package_Instances (I))); + Put_Line (" [package]"); + end if; + end loop; + Disp_Instances (Top_Instance); + end Info_Instances_Proc; + + procedure Info_Params_Proc (Line : String) + is + pragma Unreferenced (Line); + Decl : Iir; + Params : Iir; + begin + Check_Current_Process; + if Dbg_Cur_Frame = null then + Put_Line ("not in a subprogram"); + return; + end if; + Decl := Dbg_Cur_Frame.Label; + if Decl = Null_Iir + or else Get_Kind (Decl) not in Iir_Kinds_Subprogram_Declaration + then + Put_Line ("current frame is not a subprogram"); + return; + end if; + Params := Get_Interface_Declaration_Chain (Decl); + Disp_Declaration_Objects (Dbg_Cur_Frame, Params); + end Info_Params_Proc; + + procedure Info_Proc_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Check_Current_Process; + Disp_Process_Loc (Current_Process.all); + end Info_Proc_Proc; + + function Cb_Disp_Subprograms (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Put_Line (Name_Table.Image (Get_Identifier (El))); + when others => + null; + end case; + return Walk_Continue; + end Cb_Disp_Subprograms; + + procedure Info_Subprograms_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Declarations (Cb_Disp_Subprograms'Access); + pragma Assert (Status = Walk_Continue); + end Info_Subprograms_Proc; + + function Cb_Disp_Units (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + Put ("package "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Entity_Declaration => + Put ("entity "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Architecture_Body => + Put ("architecture "); + Put (Name_Table.Image (Get_Identifier (El))); + Put (" of "); + Put_Line (Name_Table.Image (Get_Identifier + (Get_Entity_Name (El)))); + when Iir_Kind_Configuration_Declaration => + Put ("configuration "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Package_Body => + null; + when others => + Error_Kind ("cb_disp_units", El); + end case; + return Walk_Continue; + end Cb_Disp_Units; + + procedure Info_Units_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Units (Cb_Disp_Units'Access); + pragma Assert (Status = Walk_Continue); + end Info_Units_Proc; + + function Cb_Disp_File (El : Iir) return Walk_Status is + begin + Put_Line (Name_Table.Image (Get_Design_File_Filename (El))); + return Walk_Continue; + end Cb_Disp_File; + + procedure Info_PSL_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + if PSL_Table.Last < PSL_Table.First then + Put_Line ("no PSL directive"); + return; + end if; + + for I in PSL_Table.First .. PSL_Table.Last loop + declare + E : PSL_Entry renames PSL_Table.Table (I); + begin + Disp_Instance_Name (E.Instance); + Put ('.'); + Put (Name_Table.Image (Get_Identifier (E.Stmt))); + New_Line; + Disp_Vhdl.Disp_PSL_NFA (Get_PSL_NFA (E.Stmt)); + Put (" 01234567890123456789012345678901234567890123456789"); + for I in E.States'Range loop + if I mod 50 = 0 then + New_Line; + Put (Int32'Image (I / 10)); + Put (": "); + end if; + if E.States (I) then + Put ('*'); + else + Put ('.'); + end if; + end loop; + New_Line; + end; + end loop; + end Info_PSL_Proc; + + procedure Info_Stats_Proc (Line : String) is + P : Natural := Line'First; + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + -- No parameters. + Disp_Design_Stats; + return; + end if; + + E := Get_Word (Line (P .. Line'Last)); + if Line (P .. E) = "global" then + Disp_Design_Stats; + elsif Line (P .. E) = "non-sensitized" then + Disp_Design_Non_Sensitized; + null; + elsif Line (P .. E) = "connections" then + Disp_Design_Connections; + -- TODO: nbr of conversions + else + Put_Line ("options are: global, non-sensitized, connections"); + -- TODO: signals: nbr of scalars, nbr of non-user... + end if; + end Info_Stats_Proc; + + procedure Info_Files_Proc (Line : String) + is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Files (Cb_Disp_File'Access); + pragma Assert (Status = Walk_Continue); + end Info_Files_Proc; + + procedure Info_Libraries_Proc (Line : String) is + pragma Unreferenced (Line); + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + begin + while Lib /= Null_Iir loop + Put_Line (Name_Table.Image (Get_Identifier (Lib))); + Lib := Get_Chain (Lib); + end loop; + end Info_Libraries_Proc; + + procedure Disp_Declared_Signals_Chain + (Chain : Iir; Instance : Block_Instance_Acc) + is + pragma Unreferenced (Instance); + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration => + Put_Line (" " & Name_Table.Image (Get_Identifier (Decl))); + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end Disp_Declared_Signals_Chain; + + procedure Disp_Declared_Signals (Decl : Iir; Instance : Block_Instance_Acc) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Disp_Declared_Signals (Get_Parent (Decl), Instance); + when Iir_Kind_Architecture_Body => + Disp_Declared_Signals (Get_Entity (Decl), Instance); + when Iir_Kind_Entity_Declaration => + null; + when others => + Error_Kind ("disp_declared_signals", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + -- No signal declaration in a process (FIXME: implicit signals) + null; + when Iir_Kind_Architecture_Body => + Put_Line ("Signals of architecture " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Declaration_Chain (Decl), Instance); + when Iir_Kind_Entity_Declaration => + Put_Line ("Ports of entity " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Port_Chain (Decl), Instance); + when others => + Error_Kind ("disp_declared_signals (2)", Decl); + end case; + end Disp_Declared_Signals; + + procedure Info_Signals_Proc (Line : String) is + pragma Unreferenced (Line); + begin + if False then + Check_Current_Process; + Disp_Declared_Signals + (Current_Process.Proc, Current_Process.Top_Instance); + elsif True then + for I in Signals_Table.First .. Signals_Table.Last loop + declare + S : Signal_Entry renames Signals_Table.Table (I); + begin + Disp_Instance_Name (S.Instance, False); + Put ('.'); + if S.Kind in Grt.Types.Mode_Signal_User then + Put (Name_Table.Image (Get_Identifier (S.Decl))); + Disp_Value (S.Sig); + Disp_Value (S.Val); + else + Disp_Declaration_Object (S.Instance, S.Decl); + end if; + end; + end loop; + else + Disp_Signals_Value; + end if; + end Info_Signals_Proc; + + type Handle_Scope_Type is access procedure (N : Iir); + + procedure Foreach_Scopes (N : Iir; Handler : Handle_Scope_Type) is + begin + case Get_Kind (N) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + when Iir_Kind_Architecture_Body => + Foreach_Scopes (Get_Entity (N), Handler); + Handler.all (N); + + when Iir_Kind_Entity_Declaration => + -- Top of scopes. + Handler.all (N); + + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + when Iir_Kind_Package_Body => + Handler.all (N); + + when Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Simple_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Case_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + + when Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement + | Iir_Kind_Generate_Statement_Body => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + + when others => + Error_Kind ("foreach_scopes", N); + end case; + end Foreach_Scopes; + + procedure Add_Decls_For (N : Iir) + is + use Sem_Scopes; + begin + case Get_Kind (N) is + when Iir_Kind_Entity_Declaration => + declare + Unit : constant Iir := Get_Design_Unit (N); + begin + Add_Context_Clauses (Unit); + -- Add_Name (Unit, Get_Identifier (N), False); + Add_Entity_Declarations (N); + end; + when Iir_Kind_Architecture_Body => + Open_Declarative_Region; + Add_Context_Clauses (Get_Design_Unit (N)); + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when Iir_Kind_Package_Body => + declare + Package_Decl : constant Iir := Get_Package (N); + Package_Unit : constant Iir := Get_Design_Unit (Package_Decl); + begin + Add_Name (Package_Unit); + Add_Context_Clauses (Package_Unit); + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (Package_Decl), False); + Add_Declarations (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + declare + Spec : constant Iir := Get_Subprogram_Specification (N); + begin + Open_Declarative_Region; + Add_Declarations + (Get_Interface_Declaration_Chain (Spec), False); + Add_Declarations + (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + when Iir_Kind_For_Loop_Statement + | Iir_Kind_For_Generate_Statement => + Open_Declarative_Region; + Add_Name (Get_Parameter_Specification (N)); + when Iir_Kind_Block_Statement => + declare + Header : constant Iir := Get_Block_Header (N); + begin + Open_Declarative_Region; + if Header /= Null_Iir then + Add_Declarations (Get_Generic_Chain (Header), False); + Add_Declarations (Get_Port_Chain (Header), False); + end if; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + end; + when Iir_Kind_Generate_Statement_Body => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when others => + Error_Kind ("enter_scope(2)", N); + end case; + end Add_Decls_For; + + procedure Enter_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Push_Interpretations; + Open_Declarative_Region; + + -- Add STD + Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); + Use_All_Names (Std_Package.Standard_Package); + + Foreach_Scopes (Node, Add_Decls_For'Access); + end Enter_Scope; + + procedure Del_Decls_For (N : Iir) + is + use Sem_Scopes; + begin + case Get_Kind (N) is + when Iir_Kind_Entity_Declaration => + null; + when Iir_Kind_Architecture_Body => + Close_Declarative_Region; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Package_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_If_Generate_Statement + | Iir_Kind_For_Generate_Statement + | Iir_Kind_Generate_Statement_Body => + Close_Declarative_Region; + when others => + Error_Kind ("Decl_Decls_For", N); + end case; + end Del_Decls_For; + + procedure Leave_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Foreach_Scopes (Node, Del_Decls_For'Access); + + Close_Declarative_Region; + Pop_Interpretations; + end Leave_Scope; + + Buffer_Index : Natural := 1; + + procedure Print_Proc (Line : String) + is + use Tokens; + Index_Str : String := Natural'Image (Buffer_Index); + File : Source_File_Entry; + Expr : Iir; + Res : Iir_Value_Literal_Acc; + P : Natural; + Opt_Value : Boolean := False; + Opt_Name : Boolean := False; + Marker : Mark_Type; + begin + -- Decode options: /v + P := Line'First; + loop + P := Skip_Blanks (Line (P .. Line'Last)); + if P + 2 < Line'Last and then Line (P .. P + 1) = "/v" then + Opt_Value := True; + P := P + 2; + elsif P + 2 < Line'Last and then Line (P .. P + 1) = "/n" then + Opt_Name := True; + P := P + 2; + else + exit; + end if; + end loop; + + Buffer_Index := Buffer_Index + 1; + Index_Str (Index_Str'First) := '*'; + File := Files_Map.Create_Source_File_From_String + (Name_Table.Get_Identifier ("*debug" & Index_Str & '*'), + Line (P .. Line'Last)); + Scanner.Set_File (File); + Scanner.Scan; + Expr := Parse.Parse_Expression; + if Scanner.Current_Token /= Tok_Eof then + Put_Line ("garbage at end of expression ignored"); + end if; + Scanner.Close_File; + if Nbr_Errors /= 0 then + Put_Line ("error while parsing expression, evaluation aborted"); + Nbr_Errors := 0; + return; + end if; + + Enter_Scope (Dbg_Cur_Frame.Stmt); + Expr := Sem_Expr.Sem_Expression_Universal (Expr); + Leave_Scope (Dbg_Cur_Frame.Stmt); + + if Expr = Null_Iir + or else Nbr_Errors /= 0 + then + Put_Line ("error while analyzing expression, evaluation aborted"); + Nbr_Errors := 0; + return; + end if; + + Disp_Vhdl.Disp_Expression (Expr); + New_Line; + + Annotate_Expand_Table; + Canon.Canon_Expression (Expr); + + Mark (Marker, Expr_Pool); + + if Opt_Name then + case Get_Kind (Expr) is + when Iir_Kind_Simple_Name => + null; + when others => + Put_Line ("expression is not a name"); + Opt_Name := False; + end case; + end if; + if Opt_Name then + Res := Execute_Name (Dbg_Cur_Frame, Expr, True); + else + Res := Execute_Expression (Dbg_Cur_Frame, Expr); + end if; + if Opt_Value then + Disp_Value (Res); + else + Disp_Iir_Value (Res, Get_Type (Expr)); + end if; + New_Line; + + -- Free value + Release (Marker, Expr_Pool); + end Print_Proc; + + procedure Quit_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Command_Status := Status_Quit; + raise Debugger_Quit; + end Quit_Proc; + + procedure Cont_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Command_Status := Status_Quit; + + -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. + Flag_Need_Debug := False; + for I in Breakpoints.First .. Breakpoints.Last loop + Flag_Need_Debug := True; + exit; + end loop; + end Cont_Proc; + + Menu_Info_Instances : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("instances"), + Next => null, + Proc => Info_Instances_Proc'Access); + + Menu_Info_Psl : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("psl"), + Next => Menu_Info_Instances'Access, + Proc => Info_PSL_Proc'Access); + + Menu_Info_Stats : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("stats"), + Next => Menu_Info_Psl'Access, + Proc => Info_Stats_Proc'Access); + + Menu_Info_Tree : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("tree"), + Next => Menu_Info_Stats'Access, + Proc => Info_Tree_Proc'Access); + + Menu_Info_Params : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("param*eters"), + Next => Menu_Info_Tree'Access, + Proc => Info_Params_Proc'Access); + + Menu_Info_Subprograms : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("subp*rograms"), + Next => Menu_Info_Params'Access, + Proc => Info_Subprograms_Proc'Access); + + Menu_Info_Units : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("units"), + Next => Menu_Info_Subprograms'Access, + Proc => Info_Units_Proc'Access); + + Menu_Info_Files : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("files"), + Next => Menu_Info_Units'Access, + Proc => Info_Files_Proc'Access); + + Menu_Info_Libraries : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("lib*raries"), + Next => Menu_Info_Files'Access, + Proc => Info_Libraries_Proc'Access); + + Menu_Info_Signals : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("sig*nals"), + Next => Menu_Info_Libraries'Access, + Proc => Info_Signals_Proc'Access); + + Menu_Info_Proc : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("proc*esses"), + Next => Menu_Info_Signals'Access, + Proc => Info_Proc_Proc'Access); + + Menu_List : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("l*list"), + Next => null, + Proc => List_Proc'Access); + + Menu_Down : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("down"), + Next => Menu_List'Access, + Proc => Down_Proc'Access); + + Menu_Up : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("up"), + Next => Menu_Down'Access, + Proc => Up_Proc'Access); + + Menu_Nstmt : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("ns*tmt"), + Next => Menu_Up'Access, + Proc => Next_Stmt_Proc'Access); + + Menu_Fstmt : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("fs*tmt"), + Next => Menu_Nstmt'Access, + Proc => Finish_Stmt_Proc'Access); + + Menu_Next : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("n*ext"), + Next => Menu_Fstmt'Access, + Proc => Next_Proc'Access); + + Menu_Step : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("s*tep"), + Next => Menu_Next'Access, + Proc => Step_Proc'Access); + + Menu_Break : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("b*reak"), + Next => Menu_Step'Access, + Proc => Break_Proc'Access); + + Menu_Where : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("where"), + Next => Menu_Break'Access, + Proc => Where_Proc'Access); + + Menu_Ps : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("ps"), + Next => Menu_Where'Access, + Proc => Ps_Proc'Access); + + Menu_Info : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => new String'("i*nfo"), + Next => Menu_Ps'Access, + First | Last => Menu_Info_Proc'Access); + + Menu_Print : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("pr*int"), + Next => Menu_Info'Access, + Proc => Print_Proc'Access); + + Menu_Cont : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("c*ont"), + Next => Menu_Print'Access, + Proc => Cont_Proc'Access); + + Menu_Quit : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("q*uit"), + Next => Menu_Cont'Access, + Proc => Quit_Proc'Access); + + Menu_Help1 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("help"), + Next => Menu_Quit'Access, + Proc => Help_Proc'Access); + + Menu_Help2 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("?"), + Next => Menu_Help1'Access, + Proc => Help_Proc'Access); + + Menu_Top : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => null, + Next => null, + First | Last => Menu_Help2'Access); + + function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String) + return Menu_Entry_Acc + is + function Is_Cmd (Cmd_Name : String; Str : String) return Boolean + is + -- Number of characters that were compared. + P : Natural; + begin + P := 0; + -- Prefix (before the '*'). + loop + if P = Cmd_Name'Length then + -- Full match. + return P = Str'Length; + end if; + exit when Cmd_Name (Cmd_Name'First + P) = '*'; + if P = Str'Length then + -- Command is too short + return False; + end if; + if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + -- Suffix (after the '*') + loop + if P = Str'Length then + return True; + end if; + if P + 1 = Cmd_Name'Length then + -- String is too long + return False; + end if; + if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then + return False; + end if; + P := P + 1; + end loop; + end Is_Cmd; + Ent : Menu_Entry_Acc; + begin + Ent := Menu.First; + while Ent /= null loop + if Is_Cmd (Ent.Name.all, Cmd) then + return Ent; + end if; + Ent := Ent.Next; + end loop; + return null; + end Find_Menu; + + procedure Parse_Command (Line : String; + P : in out Natural; + Menu : out Menu_Entry_Acc) + is + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + return; + end if; + E := Get_Word (Line (P .. Line'Last)); + Menu := Find_Menu (Menu, Line (P .. E)); + if Menu = null then + Put_Line ("command '" & Line (P .. E) & "' not found"); + end if; + P := E + 1; + end Parse_Command; + + procedure Help_Proc (Line : String) + is + P : Natural; + Root : Menu_Entry_Acc := Menu_Top'access; + begin + Put_Line ("This is the help command"); + P := Line'First; + while P < Line'Last loop + Parse_Command (Line, P, Root); + if Root = null then + return; + elsif Root.Kind /= Menu_Submenu then + Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); + return; + end if; + end loop; + + Root := Root.First; + while Root /= null loop + Put (Root.Name.all); + if Root.Kind = Menu_Submenu then + Put (" (menu)"); + end if; + New_Line; + Root := Root.Next; + end loop; + end Help_Proc; + + function Breakpoint_Hit return Natural + is + Stmt : constant Iir := Current_Process.Instance.Stmt; + begin + for I in Breakpoints.First .. Breakpoints.Last loop + if Stmt = Breakpoints.Table (I).Stmt then + return I; + end if; + end loop; + return 0; + end Breakpoint_Hit; + + Prompt_Debug : constant String := "debug> " & ASCII.NUL; + Prompt_Crash : constant String := "crash> " & ASCII.NUL; + Prompt_Init : constant String := "init> " & ASCII.NUL; + Prompt_Elab : constant String := "elab> " & ASCII.NUL; + + procedure Debug (Reason: Debug_Reason) + is + use Grt.Readline; + Raw_Line : Char_Ptr; + Prompt : System.Address; + begin + -- Unless interractive, do not use the debugger. + case Reason is + when Reason_Internal_Debug => + null; + when Reason_Assert + | Reason_Error => + if not Flag_Debugger then + return; + end if; + when Reason_Start + | Reason_Elab => + if not Flag_Interractive then + return; + end if; + when Reason_Break => + null; + end case; + + Prompt := Prompt_Debug'Address; + + case Reason is + when Reason_Start => + Set_Top_Frame (null); + Prompt := Prompt_Init'Address; + when Reason_Elab => + Set_Top_Frame (null); + Prompt := Prompt_Elab'Address; + when Reason_Internal_Debug => + if Current_Process = null then + Set_Top_Frame (null); + else + Set_Top_Frame (Current_Process.Instance); + end if; + when Reason_Break => + case Exec_State is + when Exec_Run => + if Breakpoint_Hit /= 0 then + Put_Line ("breakpoint hit"); + else + return; + end if; + when Exec_Single_Step => + null; + when Exec_Next => + if Current_Process.Instance /= Exec_Instance then + return; + end if; + when Exec_Next_Stmt => + if Current_Process.Instance /= Exec_Instance + or else Is_Within_Statement (Exec_Statement, + Current_Process.Instance.Stmt) + then + return; + end if; + end case; + -- Default state. + Exec_State := Exec_Run; + Set_Top_Frame (Current_Process.Instance); + declare + Stmt : constant Iir := Dbg_Cur_Frame.Stmt; + begin + Put ("stopped at: "); + Disp_Iir_Location (Stmt); + New_Line; + Disp_Source_Line (Get_Location (Stmt)); + end; + when Reason_Assert => + Set_Top_Frame (Current_Process.Instance); + Prompt := Prompt_Crash'Address; + Put_Line ("assertion failure, enterring in debugger"); + when Reason_Error => + Set_Top_Frame (Current_Process.Instance); + Prompt := Prompt_Crash'Address; + Put_Line ("error occurred, enterring in debugger"); + end case; + + if Dbg_Cur_Frame /= null then + Set_List_Current (Get_Location (Dbg_Cur_Frame.Stmt)); + end if; + + Command_Status := Status_Default; + + loop + loop + Raw_Line := Readline (Prompt); + -- Skip empty lines + if Raw_Line = null or else Raw_Line (1) = ASCII.NUL then + if Cmd_Repeat /= null then + Cmd_Repeat.all (""); + case Command_Status is + when Status_Default => + null; + when Status_Quit => + return; + end case; + end if; + else + Cmd_Repeat := null; + exit; + end if; + end loop; + declare + Line_Last : constant Natural := Strlen (Raw_Line); + Line : String renames Raw_Line (1 .. Line_Last); + P, E : Positive; + Cmd : Menu_Entry_Acc := Menu_Top'Access; + begin + -- Find command + P := 1; + loop + E := P; + Parse_Command (Line, E, Cmd); + exit when Cmd = null; + case Cmd.Kind is + when Menu_Submenu => + if E > Line_Last then + Put_Line ("missing command for submenu " + & Line (P .. E - 1)); + Cmd := null; + exit; + end if; + P := E; + when Menu_Command => + exit; + end case; + end loop; + + if Cmd /= null then + Cmd.Proc.all (Line (E .. Line_Last)); + + case Command_Status is + when Status_Default => + null; + when Status_Quit => + exit; + end case; + end if; + exception + when Command_Error => + null; + end; + end loop; + -- Put ("resuming"); + end Debug; + + procedure Debug_Error is + begin + Debug (Reason_Error); + end Debug_Error; +end Simul.Debugger; diff --git a/src/vhdl/simulate/simul-debugger.ads b/src/vhdl/simulate/simul-debugger.ads new file mode 100644 index 000000000..9deba556b --- /dev/null +++ b/src/vhdl/simulate/simul-debugger.ads @@ -0,0 +1,91 @@ +-- Debugger for interpreter +-- 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 Iirs; use Iirs; +with Simul.Environments; use Simul.Environments; + +package Simul.Debugger is + Flag_Debugger : Boolean := False; + Flag_Interractive : Boolean := False; + + Flag_Need_Debug : Boolean := False; + + -- Disp a message for a constraint error. + -- And raise the exception execution_constraint_error. + procedure Error_Msg_Constraint (Expr: Iir); + pragma No_Return (Error_Msg_Constraint); + + -- Disp a message during execution. + procedure Error_Msg_Exec (Msg: String; Loc: Iir); + pragma No_Return (Error_Msg_Exec); + + procedure Warning_Msg_Exec (Msg: String; Loc: Iir); + + -- Disp a block instance, in a human readable way. + -- Used to debug. + procedure Disp_Block_Instance (Instance: Block_Instance_Acc); + + -- Disp the instance tree. + procedure Disp_Instances_Tree; + + -- Disp the name of an instance, without newline. The name of + -- architectures is displayed unless Short is True. + procedure Disp_Instance_Name (Instance: Block_Instance_Acc; + Short : Boolean := False); + + -- Disp the resulting processes of elaboration. + -- procedure Disp_Processes; + + -- Disp the label of PROCESS, or if PROCESS has no label. + procedure Disp_Label (Process : Iir); + + -- Disp all signals name and values. + procedure Disp_Signals_Value; + + -- Disp stats about the design (number of process, number of signals...) + procedure Disp_Design_Stats; + + -- The reason why the debugger is invoked. + type Debug_Reason is + (-- Called from an external debugger while debugging ghdl. + Reason_Internal_Debug, + + -- Interractive session, elaboration not done + Reason_Start, + + -- At end of elaboration, for an interractive session + Reason_Elab, + + -- Before execution of a statement. + Reason_Break, + + -- Assertion failure + Reason_Assert, + + -- Non recoverable error occurred (such as index error, overflow...) + Reason_Error + ); + + Debugger_Quit : exception; + + -- Interractive debugger. + procedure Debug (Reason: Debug_Reason); + + -- Call the debugger in case of error. + procedure Debug_Error; +end Simul.Debugger; diff --git a/src/vhdl/simulate/simul-elaboration-ams.adb b/src/vhdl/simulate/simul-elaboration-ams.adb new file mode 100644 index 000000000..f5cf20110 --- /dev/null +++ b/src/vhdl/simulate/simul-elaboration-ams.adb @@ -0,0 +1,199 @@ +-- Interpreter AMS 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 Errorout; use Errorout; +with Simul.Execution; + +package body Simul.Elaboration.AMS is + function Create_Characteristic_Expression + (Kind : Characteristic_Expr_Kind) return Characteristic_Expressions_Index + is + begin + case Kind is + when Contribution => + Characteristic_Expressions.Append + ((Kind => Contribution, + Expr => null, + Tolerance => 0, + Dependencies => null)); + when others => + raise Program_Error; + end case; + return Characteristic_Expressions.Last; + end Create_Characteristic_Expression; + + function Create_Scalar_Quantity (Kind : Quantity_Kind; + Decl : Iir; + Instance : Block_Instance_Acc) + return Quantity_Index_Type + is + begin + case Kind is + when Quantity_Reference => + Scalar_Quantities.Append + ((Kind => Quantity_Reference, + Value => 0.0, + Decl => Decl, + Instance => Instance, + Contribution => + Create_Characteristic_Expression (Contribution))); + when Quantity_Across => + Scalar_Quantities.Append + ((Kind => Quantity_Across, + Value => 0.0, + Decl => Decl, + Instance => Instance)); + when Quantity_Through => + Scalar_Quantities.Append + ((Kind => Quantity_Through, + Value => 0.0, + Decl => Decl, + Instance => Instance)); + when others => + raise Program_Error; + end case; + return Scalar_Quantities.Last; + end Create_Scalar_Quantity; + + function Create_Scalar_Terminal (Decl : Iir; + Instance : Block_Instance_Acc) + return Terminal_Index_Type + is + begin + -- Simply create the reference quantity for a terminal + return Terminal_Index_Type + (Create_Scalar_Quantity (Quantity_Reference, Decl, Instance)); + end Create_Scalar_Terminal; + + function Get_Terminal_Reference (Terminal : Terminal_Index_Type) + return Quantity_Index_Type is + begin + return Quantity_Index_Type (Terminal); + end Get_Terminal_Reference; + + procedure Add_Characteristic_Expression + (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc) + is + begin + Characteristic_Expressions.Append + ((Kind => Kind, + Expr => Expr, + Tolerance => Default_Tolerance_Index, + Dependencies => null)); + end Add_Characteristic_Expression; + + procedure Compute_Dependencies (Idx : Characteristic_Expressions_Index) + is + package Quantity_Table is new Tables + (Table_Component_Type => Quantity_Index_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16); + + El : Characteristic_Expr renames Characteristic_Expressions.Table (Idx); + Res : Quantity_Dependency_Acc := null; + + procedure Add_Dependency (Block : Block_Instance_Acc; N : Iir) + is + Q : Iir_Value_Literal_Acc; + begin + case Get_Kind (N) is + when Iir_Kinds_Branch_Quantity_Declaration => + Q := Execution.Execute_Name (Block, N, True); + Quantity_Table.Append (Q.Quantity); + when Iir_Kind_Simple_Name => + Add_Dependency (Block, Get_Named_Entity (N)); + when Iir_Kinds_Dyadic_Operator => + Add_Dependency (Block, Get_Left (N)); + Add_Dependency (Block, Get_Right (N)); + when Iir_Kinds_Literal => + null; + when others => + Error_Kind ("compute_dependencies", N); + end case; + end Add_Dependency; + + Term : Ams_Term_Acc := El.Expr; + begin + pragma Assert (El.Dependencies = null); + + while Term /= null loop + case Term.Op is + when Op_Quantity => + Quantity_Table.Append (Term.Quantity); + when Op_Vhdl_Expr => + Add_Dependency (Term.Vhdl_Instance, Term.Vhdl_Expr); + end case; + Term := Term.Next; + end loop; + Res := new Quantity_Dependency_Type (Nbr => Quantity_Table.Last); + for I in Quantity_Table.First .. Quantity_Table.Last loop + Res.Quantities (I) := Quantity_Table.Table (I); + end loop; + Quantity_Table.Free; + El.Dependencies := Res; + end Compute_Dependencies; + + function Build (Op : Ams_Sign; + Val : Quantity_Index_Type; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc + is + begin + return new Ams_Term'(Op => Op_Quantity, + Sign => Op, + Next => Right, + Quantity => Val); + end Build; + + function Build (Op : Ams_Sign; + Instance : Block_Instance_Acc; + Expr : Iir; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc + is + begin + return new Ams_Term' + (Op => Op_Vhdl_Expr, + Sign => Op, + Vhdl_Expr => Expr, + Vhdl_Instance => Instance, + Next => Right); + end Build; + + procedure Append_Characteristic_Expression + (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc) + is + Ref : constant Quantity_Index_Type := Get_Terminal_Reference (Terminal); + Ce : constant Characteristic_Expressions_Index := + Scalar_Quantities.Table (Ref).Contribution; + begin + pragma Assert (Expr.Next = null); + Expr.Next := Characteristic_Expressions.Table (Ce).Expr; + Characteristic_Expressions.Table (Ce).Expr := Expr; + end Append_Characteristic_Expression; + + procedure Create_Tables is + begin + for I in Characteristic_Expressions.First + .. Characteristic_Expressions.Last + loop + Compute_Dependencies (I); + end loop; + end Create_Tables; +end Simul.Elaboration.AMS; diff --git a/src/vhdl/simulate/simul-elaboration-ams.ads b/src/vhdl/simulate/simul-elaboration-ams.ads new file mode 100644 index 000000000..f7f063019 --- /dev/null +++ b/src/vhdl/simulate/simul-elaboration-ams.ads @@ -0,0 +1,163 @@ +-- Interpreter AMS 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 Tables; + +package Simul.Elaboration.AMS is + -- AMS expressions + -- + -- At many places during elaboration, the LRM defines characteristic + -- expressions that aren't present in source code: + -- * contribution expression (12.3.1.4) + -- * characteristic expression for an across quantity declaration + -- (12.3.1.4) + -- * characteristic expression for simple simultaneous statement (the + -- expression is in the source in that case) (15.1) + -- + -- They are represented using a list of Ams_Expression elements. The value + -- is the sum of each element, using the + or - sign. + + type Ams_Sign is (Op_Plus, Op_Minus); + -- Sign for the operand + + type Ams_Operand is (Op_Quantity, Op_Vhdl_Expr); + -- The operand is one of: + -- Op_Quantity: a quantity + -- Op_Vhdl_Expr: an expression from the design. This expression may contain + -- quantities + + type Ams_Term; + type Ams_Term_Acc is access Ams_Term; + -- A term of a characteristic expression + + type Characteristic_Expr_Kind is + (Explicit, + Contribution, + Structural); + + type Tolerance_Index_Type is new Natural; + Default_Tolerance_Index : constant Tolerance_Index_Type := 0; + -- Tolerance + + type Characteristic_Expressions_Index is new Natural; + + type Quantity_Kind is + (Quantity_Reference, + -- The potential of a terminal. This is an across quantity between the + -- terminal and the reference terminal of the nature. + + Quantity_Across, + Quantity_Through, + Quantity_Free + -- Explicitly declared quantities + ); + + function Create_Scalar_Quantity (Kind : Quantity_Kind; + Decl : Iir; + Instance : Block_Instance_Acc) + return Quantity_Index_Type; + -- Create a new scalar quantity + + function Create_Scalar_Terminal (Decl : Iir; + Instance : Block_Instance_Acc) + return Terminal_Index_Type; + -- Create a new scalar terminal + + function Get_Terminal_Reference (Terminal : Terminal_Index_Type) + return Quantity_Index_Type; + -- Get the reference quantity of a terminal + + procedure Add_Characteristic_Expression + (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc); + -- Add a new characteristic expression + + function Build (Op : Ams_Sign; + Val : Quantity_Index_Type; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc; + function Build (Op : Ams_Sign; + Instance : Block_Instance_Acc; + Expr : Iir; + Right : Ams_Term_Acc := null) + return Ams_Term_Acc; + -- Build a term of a characteristic expression + + procedure Append_Characteristic_Expression + (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc); + -- Append an expression to the contribution of a terminal + + procedure Create_Tables; + + type Quantity_Index_Array is array (Positive range <>) + of Quantity_Index_Type; + + type Quantity_Dependency_Type (Nbr : Natural); + type Quantity_Dependency_Acc is access Quantity_Dependency_Type; + + type Quantity_Dependency_Type (Nbr : Natural) is record + Quantities : Quantity_Index_Array (1 .. Nbr); + end record; + + type Ams_Term (Op : Ams_Operand) is record + Sign : Ams_Sign; + Next : Ams_Term_Acc; + + case Op is + when Op_Quantity => + Quantity : Quantity_Index_Type; + when Op_Vhdl_Expr => + Vhdl_Expr : Iir; + Vhdl_Instance : Block_Instance_Acc; + end case; + end record; + + type Characteristic_Expr is record + Kind : Characteristic_Expr_Kind; + Expr : Ams_Term_Acc; + Tolerance : Tolerance_Index_Type; + Dependencies : Quantity_Dependency_Acc; + end record; + + package Characteristic_Expressions is new Tables + (Table_Index_Type => Characteristic_Expressions_Index, + Table_Component_Type => Characteristic_Expr, + Table_Low_Bound => 1, + Table_Initial => 128); + + type Scalar_Quantity (Kind : Quantity_Kind := Quantity_Reference) is record + Value : Ghdl_F64; + -- The value of the quantity + + Decl : Iir; + Instance : Block_Instance_Acc; + -- Declaration for the quantity + + case Kind is + when Quantity_Reference => + Contribution : Characteristic_Expressions_Index; + when others => + null; + end case; + end record; + + package Scalar_Quantities is new Tables + (Table_Index_Type => Quantity_Index_Type, + Table_Component_Type => Scalar_Quantity, + Table_Low_Bound => 1, + Table_Initial => 128); +end Simul.Elaboration.AMS; diff --git a/src/vhdl/simulate/simul-elaboration.adb b/src/vhdl/simulate/simul-elaboration.adb new file mode 100644 index 000000000..86a936458 --- /dev/null +++ b/src/vhdl/simulate/simul-elaboration.adb @@ -0,0 +1,2979 @@ +-- Elaboration +-- 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.Text_IO; +with Str_Table; +with Errorout; use Errorout; +with Evaluation; +with Simul.Execution; use Simul.Execution; +with Iirs_Utils; use Iirs_Utils; +with Libraries; +with Name_Table; +with Simul.File_Operation; +with Iir_Chains; use Iir_Chains; +with Simul.Elaboration.AMS; use Simul.Elaboration.AMS; +with Areapools; use Areapools; +with Grt.Errors; +with Grt.Options; + +package body Simul.Elaboration is + + procedure Elaborate_Dependence (Design_Unit: Iir_Design_Unit); + + procedure Elaborate_Statement_Part + (Instance : Block_Instance_Acc; Stmt_Chain: Iir); + procedure Elaborate_Type_Definition + (Instance : Block_Instance_Acc; Def : Iir); + procedure Elaborate_Nature_Definition + (Instance : Block_Instance_Acc; Def : Iir); + + function Elaborate_Default_Value + (Instance : Block_Instance_Acc; Decl : Iir) + return Iir_Value_Literal_Acc; + + procedure Elaborate_Generic_Clause + (Instance : Block_Instance_Acc; Generic_Chain : Iir); + procedure Elaborate_Generic_Map_Aspect + (Target_Instance : Block_Instance_Acc; + Local_Instance : Block_Instance_Acc; + Generics : Iir; + Map : Iir); + + -- CONF is the block_configuration for components of ARCH. + function Elaborate_Architecture (Arch : Iir_Architecture_Body; + Conf : Iir_Block_Configuration; + Parent_Instance : Block_Instance_Acc; + Stmt : Iir; + Generic_Map : Iir; + Port_Map : Iir) + return Block_Instance_Acc; + + procedure Create_Object + (Instance : Block_Instance_Acc; + Slot : Object_Slot_Type; + Num : Object_Slot_Type := 1) is + begin + -- Check elaboration order. + -- Note: this is not done for package since objects from package are + -- commons (same scope), and package annotation order can be different + -- from package elaboration order (eg: body). + if Slot /= Instance.Elab_Objects + 1 + or else Instance.Objects (Slot) /= null + then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Instance.Elab_Objects := Slot + Num - 1; + end Create_Object; + + procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir) + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + begin + Create_Object (Instance, Slot, 1); + end Create_Object; + + procedure Destroy_Object (Instance : Block_Instance_Acc; Decl : Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + Slot : constant Object_Slot_Type := Info.Slot; + begin + if Slot /= Instance.Elab_Objects + or else Info.Obj_Scope /= Instance.Block_Scope + then + Error_Msg_Elab ("bad destroy order"); + raise Internal_Error; + end if; + -- Clear the slot (this is necessary for ranges). + Instance.Objects (Slot) := null; + Instance.Elab_Objects := Slot - 1; + end Destroy_Object; + + procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir) + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + begin + Create_Object (Instance, Slot, 2); + end Create_Signal; + + -- Create a new signal, using DEFAULT as initial value. + -- Set its number. + procedure Elaborate_Signal (Block: Block_Instance_Acc; + Signal: Iir; + Default : Iir_Value_Literal_Acc) + is + function Create_Signal (Lit: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Lit.Kind is + when Iir_Value_Array => + Res := Create_Array_Value (Lit.Val_Array.Len, + Lit.Bounds.Nbr_Dims); + Res.Bounds.D := Lit.Bounds.D; + Res := Unshare_Bounds (Res, Global_Pool'Access); + + for I in Lit.Val_Array.V'Range loop + Res.Val_Array.V (I) := Create_Signal (Lit.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + Res := Create_Record_Value + (Lit.Val_Record.Len, Instance_Pool); + for I in Lit.Val_Record.V'Range loop + Res.Val_Record.V (I) := Create_Signal (Lit.Val_Record.V (I)); + end loop; + + when Iir_Value_Scalars => + Res := Create_Signal_Value (null); + + when Iir_Value_Signal + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + return Res; + end Create_Signal; + + Sig : Iir_Value_Literal_Acc; + Def : Iir_Value_Literal_Acc; + Slot : constant Object_Slot_Type := Get_Info (Signal).Slot; + begin + Sig := Create_Signal (Default); + Def := Unshare (Default, Global_Pool'Access); + Block.Objects (Slot) := Sig; + Block.Objects (Slot + 1) := Def; + + case Get_Kind (Signal) is + when Iir_Kind_Interface_Signal_Declaration => + case Get_Mode (Signal) is + when Iir_Unknown_Mode => + raise Internal_Error; + when Iir_Linkage_Mode => + Signals_Table.Append ((Mode_Linkage, + Signal, Sig, Def, Block)); + when Iir_Buffer_Mode => + Signals_Table.Append ((Mode_Buffer, + Signal, Sig, Def, Block)); + when Iir_Out_Mode => + Signals_Table.Append ((Mode_Out, + Signal, Sig, Def, Block)); + when Iir_Inout_Mode => + Signals_Table.Append ((Mode_Inout, + Signal, Sig, Def, Block)); + when Iir_In_Mode => + Signals_Table.Append ((Mode_In, + Signal, Sig, Def, Block)); + end case; + when Iir_Kind_Signal_Declaration => + Signals_Table.Append ((Mode_Signal, Signal, Sig, Def, Block)); + when others => + Error_Kind ("elaborate_signal", Signal); + end case; + end Elaborate_Signal; + + function Execute_Time_Attribute (Instance : Block_Instance_Acc; Attr : Iir) + return Ghdl_I64 + is + Param : constant Iir := Get_Parameter (Attr); + Res : Ghdl_I64; + Val : Iir_Value_Literal_Acc; + begin + if Param = Null_Iir then + Res := 0; + else + Val := Execute_Expression (Instance, Param); + Res := Val.I64; + end if; + return Res; + end Execute_Time_Attribute; + + procedure Elaborate_Implicit_Signal + (Instance: Block_Instance_Acc; Signal: Iir; Kind : Mode_Signal_Type) + is + Info : constant Sim_Info_Acc := Get_Info (Signal); + Prefix : Iir_Value_Literal_Acc; + T : Ghdl_I64; + Sig : Iir_Value_Literal_Acc; + Init : Iir_Value_Literal_Acc; + begin + if Kind = Mode_Transaction then + T := 0; + Init := Create_B1_Value (False); + else + T := Execute_Time_Attribute (Instance, Signal); + Init := Create_B1_Value (False); + end if; + Create_Signal (Instance, Signal); + Sig := Create_Signal_Value (null); + Init := Unshare (Init, Global_Pool'Access); + Instance.Objects (Info.Slot) := Sig; + Instance.Objects (Info.Slot + 1) := Init; + + Prefix := Execute_Name (Instance, Get_Prefix (Signal), True); + Prefix := Unshare_Bounds (Prefix, Global_Pool'Access); + case Kind is + when Mode_Stable => + Signals_Table.Append ((Kind => Mode_Stable, + Decl => Signal, + Sig => Sig, + Val => Init, + Instance => Instance, + Time => Std_Time (T), + Prefix => Prefix)); + when Mode_Quiet => + Signals_Table.Append ((Kind => Mode_Quiet, + Decl => Signal, + Sig => Sig, + Val => Init, + Instance => Instance, + Time => Std_Time (T), + Prefix => Prefix)); + when Mode_Transaction => + Signals_Table.Append ((Kind => Mode_Transaction, + Decl => Signal, + Sig => Sig, + Val => Init, + Instance => Instance, + Time => 0, + Prefix => Prefix)); + when others => + raise Internal_Error; + end case; + end Elaborate_Implicit_Signal; + + function Create_Delayed_Signal (Pfx : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Pfx.Kind is + when Iir_Value_Array => + Res := Create_Array_Value (Pfx.Val_Array.Len, + Pfx.Bounds.Nbr_Dims, + Global_Pool'Access); + Res.Bounds.D := Pfx.Bounds.D; + + for I in Pfx.Val_Array.V'Range loop + Res.Val_Array.V (I) := Create_Delayed_Signal + (Pfx.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + Res := Create_Record_Value (Pfx.Val_Record.Len, + Global_Pool'Access); + for I in Pfx.Val_Record.V'Range loop + Res.Val_Record.V (I) := Create_Delayed_Signal + (Pfx.Val_Record.V (I)); + end loop; + when Iir_Value_Signal => + Res := Create_Signal_Value (null); + when others => + raise Internal_Error; + end case; + return Res; + end Create_Delayed_Signal; + + procedure Elaborate_Delayed_Signal + (Instance: Block_Instance_Acc; Signal: Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Signal); + Prefix : Iir_Value_Literal_Acc; + Sig : Iir_Value_Literal_Acc; + Init : Iir_Value_Literal_Acc; + T : Ghdl_I64; + begin + Prefix := Execute_Name (Instance, Get_Prefix (Signal), True); + Prefix := Unshare_Bounds (Prefix, Global_Pool'Access); + + T := Execute_Time_Attribute (Instance, Signal); + + Sig := Create_Delayed_Signal (Prefix); + Create_Signal (Instance, Signal); + Instance.Objects (Info.Slot) := Sig; + + Init := Execute_Signal_Init_Value (Instance, Get_Prefix (Signal)); + Init := Unshare (Init, Global_Pool'Access); -- Create a full copy. + Instance.Objects (Info.Slot + 1) := Init; + + Signals_Table.Append ((Kind => Mode_Delayed, + Decl => Signal, + Sig => Sig, + Val => Init, + Instance => Instance, + Time => Std_Time (T), + Prefix => Prefix)); + end Elaborate_Delayed_Signal; + + -- Create a block instance to instantiate OBJ (block, component, + -- architecture, generate) in FATHER. STMT is the statement/declaration + -- at the origin of the instantiation (it is generally the same as OBJ, + -- except for component where STMT is the component instantation + -- statement). + function Create_Block_Instance + (Father : Block_Instance_Acc; + Obj : Iir; + Stmt : Iir) + return Block_Instance_Acc + is + Obj_Info : constant Sim_Info_Acc := Get_Info (Obj); + Res : Block_Instance_Acc; + begin + Nbr_Block_Instances := Nbr_Block_Instances + 1; + + Res := new Block_Instance_Type' + (Max_Objs => Obj_Info.Nbr_Objects, + Id => Nbr_Block_Instances, + Block_Scope => Obj_Info.Frame_Scope, + Up_Block => Father, + Label => Stmt, + Stmt => Obj, + Parent => Father, + Children => null, + Brother => null, + Ports_Map => Null_Iir, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + Actuals_Ref => null, + Result => null); + + if Father /= null then + case Obj_Info.Kind is + when Kind_Block + | Kind_Process => + Res.Brother := Father.Children; + Father.Children := Res; + when others => + null; + end case; + end if; + + return Res; + end Create_Block_Instance; + + procedure Elaborate_Package (Decl: Iir) + is + Package_Info : constant Sim_Info_Acc := Get_Info (Decl); + Instance : Block_Instance_Acc; + begin + Instance := Create_Block_Instance (null, Decl, Decl); + + Package_Instances (Package_Info.Frame_Scope.Pkg_Index) := Instance; + + if Trace_Elaboration then + Report_Msg (Msgid_Note, Errorout.Elaboration, No_Location, + "elaborating %n", (1 => +Decl)); + end if; + + if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then + Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Decl)); + Elaborate_Generic_Map_Aspect + (Instance, Instance, + Get_Generic_Chain (Decl), + Get_Generic_Map_Aspect_Chain (Decl)); + end if; + + -- Elaborate objects declarations. + Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); + + if Get_Kind (Decl) = Iir_Kind_Package_Instantiation_Declaration then + -- Elaborate the body now. + declare + Uninst : constant Iir := Get_Uninstantiated_Package_Decl (Decl); + begin + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Get_Package_Body (Uninst))); + end; + end if; + end Elaborate_Package; + + procedure Elaborate_Package_Body (Decl: Iir) + is + Package_Info : constant Sim_Info_Acc := Get_Info (Decl); + Instance : Block_Instance_Acc; + begin + Instance := Package_Instances (Package_Info.Frame_Scope.Pkg_Index); + + if Trace_Elaboration then + Report_Msg (Msgid_Note, Errorout.Elaboration, No_Location, + "elaborating %n", (1 => +Decl)); + end if; + + -- Elaborate objects declarations. + Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); + end Elaborate_Package_Body; + + procedure Elaborate_Configuration_Declaration (Decl : Iir) + is + Config_Info : constant Sim_Info_Acc := Get_Info (Decl); + Instance : Block_Instance_Acc; + begin + if Config_Info = null then + -- Not a user defined configuration. No objects. + pragma Assert (Get_Identifier (Decl) = Null_Identifier); + return; + end if; + + Instance := Create_Block_Instance (null, Decl, Decl); + + Package_Instances (Config_Info.Frame_Scope.Pkg_Index) := Instance; + + -- Elaborate objects declarations. + Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl)); + end Elaborate_Configuration_Declaration; + + -- Elaborate all packages which DESIGN_UNIT depends on. + -- The packages are elaborated only once. The body, if the package needs + -- one, can be loaded during the elaboration. + -- Recursive function. + -- FIXME: handle pathological cases of recursion. + -- Due to the rules of analysis, it is not possible to have a circulare + -- dependence. + procedure Elaborate_Dependence (Design_Unit: Iir_Design_Unit) + is + Depend_List : constant Iir_List := Get_Dependence_List (Design_Unit); + Depend_It : List_Iterator; + Design: Iir; + Library_Unit: Iir; + begin + Depend_It := List_Iterate_Safe (Depend_List); + while Is_Valid (Depend_It) loop + Design := Get_Element (Depend_It); + if Get_Kind (Design) = Iir_Kind_Entity_Aspect_Entity then + -- During Sem, the architecture may be still unknown, and the + -- dependency is therefore the aspect. + Library_Unit := Strip_Denoting_Name (Get_Architecture (Design)); + case Get_Kind (Library_Unit) is + when Iir_Kind_Architecture_Body => + Design := Get_Design_Unit (Library_Unit); + when Iir_Kind_Design_Unit => + Design := Library_Unit; + Library_Unit := Get_Library_Unit (Design); + when others => + Error_Kind ("elaborate_dependence(1)", Library_Unit); + end case; + else + Library_Unit := Get_Library_Unit (Design); + end if; + -- Elaborates only non-elaborated packages. + case Get_Kind (Library_Unit) is + when Iir_Kind_Package_Declaration => + declare + Info : constant Sim_Info_Acc := Get_Info (Library_Unit); + Body_Design: Iir_Design_Unit; + begin + if not Is_Uninstantiated_Package (Library_Unit) + and then + Package_Instances (Info.Frame_Scope.Pkg_Index) = null + then + -- Package not yet elaborated. + + -- Load the body now, as it can add objects in the + -- package instance. + -- Don't try to load optionnal but obsolete package body. + Body_Design := Libraries.Find_Secondary_Unit + (Design, Null_Identifier); + if Body_Design /= Null_Iir + and then + (Get_Need_Body (Library_Unit) + or else Get_Date (Body_Design) /= Date_Obsolete) + then + Libraries.Load_Design_Unit (Body_Design, Design_Unit); + else + Body_Design := Null_Iir; + end if; + + -- First the packages on which DESIGN depends. + Elaborate_Dependence (Design); + + -- Then the declaration. + Elaborate_Package (Library_Unit); + + -- And then the body (if any). + if Body_Design = Null_Iir then + if Get_Need_Body (Library_Unit) then + Error_Msg_Elab + ("no package body for `" & + Image_Identifier (Library_Unit) & '''); + end if; + else + -- Note: the body can elaborate some packages. + Elaborate_Dependence (Body_Design); + + Elaborate_Package_Body + (Get_Library_Unit (Body_Design)); + end if; + end if; + end; + when Iir_Kind_Package_Instantiation_Declaration => + declare + Info : constant Sim_Info_Acc := Get_Info (Library_Unit); + begin + if Package_Instances (Info.Frame_Scope.Pkg_Index) = null + then + -- Package not yet elaborated. + + -- First the packages on which DESIGN depends. + Elaborate_Dependence (Design); + + -- Then the declaration. + Elaborate_Package (Library_Unit); + end if; + end; + when Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Architecture_Body => + Elaborate_Dependence (Design); + when Iir_Kind_Package_Body => + -- For package instantiation. + Elaborate_Dependence (Design); + when Iir_Kind_Context_Declaration => + Elaborate_Dependence (Design); + when others => + Error_Kind ("elaborate_dependence", Library_Unit); + end case; + Next (Depend_It); + end loop; + end Elaborate_Dependence; + + function Create_Protected_Object (Block: Block_Instance_Acc; Decl: Iir) + return Iir_Value_Literal_Acc + is + Bod : constant Iir := Get_Protected_Type_Body (Decl); + Inst : Block_Instance_Acc; + Res : Iir_Value_Literal_Acc; + begin + Protected_Table.Increment_Last; + Res := Create_Protected_Value (Protected_Table.Last); + + Inst := Create_Subprogram_Instance (Block, null, Bod); + Protected_Table.Table (Res.Prot) := Inst; + + -- Temporary put the instancce on the stack in case of function calls + -- during the elaboration of the protected object. + Current_Process.Instance := Inst; + + Elaborate_Declarative_Part (Inst, Get_Declaration_Chain (Bod)); + + Current_Process.Instance := Block; + + return Res; + end Create_Protected_Object; + + -- Create an value_literal for DECL (defined in BLOCK) and set it with + -- its default values. Nodes are shared. + function Create_Value_For_Type + (Block: Block_Instance_Acc; Decl: Iir; Init : Init_Value_Kind) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc; + begin + case Get_Kind (Decl) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Physical_Type_Definition => + case Init is + when Init_Value_Default => + Bounds := Execute_Bounds (Block, Decl); + Res := Bounds.Left; + when Init_Value_Any => + case Iir_Value_Scalars + (Get_Info (Get_Base_Type (Decl)).Scalar_Mode) + is + when Iir_Value_B1 => + Res := Create_B1_Value (False); + when Iir_Value_E8 => + Res := Create_E8_Value (0); + when Iir_Value_E32 => + Res := Create_E32_Value (0); + when Iir_Value_I64 => + Res := Create_I64_Value (0); + when Iir_Value_F64 => + Res := Create_F64_Value (0.0); + end case; + when Init_Value_Signal => + Res := Create_Signal_Value (null); + end case; + + when Iir_Kind_Array_Subtype_Definition => + Res := Create_Array_Bounds_From_Type (Block, Decl, True); + declare + El_Type : constant Iir := Get_Element_Subtype (Decl); + El_Val : Iir_Value_Literal_Acc; + begin + if Res.Val_Array.Len > 0 then + -- Aliases the elements, for speed. If modified, the + -- value will first be copied which will unalias it. + El_Val := Create_Value_For_Type (Block, El_Type, Init); + for I in 1 .. Res.Val_Array.Len loop + Res.Val_Array.V (I) := El_Val; + end loop; + end if; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (Decl)); + El : Iir_Element_Declaration; + begin + Res := Create_Record_Value + (Iir_Index32 (Get_Nbr_Elements (List))); + + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Res.Val_Record.V (1 + Get_Element_Position (El)) := + Create_Value_For_Type (Block, Get_Type (El), Init); + end loop; + end; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return Create_Access_Value (null); + when Iir_Kind_Protected_Type_Declaration => + return Create_Protected_Object (Block, Decl); + when others => + Error_Kind ("create_value_for_type", Decl); + end case; + return Res; + end Create_Value_For_Type; + + procedure Init_To_Default + (Targ : Iir_Value_Literal_Acc; Block: Block_Instance_Acc; Atype : Iir) is + begin + case Get_Kind (Atype) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Physical_Type_Definition => + declare + Bounds : Iir_Value_Literal_Acc; + begin + Bounds := Execute_Bounds (Block, Atype); + Store (Targ, Bounds.Left); + end; + + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + declare + El_Type : constant Iir := Get_Element_Subtype (Atype); + begin + for I in 1 .. Targ.Val_Array.Len loop + Init_To_Default (Targ.Val_Array.V (I), Block, El_Type); + end loop; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (Atype)); + El : Iir_Element_Declaration; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Init_To_Default (Targ.Val_Record.V (1 + Iir_Index32 (I)), + Block, Get_Type (El)); + end loop; + end; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + Store (Targ, Null_Lit); + when others => + Error_Kind ("Init_To_Default", Atype); + end case; + end Init_To_Default; + + function Create_Terminal_Object (Block: Block_Instance_Acc; + Decl : Iir; + Def: Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + Res := Create_Terminal_Value + (Create_Scalar_Terminal (Decl, Block)); + when others => + Error_Kind ("create_terminal_object", Def); + end case; + return Res; + end Create_Terminal_Object; + + procedure Create_Terminal (Instance : Block_Instance_Acc; Decl : Iir) + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + begin + if Slot + 1 = Instance.Elab_Objects then + -- Reference terminal of nature declaration may have already been + -- elaborated. + return; + end if; + if Slot /= Instance.Elab_Objects then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Instance.Objects (Slot) := + Create_Terminal_Object (Instance, Decl, Get_Nature (Decl)); + Instance.Elab_Objects := Slot + 1; + end Create_Terminal; + + function Create_Quantity_Object (Block: Block_Instance_Acc; + Decl : Iir; + Def: Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Kind : Quantity_Kind; + begin + case Get_Kind (Def) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + case Iir_Kinds_Quantity_Declaration (Get_Kind (Decl)) is + when Iir_Kind_Across_Quantity_Declaration => + Kind := Quantity_Across; + when Iir_Kind_Through_Quantity_Declaration => + Kind := Quantity_Through; + when Iir_Kind_Free_Quantity_Declaration => + Kind := Quantity_Free; + end case; + Res := Create_Quantity_Value + (Create_Scalar_Quantity (Kind, Decl, Block)); + when others => + Error_Kind ("create_quantity_object", Def); + end case; + return Res; + end Create_Quantity_Object; + + function Create_Quantity (Instance : Block_Instance_Acc; Decl : Iir) + return Iir_Value_Literal_Acc + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + Res : Iir_Value_Literal_Acc; + begin + if Slot /= Instance.Elab_Objects then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Res := Create_Quantity_Object (Instance, Decl, Get_Type (Decl)); + Instance.Objects (Slot) := Res; + Instance.Elab_Objects := Slot + 1; + return Res; + end Create_Quantity; + + procedure Elaborate_Range_Expression + (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression) + is + Range_Info : constant Sim_Info_Acc := Get_Info (Rc); + Val : Iir_Value_Literal_Acc; + begin + if Range_Info.Obj_Scope /= Instance.Block_Scope + or else Instance.Objects (Range_Info.Slot) /= null + then + -- A range expression may have already been created, for example + -- when severals objects are created with the same subtype: + -- variable v, v1 : bit_vector (x to y); + return; + end if; + if False + and then (Range_Info.Obj_Scope /= Instance.Block_Scope + or else Range_Info.Slot < Instance.Elab_Objects) + then + -- FIXME: the test is wrong for packages. + -- The range was already elaborated. + -- ?? Is that possible + raise Internal_Error; + return; + end if; + Create_Object (Instance, Rc); + Val := Create_Range_Value + (Execute_Expression (Instance, Get_Left_Limit (Rc)), + Execute_Expression (Instance, Get_Right_Limit (Rc)), + Get_Direction (Rc)); + -- Check constraints. + if not Is_Null_Range (Val) then + Check_Constraints (Instance, Val.Left, Get_Type (Rc), Rc); + Check_Constraints (Instance, Val.Right, Get_Type (Rc), Rc); + end if; + Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool); + end Elaborate_Range_Expression; + + procedure Elaborate_Range_Constraint + (Instance : Block_Instance_Acc; Rc: Iir) is + begin + case Get_Kind (Rc) is + when Iir_Kind_Range_Expression => + Elaborate_Range_Expression (Instance, Rc); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + null; + when others => + Error_Kind ("elaborate_range_constraint", Rc); + end case; + end Elaborate_Range_Constraint; + + -- Create the bounds of a scalar type definition. + -- Elaborate_Range_Constraint cannot be used, as it checks bounds (and + -- here we create the bounds). + procedure Elaborate_Type_Range + (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression) + is + Range_Info : Sim_Info_Acc; + Val : Iir_Value_Literal_Acc; + begin + Range_Info := Get_Info (Rc); + Create_Object (Instance, Rc); + Val := Create_Range_Value + (Execute_Expression (Instance, Get_Left_Limit (Rc)), + Execute_Expression (Instance, Get_Right_Limit (Rc)), + Get_Direction (Rc)); + Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool); + end Elaborate_Type_Range; + + -- DECL is a subtype indication. + -- Elaborate DECL only if it is anonymous. + procedure Elaborate_Subtype_Indication_If_Anonymous + (Instance : Block_Instance_Acc; Decl : Iir) is + begin + if Is_Anonymous_Type_Definition (Decl) then + Elaborate_Subtype_Indication (Instance, Decl); + end if; + end Elaborate_Subtype_Indication_If_Anonymous; + + -- LRM93 §12.3.1.3 Subtype Declarations + -- The elaboration of a subtype indication creates a subtype. + procedure Elaborate_Subtype_Indication + (Instance : Block_Instance_Acc; Ind : Iir) + is + begin + case Get_Kind (Ind) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Record_Type_Definition => + Elaborate_Type_Definition (Instance, Ind); + when Iir_Kind_Array_Subtype_Definition => + -- LRM93 12.3.1.3 + -- The elaboration of an index constraint consists of the + -- declaration of each of the discrete ranges in the index + -- constraint in some order that is not defined by the language. + declare + St_Indexes : constant Iir_Flist := Get_Index_Subtype_List (Ind); + St_El : Iir; + begin + for I in Flist_First .. Flist_Last (St_Indexes) loop + St_El := Get_Index_Type (St_Indexes, I); + Elaborate_Subtype_Indication_If_Anonymous (Instance, St_El); + end loop; + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Element_Subtype (Ind)); + end; + when Iir_Kind_Record_Subtype_Definition => + null; + when Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind)); + when Iir_Kind_Physical_Subtype_Definition => + Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind)); + when others => + Error_Kind ("elaborate_subtype_indication", Ind); + end case; + end Elaborate_Subtype_Indication; + + -- LRM93 §12.3.1.2 Type Declarations. + procedure Elaborate_Type_Definition + (Instance : Block_Instance_Acc; Def : Iir) + is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + -- Elaboration of an enumeration type definition has not effect + -- other than the creation of the corresponding type. + Elaborate_Type_Range (Instance, Get_Range_Constraint (Def)); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + null; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + -- Elaboration of an integer, floating point, or physical type + -- definition consists of the elaboration of the corresponding + -- range constraint. + Elaborate_Subtype_Indication_If_Anonymous (Instance, Def); + -- Elaboration of a physical unit declaration has no effect other + -- than to create the unit defined by the unit declaration. + null; + when Iir_Kind_Array_Type_Definition => + -- Elaboration of an unconstrained array type definition consists + -- of the elaboration of the element subtype indication of the + -- array type. + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Element_Subtype (Def)); + when Iir_Kind_Access_Type_Definition => + -- Elaboration of an access type definition consists of the + -- elaboration of the corresponding subtype indication. + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Designated_Type (Def)); + when Iir_Kind_File_Type_Definition => + -- GHDL: There is nothing about elaboration of a file type + -- definition. FIXME ?? + null; + when Iir_Kind_Record_Type_Definition => + -- Elaboration of a record type definition consists of the + -- elaboration of the equivalent single element declarations in + -- the given order. + declare + List : constant Iir_Flist := + Get_Elements_Declaration_List (Def); + El : Iir_Element_Declaration; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + -- Elaboration of an element declaration consists of + -- elaboration of the element subtype indication. + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (El)); + end loop; + end; + when Iir_Kind_Protected_Type_Declaration => + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Def)); + + when Iir_Kind_Incomplete_Type_Definition => + null; + when others => + Error_Kind ("elaborate_type_definition", Def); + end case; + end Elaborate_Type_Definition; + + -- LRM93 §12.3.1.2 Type Declarations. + procedure Elaborate_Type_Declaration + (Instance : Block_Instance_Acc; Decl : Iir_Type_Declaration) + is + Def : Iir; + Base_Type : Iir_Array_Type_Definition; + begin + -- Elaboration of a type declaration generally consists of the + -- elaboration of the definition of the type and the creation of that + -- type. + Def := Get_Type_Definition (Decl); + if Def = Null_Iir then + -- FIXME: can this happen ? + raise Program_Error; + end if; + if Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition then + Base_Type := Get_Base_Type (Def); + -- For a constrained array type declaration, however, + -- elaboration consists of the elaboration of the equivalent + -- anonymous unconstrained array type [...] + Elaborate_Subtype_Indication_If_Anonymous (Instance, Base_Type); + -- [...] followed by the elaboration of the named subtype + -- of that unconstrained type. + Elaborate_Subtype_Indication (Instance, Def); + else + Elaborate_Type_Definition (Instance, Def); + end if; + end Elaborate_Type_Declaration; + + procedure Elaborate_Nature_Definition + (Instance : Block_Instance_Acc; Def : Iir) + is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + Elaborate_Subtype_Indication (Instance, Get_Across_Type (Def)); + Elaborate_Subtype_Indication (Instance, Get_Through_Type (Def)); + when others => + Error_Kind ("elaborate_nature_definition", Def); + end case; + end Elaborate_Nature_Definition; + + -- LRM93 12.2.1 The Generic Clause + -- LRM08 14.3.2 Generic clause + procedure Elaborate_Generic_Clause + (Instance : Block_Instance_Acc; Generic_Chain : Iir) + is + Decl : Iir_Interface_Constant_Declaration; + begin + -- LRM08 14.3.2 Generic clause + -- Elaboration of a generic clause consists of the elaboration of each + -- of the equivalent single generic declarations contained in the + -- clause, in the order given. + Decl := Generic_Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Interface_Constant_Declaration => + -- LRM93 12.2.2 The generic clause + -- The elaboration of a generic declaration consists of + -- elaborating the subtype indication and then creating a + -- generic constant of that subtype. + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Create_Object (Instance, Decl); + -- The value of a generic constant is not defined until a + -- subsequent generic map aspect is evaluated, or in the + -- absence of a generic map aspect, until the default + -- expression associated with the generic constant is evaluated + -- to determine the value of the constant. + when Iir_Kind_Interface_Package_Declaration => + Create_Object (Instance, Get_Info (Decl).Env_Slot); + when others => + Error_Kind ("elaborate_generic_clause", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Elaborate_Generic_Clause; + + -- LRM93 12.2.3 The Port Clause + procedure Elaborate_Port_Clause + (Instance : Block_Instance_Acc; Port_Chain : Iir) + is + Decl : Iir_Interface_Signal_Declaration; + begin + Decl := Port_Chain; + while Decl /= Null_Iir loop + -- LRM93 §12.2.3 + -- The elaboration of a port declaration consists of elaborating the + -- subtype indication and then creating a port of that subtype. + Elaborate_Subtype_Indication_If_Anonymous (Instance, Get_Type (Decl)); + + -- Simply increase an index to check that the port was created. + Create_Signal (Instance, Decl); + + Decl := Get_Chain (Decl); + end loop; + end Elaborate_Port_Clause; + + -- LRM93 §12.2.2 The generic Map Aspect + procedure Elaborate_Generic_Map_Aspect + (Target_Instance : Block_Instance_Acc; + Local_Instance : Block_Instance_Acc; + Generics : Iir; + Map : Iir) + is + Assoc : Iir; + Gen : Iir; + Inter : Iir_Interface_Constant_Declaration; + Value : Iir; + Val : Iir_Value_Literal_Acc; + Last_Individual : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + -- Elaboration of a generic map aspect consists of elaborating the + -- generic association list. + + -- Elaboration of a generic association list consists of the + -- elaboration of each generic association element in the + -- association list. + Assoc := Map; + Gen := Generics; + Mark (Marker, Expr_Pool); + while Assoc /= Null_Iir loop + -- Elaboration of a generic association element consists of the + -- elaboration of the formal part and the evaluation of the actual + -- part. + -- FIXME: elaboration of the formal part. + Inter := Get_Association_Interface (Assoc, Gen); + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + -- The generic association list contains an implicit + -- association element for each generic constant that is not + -- explicitly associated with an actual [GHDL: done trought + -- annotations] or that is associated with the reserved word + -- OPEN; the actual part of such an implicit association + -- element is the default expression appearing in the + -- declaration of that generic constant. + Value := Get_Default_Value (Inter); + if Value /= Null_Iir then + Val := Execute_Expression (Target_Instance, Value); + else + Val := Create_Value_For_Type + (Target_Instance, Get_Type (Inter), + Init_Value_Default); + end if; + when Iir_Kind_Association_Element_By_Expression => + Value := Get_Actual (Assoc); + Val := Execute_Expression (Local_Instance, Value); + when Iir_Kind_Association_Element_By_Individual => + Val := Create_Value_For_Type + (Local_Instance, Get_Actual_Type (Assoc), Init_Value_Any); + + Last_Individual := Unshare (Val, Instance_Pool); + Target_Instance.Objects (Get_Info (Inter).Slot) := + Last_Individual; + goto Continue; + when Iir_Kind_Association_Element_Package => + declare + Actual : constant Iir := + Strip_Denoting_Name (Get_Actual (Assoc)); + Info : constant Sim_Info_Acc := Get_Info (Actual); + Pkg_Block : Block_Instance_Acc; + begin + Pkg_Block := Get_Instance_By_Scope + (Local_Instance, Info.Frame_Scope); + Environment_Table.Append (Pkg_Block); + Val := Create_Environment_Value (Environment_Table.Last); + Target_Instance.Objects (Get_Info (Inter).Env_Slot) := + Unshare (Val, Instance_Pool); + end; + + goto Continue; + when others => + Error_Kind ("elaborate_generic_map_aspect", Assoc); + end case; + + if Get_Whole_Association_Flag (Assoc) then + -- It is an error if the value of the actual does not belong to + -- the subtype denoted by the subtype indication of the formal. + -- If the subtype denoted by the subtype indication of the + -- declaration of the formal is a constrained array subtype, then + -- an implicit subtype conversion is performed prior to this + -- check. + -- It is also an error if the type of the formal is an array type + -- and the value of each element of the actual does not belong to + -- the element subtype of the formal. + Implicit_Array_Conversion + (Target_Instance, Val, Get_Type (Inter), Inter); + Check_Constraints (Target_Instance, Val, Get_Type (Inter), Inter); + + -- The generic constant or subelement or slice thereof designated + -- by the formal part is then initialized with the value + -- resulting from the evaluation of the corresponding actual part. + Target_Instance.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + else + declare + Targ : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base + (Target_Instance, Get_Formal (Assoc), + Last_Individual, Targ, Is_Sig); + Store (Targ, Val); + end; + end if; + + <> null; + Release (Marker, Expr_Pool); + Next_Association_Interface (Assoc, Gen); + end loop; + end Elaborate_Generic_Map_Aspect; + + -- LRM93 12.2.3 The Port Clause + procedure Elaborate_Port_Declaration + (Instance : Block_Instance_Acc; + Decl : Iir_Interface_Signal_Declaration; + Default_Value : Iir_Value_Literal_Acc) + is + Val : Iir_Value_Literal_Acc; + begin + if Default_Value = null then + Val := Elaborate_Default_Value (Instance, Decl); + else + Val := Default_Value; + end if; + Elaborate_Signal (Instance, Decl, Val); + end Elaborate_Port_Declaration; + + procedure Elab_Connect + (Formal_Instance : Block_Instance_Acc; + Local_Instance : Block_Instance_Acc; + Actual_Expr : Iir_Value_Literal_Acc; + Assoc : Iir_Association_Element_By_Expression; + Inter : Iir) + is + Formal : Iir; + Actual : Iir; + Local_Expr : Iir_Value_Literal_Acc; + Formal_Expr : Iir_Value_Literal_Acc; + begin + Formal := Get_Association_Formal (Assoc, Inter); + Actual := Get_Actual (Assoc); + Formal_Expr := Execute_Name (Formal_Instance, Formal, True); + Formal_Expr := Unshare_Bounds (Formal_Expr, Global_Pool'Access); + if Actual_Expr = null then + Local_Expr := Execute_Name (Local_Instance, Actual, True); + Local_Expr := Unshare_Bounds (Local_Expr, Global_Pool'Access); + else + Local_Expr := Actual_Expr; + end if; + + Connect_Table.Append ((Formal => Formal_Expr, + Formal_Instance => Formal_Instance, + Actual => Local_Expr, + Actual_Instance => Local_Instance, + Inter => Inter, + Assoc => Assoc)); + end Elab_Connect; + + -- LRM93 12.2.3 The Port Clause + -- LRM93 §12.2.4 The Port Map Aspect + procedure Elaborate_Port_Map_Aspect + (Formal_Instance : Block_Instance_Acc; + Actual_Instance : Block_Instance_Acc; + Ports : Iir; + Map : Iir) + is + Assoc : Iir; + Port : Iir; + Inter : Iir_Interface_Signal_Declaration; + Actual_Expr : Iir_Value_Literal_Acc; + Init_Expr : Iir_Value_Literal_Acc; + Actual : Iir; + Formal : Iir; + begin + pragma Assert (Formal_Instance.Ports_Map = Null_Iir); + Formal_Instance.Ports_Map := Map; + + if Ports = Null_Iir then + return; + end if; + + -- Elaboration of a port map aspect consists of elaborating the port + -- association list. + if Map = Null_Iir then + -- No port association, elaborate the port clause. + -- Elaboration of a port clause consists of the elaboration of each + -- of the equivalent signal port declaration in the clause, in the + -- order given. + Inter := Ports; + while Inter /= Null_Iir loop + Elaborate_Port_Declaration (Formal_Instance, Inter, null); + Inter := Get_Chain (Inter); + end loop; + return; + end if; + + Assoc := Map; + Port := Ports; + while Assoc /= Null_Iir loop + -- Elaboration of a port association list consists of the elaboration + -- of each port association element in the association list whose + -- actual is not the reserved word OPEN. + Inter := Get_Association_Interface (Assoc, Port); + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Actual_Conversion (Assoc) = Null_Iir + and then Get_Formal_Conversion (Assoc) = Null_Iir + then + Actual := Get_Actual (Assoc); + Formal := Get_Association_Formal (Assoc, Inter); + if Is_Signal_Name (Actual) then + -- Association with a signal + Init_Expr := Execute_Signal_Init_Value + (Actual_Instance, Actual); + Implicit_Array_Conversion + (Formal_Instance, Init_Expr, Get_Type (Formal), Actual); + Init_Expr := Unshare_Bounds + (Init_Expr, Global_Pool'Access); + Actual_Expr := null; + else + -- Association with an expression + Init_Expr := Execute_Expression + (Actual_Instance, Actual); + Implicit_Array_Conversion + (Formal_Instance, Init_Expr, Get_Type (Formal), Actual); + Init_Expr := Unshare (Init_Expr, Global_Pool'Access); + Actual_Expr := Init_Expr; + end if; + else + -- The actual doesn't define the constraints of the formal. + if Get_Whole_Association_Flag (Assoc) then + Init_Expr := Elaborate_Default_Value + (Formal_Instance, Inter); + Actual_Expr := null; + end if; + end if; + + if Get_Whole_Association_Flag (Assoc) + and then Get_Collapse_Signal_Flag (Assoc) + then + pragma Assert (Get_Actual_Conversion (Assoc) = Null_Iir); + pragma Assert (Get_Formal_Conversion (Assoc) = Null_Iir); + pragma Assert (Is_Signal_Name (Get_Actual (Assoc))); + declare + Slot : constant Object_Slot_Type := + Get_Info (Inter).Slot; + Actual_Sig : Iir_Value_Literal_Acc; + Default_Value : Iir; + Val : Iir_Value_Literal_Acc; + begin + Actual_Sig := + Execute_Name (Actual_Instance, Actual, True); + Implicit_Array_Conversion + (Formal_Instance, Actual_Sig, + Get_Type (Inter), Actual); + Formal_Instance.Objects (Slot) := Unshare_Bounds + (Actual_Sig, Global_Pool'Access); + Formal_Instance.Objects (Slot + 1) := Init_Expr; + if Get_Mode (Inter) = Iir_Out_Mode then + Default_Value := Get_Default_Value (Inter); + if Default_Value /= Null_Iir then + Val := Execute_Expression_With_Type + (Formal_Instance, Default_Value, + Get_Type (Inter)); + Store (Formal_Instance.Objects (Slot + 1), Val); + else + Init_To_Default + (Formal_Instance.Objects (Slot + 1), + Formal_Instance, Get_Type (Inter)); + end if; + end if; + end; + else + if Get_Whole_Association_Flag (Assoc) then + Elaborate_Signal (Formal_Instance, Inter, Init_Expr); + end if; + + -- Elaboration of a port association element consists of the + -- elaboration of the formal part; the port or subelement + -- or slice thereof designated by the formal part is then + -- associated with the signal or expression designated + -- by the actual part. + Elab_Connect (Formal_Instance, Actual_Instance, Actual_Expr, + Assoc, Inter); + end if; + + when Iir_Kind_Association_Element_Open => + -- Note that an open cannot be associated with a formal that + -- is associated individually. + Elaborate_Port_Declaration (Formal_Instance, Inter, null); + + when Iir_Kind_Association_Element_By_Individual => + Init_Expr := Create_Value_For_Type + (Formal_Instance, Get_Actual_Type (Assoc), Init_Value_Any); + Elaborate_Signal (Formal_Instance, Inter, Init_Expr); + + when others => + Error_Kind ("elaborate_port_map_aspect", Assoc); + end case; + Next_Association_Interface (Assoc, Port); + end loop; + end Elaborate_Port_Map_Aspect; + + -- LRM93 §12.2 Elaboration of a block header + -- Elaboration of a block header consists of the elaboration of the + -- generic clause, the generic map aspect, the port clause, and the port + -- map aspect, in that order. + procedure Elaborate_Block_Header + (Instance : Block_Instance_Acc; Header : Iir_Block_Header) + is + begin + Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Header)); + Elaborate_Generic_Map_Aspect + (Instance, Instance, + Get_Generic_Chain (Header), + Get_Generic_Map_Aspect_Chain (Header)); + Elaborate_Port_Clause (Instance, Get_Port_Chain (Header)); + Elaborate_Port_Map_Aspect + (Instance, Instance, + Get_Port_Chain (Header), Get_Port_Map_Aspect_Chain (Header)); + end Elaborate_Block_Header; + + procedure Elaborate_Guard_Signal + (Instance : Block_Instance_Acc; Guard : Iir) + is + Sig, Val : Iir_Value_Literal_Acc; + Info : constant Sim_Info_Acc := Get_Info (Guard); + begin + Create_Signal (Instance, Guard); + + Sig := Create_Signal_Value (null); + Val := Unshare (Create_B1_Value (False), Instance_Pool); + Instance.Objects (Info.Slot) := Sig; + Instance.Objects (Info.Slot + 1) := Val; + + Signals_Table.Append ((Kind => Mode_Guard, + Decl => Guard, + Sig => Sig, + Val => Val, + Instance => Instance)); + end Elaborate_Guard_Signal; + + -- LRM93 §12.4.1 Block statements. + procedure Elaborate_Block_Statement + (Instance : Block_Instance_Acc; Block : Iir_Block_Statement) + is + Header : Iir_Block_Header; + Ninstance : Block_Instance_Acc; -- FIXME + Guard : Iir; + begin + Ninstance := Create_Block_Instance (Instance, Block, Block); + + Guard := Get_Guard_Decl (Block); + if Guard /= Null_Iir then + -- LRM93 12.6.4 (3) + -- The value of each implicit GUARD signal is set to the result of + -- evaluating the corresponding guard expression. + -- GHDL: done by grt when the guard signal is created. + Elaborate_Guard_Signal (Ninstance, Guard); + end if; + + -- Elaboration of a block statement consists of the elaboration of the + -- block header, if present [...] + Header := Get_Block_Header (Block); + if Header /= Null_Iir then + Elaborate_Block_Header (Ninstance, Header); + end if; + + -- [...] followed by the elaboration of the block declarative part [...] + Elaborate_Declarative_Part (Ninstance, + Get_Declaration_Chain (Block)); + -- [...] followed by the elaboration of the block statement part. + Elaborate_Statement_Part + (Ninstance, Get_Concurrent_Statement_Chain (Block)); + -- Elaboration of a block statement may occur under the control of a + -- configuration declaration. + -- In particular, a block configuration, wether implicit or explicit, + -- within a configuration declaration may supply a sequence of + -- additionnal implicit configuration specification to be applied + -- during the elaboration of the corresponding block statement. + -- If a block statement is being elaborated under the control of a + -- configuration declaration, then the sequence of implicit + -- configuration specifications supplied by the block configuration + -- is elaborated as part of the block declarative part, following all + -- other declarative items in that part. + -- The sequence of implicit configuration specifications supplied by a + -- block configuration, wether implicit or explicit, consists of each of + -- the configuration specifications implied by component configurations + -- occurring immediatly within the block configuration, and in the + -- order in which the component configurations themselves appear. + -- FIXME. + end Elaborate_Block_Statement; + + function Create_Default_Association (Formal_Chain : Iir; + Local_Chain : Iir; + Node : Iir) + return Iir + is + Nbr_Formals : Natural; + begin + -- LRM93 5.2.2 + -- The default binding indication includes a default generic map + -- aspect if the design entity implied by the entity aspect contains + -- formal generic. + -- + -- LRM93 5.2.2 + -- The default binding indication includes a default port map aspect if + -- the design entity implied by the entity aspect contains formal ports. + if Formal_Chain = Null_Iir then + if Local_Chain /= Null_Iir then + Error_Msg_Sem (+Node, "cannot create default map aspect"); + end if; + return Null_Iir; + end if; + Nbr_Formals := Get_Chain_Length (Formal_Chain); + declare + Assoc_List : Iir_Array (0 .. Nbr_Formals - 1) := (others => Null_Iir); + Assoc : Iir; + Local : Iir; + Formal : Iir; + Pos : Natural; + First, Last : Iir; + begin + -- LRM93 5.2.2 + -- The default generic map aspect associates each local generic in + -- the corresponding component instantiation (if any) with a formal + -- of the same simple name. + Local := Local_Chain; + while Local /= Null_Iir loop + Formal := Formal_Chain; + Pos := 0; + while Formal /= Null_Iir loop + exit when Get_Identifier (Formal) = Get_Identifier (Local); + Formal := Get_Chain (Formal); + Pos := Pos + 1; + end loop; + if Formal = Null_Iir then + -- LRM93 5.2.2 + -- It is an error if such a formal does not exist, or if + -- its mode and type are not appropriate for such an + -- association. + -- FIXME: mode/type check. + Error_Msg_Sem (+Node, "cannot associate local %n", +Local); + exit; + end if; + if Assoc_List (Pos) /= Null_Iir then + raise Internal_Error; + end if; + Assoc_List (Pos) := Local; + + Local := Get_Chain (Local); + end loop; + + Sub_Chain_Init (First, Last); + Formal := Formal_Chain; + for I in Assoc_List'Range loop + if Assoc_List (I) = Null_Iir then + -- LRM93 5.2.2 + -- Any remaining unassociated formals are associated with the + -- actual designator any. + Assoc := Create_Iir (Iir_Kind_Association_Element_Open); + else + Assoc := + Create_Iir (Iir_Kind_Association_Element_By_Expression); + Set_Actual (Assoc, Assoc_List (I)); + end if; + Set_Whole_Association_Flag (Assoc, True); + Set_Formal (Assoc, Formal); + Sub_Chain_Append (First, Last, Assoc); + + Formal := Get_Chain (Formal); + end loop; + return First; + end; + end Create_Default_Association; + + -- LRM93 §12.4.3 + function Is_Fully_Bound (Conf : Iir) return Boolean + is + Binding : Iir; + begin + if Conf = Null_Iir then + return False; + end if; + case Get_Kind (Conf) is + when Iir_Kind_Configuration_Specification + | Iir_Kind_Component_Configuration => + Binding := Get_Binding_Indication (Conf); + if Binding = Null_Iir then + return False; + end if; + if Get_Kind (Get_Entity_Aspect (Binding)) + = Iir_Kind_Entity_Aspect_Open + then + return False; + end if; + when others => + null; + end case; + return True; + end Is_Fully_Bound; + + procedure Elaborate_Component_Instantiation + (Instance : Block_Instance_Acc; + Stmt : Iir_Component_Instantiation_Statement) + is + Frame : Block_Instance_Acc; + begin + if Is_Component_Instantiation (Stmt) then + declare + Component : constant Iir := + Get_Named_Entity (Get_Instantiated_Unit (Stmt)); + begin + -- Elaboration of a component instantiation statement that + -- instanciates a component declaration has no effect unless the + -- component instance is either fully bound to a design entity + -- defined by an entity declaration and architecture body or is + -- bound to a configuration of such a design entity. + -- FIXME: in fact the component is created. + + -- If a component instance is so bound, then elaboration of the + -- corresponding component instantiation statement consists of the + -- elaboration of the implied block statement representing the + -- component instance and [...] + Frame := Create_Block_Instance (Instance, Component, Stmt); + + Current_Component := Frame; + Elaborate_Generic_Clause (Frame, Get_Generic_Chain (Component)); + Elaborate_Generic_Map_Aspect + (Frame, Instance, + Get_Generic_Chain (Component), + Get_Generic_Map_Aspect_Chain (Stmt)); + Elaborate_Port_Clause (Frame, Get_Port_Chain (Component)); + Elaborate_Port_Map_Aspect + (Frame, Instance, + Get_Port_Chain (Component), Get_Port_Map_Aspect_Chain (Stmt)); + Current_Component := null; + end; + else + -- Direct instantiation + declare + Aspect : constant Iir := Get_Instantiated_Unit (Stmt); + Arch : Iir; + Config : Iir; + begin + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Arch := Get_Architecture (Aspect); + if Arch = Null_Iir then + Arch := Libraries.Get_Latest_Architecture + (Get_Entity (Aspect)); + else + Arch := Strip_Denoting_Name (Arch); + end if; + Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Configuration (Aspect); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + when others => + raise Internal_Error; + end case; + Config := Get_Block_Configuration (Config); + + Frame := Elaborate_Architecture + (Arch, Config, Instance, Stmt, + Get_Generic_Map_Aspect_Chain (Stmt), + Get_Port_Map_Aspect_Chain (Stmt)); + end; + end if; + end Elaborate_Component_Instantiation; + + -- LRM93 12.4.2 Generate Statements + procedure Elaborate_If_Generate_Statement + (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement) + is + Clause : Iir; + Cond : Iir; + Bod : Iir; + Ninstance : Block_Instance_Acc; + Lit : Iir_Value_Literal_Acc; + begin + -- LRM93 12.4.2 + -- For a generate statement with an if generation scheme, elaboration + -- consists of the evaluation of the boolean expression, followed by + -- the generation of exactly one block statement if the expression + -- evaluates to TRUE, and no block statement otherwise. + Clause := Generate; + while Clause /= Null_Iir loop + Cond := Get_Condition (Clause); + if Cond /= Null_Iir then + Lit := Execute_Expression (Instance, Cond); + end if; + if Cond = Null_Iir or else Lit.B1 = True then + -- LRM93 12.4.2 + -- If generated, the block statement has the following form: + -- 1. The block label is the same as the label of the generate + -- statement. + -- 2. The block declarative part consists of a copy of the + -- declarative items contained within the generate statement. + -- 3. The block statement part consists of a copy of the + -- concurrent statement contained within the generate + -- statement. + Bod := Get_Generate_Statement_Body (Clause); + Ninstance := Create_Block_Instance (Instance, Bod, Bod); + Elaborate_Declarative_Part + (Ninstance, Get_Declaration_Chain (Bod)); + Elaborate_Statement_Part + (Ninstance, Get_Concurrent_Statement_Chain (Bod)); + + exit; + end if; + Clause := Get_Generate_Else_Clause (Clause); + end loop; + end Elaborate_If_Generate_Statement; + + -- LRM93 12.4.2 Generate Statements + procedure Elaborate_For_Generate_Statement + (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement) + is + Iter : constant Iir := Get_Parameter_Specification (Generate); + Bod : constant Iir := Get_Generate_Statement_Body (Generate); + Ninstance : Block_Instance_Acc; + Sub_Instance : Block_Instance_Acc; + Bound, Index : Iir_Value_Literal_Acc; + begin + -- LRM93 12.4.2 + -- For a generate statement with a for generation scheme, elaboration + -- consists of the elaboration of the discrete range + + Ninstance := Create_Block_Instance (Instance, Bod, Bod); + Elaborate_Declaration (Ninstance, Iter); + Bound := Execute_Bounds (Ninstance, Get_Type (Iter)); + + -- Index is the iterator value. + Index := Unshare (Ninstance.Objects (Get_Info (Iter).Slot), + Current_Pool); + + -- Initialize the iterator. + Store (Index, Bound.Left); + + if not Is_In_Range (Index, Bound) then + -- Well, this instance should have never been built. + -- Should be destroyed ?? + return; + end if; + + loop + Sub_Instance := Create_Block_Instance (Ninstance, Bod, Iter); + + -- FIXME: this is needed to copy iterator type (if any). But this + -- elaborates the subtype several times (what about side effects). + Elaborate_Declaration (Sub_Instance, Iter); + + -- Store index. + Store (Sub_Instance.Objects (Get_Info (Iter).Slot), Index); + + Elaborate_Declarative_Part + (Sub_Instance, Get_Declaration_Chain (Bod)); + Elaborate_Statement_Part + (Sub_Instance, Get_Concurrent_Statement_Chain (Bod)); + + exit when Is_Equal (Index, Bound.Right); + Update_Loop_Index (Index, Bound); + end loop; + -- FIXME: destroy index ? + end Elaborate_For_Generate_Statement; + + procedure Elaborate_Process_Statement + (Instance : Block_Instance_Acc; Stmt : Iir) + is + Proc_Instance : Block_Instance_Acc; + begin + Proc_Instance := Create_Block_Instance (Instance, Stmt, Stmt); + + Processes_Table.Append (Proc_Instance); + + -- Processes aren't elaborated here. They are elaborated + -- just before simulation. + end Elaborate_Process_Statement; + + procedure Elaborate_Psl_Directive + (Instance : Block_Instance_Acc; Stmt : Iir) + is + begin + -- Create the state vector (and initialize it). + -- Create the bool flag (for cover) + -- Create the process + -- Create the finalizer + PSL_Table.Append (PSL_Entry'(Instance, Stmt, null, False)); + end Elaborate_Psl_Directive; + + -- LRM93 §12.4 Elaboration of a Statement Part. + procedure Elaborate_Statement_Part + (Instance : Block_Instance_Acc; Stmt_Chain: Iir) + is + Stmt : Iir; + begin + -- Concurrent statements appearing in the statement part of a block + -- must be elaborated before execution begins. + -- Elaboration of the statement part of a block consists of the + -- elaboration of each concurrent statement in the order given. + Stmt := Stmt_Chain; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Block_Statement => + Elaborate_Block_Statement (Instance, Stmt); + + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Elaborate_Process_Statement (Instance, Stmt); + + when Iir_Kind_Component_Instantiation_Statement => + Elaborate_Component_Instantiation (Instance, Stmt); + + when Iir_Kind_If_Generate_Statement => + Elaborate_If_Generate_Statement (Instance, Stmt); + + when Iir_Kind_For_Generate_Statement => + Elaborate_For_Generate_Statement (Instance, Stmt); + + when Iir_Kind_Simple_Simultaneous_Statement => + Add_Characteristic_Expression + (Explicit, + Build (Op_Plus, + Instance, Get_Simultaneous_Right (Stmt), + Build (Op_Minus, + Instance, Get_Simultaneous_Left (Stmt)))); + + when Iir_Kind_Psl_Default_Clock + | Iir_Kind_Psl_Declaration => + null; + + when Iir_Kind_Psl_Cover_Statement + | Iir_Kind_Psl_Assert_Statement => + Elaborate_Psl_Directive (Instance, Stmt); + + when Iir_Kind_Concurrent_Simple_Signal_Assignment => + -- In case concurrent signal assignemnts were not + -- canonicalized. + null; + + when others => + Error_Kind ("elaborate_statement_part", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + + -- Put children in order (were prepended, so in reverse order). + declare + Last, Child : Block_Instance_Acc; + Next_Child : Block_Instance_Acc; + begin + Child := Instance.Children; + Last := null; + while Child /= null loop + Next_Child := Child.Brother; + Child.Brother := Last; + Last := Child; + Child := Next_Child; + end loop; + Instance.Children := Last; + end; + end Elaborate_Statement_Part; + + -- Compute the default value for declaration DECL, using either + -- DEFAULT_VALUE if not null, or the implicit default value for DECL. + -- DECL must have a type. + function Elaborate_Default_Value (Instance : Block_Instance_Acc; Decl : Iir) + return Iir_Value_Literal_Acc + is + Default_Value : constant Iir := Get_Default_Value (Decl); + Val : Iir_Value_Literal_Acc; + begin + if Default_Value /= Null_Iir then + Val := Execute_Expression_With_Type + (Instance, Default_Value, Get_Type (Decl)); + else + Val := Create_Value_For_Type + (Instance, Get_Type (Decl), Init_Value_Default); + end if; + return Val; + end Elaborate_Default_Value; + + -- LRM93 §12.3.1.1 Subprogram Declaration and Bodies + procedure Elaborate_Interface_List + (Instance : Block_Instance_Acc; Inter_Chain : Iir) + is + Inter : Iir; + begin + -- elaboration of the parameter interface list + -- this in turn involves the elaboration of the subtype indication of + -- each interface element to determine the subtype of each formal + -- parameter of the subprogram. + Inter := Inter_Chain; + while Inter /= Null_Iir loop + case Get_Kind (Inter) is + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Inter)); + when others => + Error_Kind ("elaborate_interface_list", Inter); + end case; + Inter := Get_Chain (Inter); + end loop; + end Elaborate_Interface_List; + + -- LRM93 §12.3.1.1 Subprogram Declaration and Bodies + procedure Elaborate_Subprogram_Declaration + (Instance : Block_Instance_Acc; Decl : Iir) + is + begin + -- Elaboration of a subprogram declaration involves the elaboration + -- of the parameter interface list of the subprogram declaration; [...] + Elaborate_Interface_List + (Instance, Get_Interface_Declaration_Chain (Decl)); + + -- Elaboration of a subprogram body has no effect other than to + -- establish that the body can, from then on, be used for the + -- execution of calls of the subprogram. + -- FIXME + null; + end Elaborate_Subprogram_Declaration; + + procedure Elaborate_Component_Configuration + (Stmt : Iir_Component_Instantiation_Statement; + Comp_Instance : Block_Instance_Acc; + Conf : Iir_Component_Configuration) + is + Component : constant Iir_Component_Declaration := + Get_Named_Entity (Get_Instantiated_Unit (Stmt)); + Entity : Iir_Entity_Declaration; + Arch_Name : Name_Id; + Arch_Design : Iir_Design_Unit; + Arch : Iir_Architecture_Body; + Arch_Frame : Block_Instance_Acc; + pragma Unreferenced (Arch_Frame); + Generic_Map_Aspect_Chain : Iir; + Port_Map_Aspect_Chain : Iir; + Binding : Iir_Binding_Indication; + Aspect : Iir; + Sub_Conf : Iir; + begin + if Trace_Elaboration then + Ada.Text_IO.Put ("configure component "); + Ada.Text_IO.Put (Name_Table.Image (Get_Label (Stmt))); + Ada.Text_IO.Put (": "); + Ada.Text_IO.Put_Line (Image_Identifier (Component)); + end if; + + -- Elaboration of a component instantiation statement that instanciates + -- a component declaration has no effect unless the component instance + -- is either fully bound to a design entity defined by an entity + -- declaration and architecture body or is bound to a configuration of + -- such a design entity. + if not Is_Fully_Bound (Conf) then + Warning_Msg_Elab + (Warnid_Binding, Stmt, "%n not bound", +Stmt); + return; + end if; + + if Trace_Elaboration then + Ada.Text_IO.Put_Line + (" using " & Disp_Node (Conf) & " from " & Disp_Location (Conf)); + end if; + + -- If a component instance is so bound, then elaboration of the + -- corresponding component instantiation statement consists of the + -- elaboration of the implied block statement representing the + -- component instance and [...] + -- FIXME: extract frame. + + -- and (within that block) the implied block statement representing the + -- design entity to which the component instance is so bound. + Arch := Null_Iir; + Arch_Name := Null_Identifier; + Binding := Get_Binding_Indication (Conf); + Aspect := Get_Entity_Aspect (Binding); + + case Get_Kind (Conf) is + when Iir_Kind_Component_Configuration => + Sub_Conf := Get_Block_Configuration (Conf); + when Iir_Kind_Configuration_Specification => + Sub_Conf := Null_Iir; + when others => + raise Internal_Error; + end case; + + case Get_Kind (Aspect) is + when Iir_Kind_Design_Unit => + raise Internal_Error; + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Aspect); + if Get_Architecture (Aspect) /= Null_Iir then + Arch_Name := Get_Identifier + (Strip_Denoting_Name (Get_Architecture (Aspect))); + end if; + when Iir_Kind_Entity_Aspect_Configuration => + if Sub_Conf /= Null_Iir then + raise Internal_Error; + end if; + declare + Conf : constant Iir := Get_Configuration (Aspect); + begin + Entity := Get_Entity (Conf); + Sub_Conf := Get_Block_Configuration (Conf); + Arch := Get_Named_Entity (Get_Block_Specification (Sub_Conf)); + end; + when others => + Error_Kind ("elaborate_component_declaration0", Aspect); + end case; + + if Arch = Null_Iir then + if Arch_Name = Null_Identifier then + Arch := Libraries.Get_Latest_Architecture (Entity); + if Arch = Null_Iir then + Error_Msg_Elab + (Stmt, "no architecture analysed for %n", +Entity); + end if; + Arch_Name := Get_Identifier (Arch); + end if; + Arch_Design := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Entity), Arch_Name, Stmt); + if Arch_Design = Null_Iir then + Error_Msg_Elab + (Stmt, "no architecture %i for %n", (+Arch_Name, +Entity)); + end if; + Arch := Get_Library_Unit (Arch_Design); + end if; + + Generic_Map_Aspect_Chain := Get_Generic_Map_Aspect_Chain (Binding); + Port_Map_Aspect_Chain := Get_Port_Map_Aspect_Chain (Binding); + + if Generic_Map_Aspect_Chain = Null_Iir then + -- LRM93 5.2.2 + -- The default binding indication includes a default generic map + -- aspect if the design entity implied by the entity aspect contains + -- formal generic + -- GHDL: this condition is checked by create_default_association. + Generic_Map_Aspect_Chain := + Create_Default_Association (Get_Generic_Chain (Entity), + Get_Generic_Chain (Component), + Stmt); + end if; + + if Port_Map_Aspect_Chain = Null_Iir then + Port_Map_Aspect_Chain := + Create_Default_Association (Get_Port_Chain (Entity), + Get_Port_Chain (Component), + Stmt); + end if; + + if Sub_Conf = Null_Iir then + Sub_Conf := Get_Default_Configuration_Declaration (Arch); + Sub_Conf := Get_Block_Configuration (Get_Library_Unit (Sub_Conf)); + end if; + + -- FIXME: Use Sub_Conf instead of Arch for Stmt ? (But need to add + -- info for block configuration). + Arch_Frame := Elaborate_Architecture + (Arch, Sub_Conf, Comp_Instance, Arch, + Generic_Map_Aspect_Chain, Port_Map_Aspect_Chain); + end Elaborate_Component_Configuration; + + procedure Elaborate_Block_Configuration + (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc); + + procedure Apply_Block_Configuration_To_Iterative_Generate + (Stmt : Iir; Conf_Chain : Iir; Instance : Block_Instance_Acc) + is + Scheme : constant Iir := Get_Parameter_Specification (Stmt); + Bounds : constant Iir_Value_Literal_Acc := + Execute_Bounds (Instance, Get_Type (Scheme)); + + Sub_Instances : Block_Instance_Acc_Array + (0 .. Instance_Slot_Type (Bounds.Length - 1)); + + type Sub_Conf_Type is array (0 .. Instance_Slot_Type (Bounds.Length - 1)) + of Boolean; + Sub_Conf : Sub_Conf_Type := (others => False); + + Child : Block_Instance_Acc; + + Item : Iir; + Prev_Item : Iir; + Default_Item : Iir := Null_Iir; + Spec : Iir; + Expr : Iir_Value_Literal_Acc; + Ind : Instance_Slot_Type; + begin + -- Gather children. + Child := Instance.Children; + for I in Sub_Instances'Range loop + Sub_Instances (I) := Child; + Child := Child.Brother; + end loop; + -- All children must have been handled. + pragma Assert (Child = null); + + -- Apply configuration items + Item := Conf_Chain; + while Item /= Null_Iir loop + Spec := Strip_Denoting_Name (Get_Block_Specification (Item)); + Prev_Item := Get_Prev_Block_Configuration (Item); + + case Get_Kind (Spec) is + when Iir_Kind_Slice_Name => + Expr := Execute_Bounds (Instance, Get_Suffix (Spec)); + Ind := Instance_Slot_Type + (Get_Index_Offset (Execute_Low_Limit (Expr), Bounds, Spec)); + for I in 1 .. Instance_Slot_Type (Expr.Length) loop + Sub_Conf (Ind + I - 1) := True; + Elaborate_Block_Configuration + (Item, Sub_Instances (Ind + I - 1)); + end loop; + when Iir_Kind_Indexed_Name => + if Get_Index_List (Spec) = Iir_Flist_Others then + -- Must be the only default block configuration + pragma Assert (Default_Item = Null_Iir); + Default_Item := Item; + else + Expr := Execute_Expression + (Instance, Get_Nth_Element (Get_Index_List (Spec), 0)); + Ind := Instance_Slot_Type + (Get_Index_Offset (Expr, Bounds, Spec)); + Sub_Conf (Ind) := True; + Elaborate_Block_Configuration (Item, Sub_Instances (Ind)); + end if; + when Iir_Kind_Generate_Statement_Body => + -- Must be the only block configuration + pragma Assert (Item = Conf_Chain); + pragma Assert (Prev_Item = Null_Iir); + for I in Sub_Instances'Range loop + Sub_Conf (I) := True; + Elaborate_Block_Configuration (Item, Sub_Instances (I)); + end loop; + when others => + raise Internal_Error; + end case; + Item := Prev_Item; + end loop; + + -- Default configuration. + if Default_Item /= Null_Iir then + for I in Sub_Instances'Range loop + if not Sub_Conf (I) then + Elaborate_Block_Configuration + (Default_Item, Sub_Instances (I)); + end if; + end loop; + end if; + end Apply_Block_Configuration_To_Iterative_Generate; + + procedure Elaborate_Block_Configuration + (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc) + is + Blk_Info : constant Sim_Info_Acc := Get_Info (Instance.Stmt); + Sub_Instances : Block_Instance_Acc_Array + (0 .. Blk_Info.Nbr_Instances - 1); + type Iir_Array is array (Instance_Slot_Type range <>) of Iir; + Sub_Conf : Iir_Array (0 .. Blk_Info.Nbr_Instances - 1) := + (others => Null_Iir); + + Item : Iir; + begin + -- Gather children and reverse the list. + declare + Child, Prev, First : Block_Instance_Acc; + Info : Sim_Info_Acc; + begin + Child := Instance.Children; + First := null; + while Child /= null loop + Info := Get_Info (Child.Label); + if Info.Kind = Kind_Block then + pragma Assert (Info.Inst_Slot /= Invalid_Instance_Slot); + pragma Assert (Sub_Instances (Info.Inst_Slot) = null); + Sub_Instances (Info.Inst_Slot) := Child; + end if; + + -- Reverse + Prev := Child.Brother; + Child.Brother := First; + First := Child; + + Child := Prev; + end loop; + Instance.Children := First; + end; + + -- Associate configuration items with subinstance. Gather items for + -- for-generate statements. + Item := Get_Configuration_Item_Chain (Conf); + while Item /= Null_Iir loop + case Get_Kind (Item) is + when Iir_Kind_Block_Configuration => + declare + Spec : Iir; + Gen : Iir_Generate_Statement; + Info : Sim_Info_Acc; + begin + Spec := Strip_Denoting_Name (Get_Block_Specification (Item)); + case Get_Kind (Spec) is + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Name => + -- Block configuration for a generate statement. + Gen := Get_Named_Entity (Get_Prefix (Spec)); + Info := Get_Info (Gen); + Set_Prev_Block_Configuration + (Item, Sub_Conf (Info.Inst_Slot)); + Sub_Conf (Info.Inst_Slot) := Item; + when Iir_Kind_Parenthesis_Name => + Gen := Get_Named_Entity (Spec); + Info := Get_Info (Gen); + if Sub_Instances (Info.Inst_Slot) /= null + and then Sub_Instances (Info.Inst_Slot).Label = Gen + then + pragma Assert + (Sub_Conf (Info.Inst_Slot) = Null_Iir); + Sub_Conf (Info.Inst_Slot) := Item; + end if; + when Iir_Kind_Generate_Statement_Body => + Info := Get_Info (Spec); + pragma Assert (Sub_Conf (Info.Inst_Slot) = Null_Iir); + Sub_Conf (Info.Inst_Slot) := Item; + when Iir_Kind_Block_Statement => + -- Block configuration for a block statement. + Info := Get_Info (Spec); + pragma Assert (Sub_Conf (Info.Inst_Slot) = Null_Iir); + Sub_Conf (Info.Inst_Slot) := Item; + when others => + Error_Kind ("elaborate_block_configuration1", Spec); + end case; + end; + + when Iir_Kind_Component_Configuration => + declare + List : constant Iir_Flist := + Get_Instantiation_List (Item); + El : Iir; + Info : Sim_Info_Acc; + begin + if List = Iir_Flist_All or else List = Iir_Flist_Others then + raise Internal_Error; + end if; + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Info := Get_Info (Get_Named_Entity (El)); + pragma Assert (Sub_Conf (Info.Inst_Slot) = Null_Iir); + Sub_Conf (Info.Inst_Slot) := Item; + end loop; + end; + + when others => + Error_Kind ("elaborate_block_configuration", Item); + end case; + Item := Get_Chain (Item); + end loop; + + -- Configure sub instances. + for I in Sub_Instances'Range loop + declare + Sub_Inst : constant Block_Instance_Acc := Sub_Instances (I); + Stmt : Iir; + begin + if Sub_Inst /= null then + Stmt := Sub_Inst.Label; + case Get_Kind (Stmt) is + when Iir_Kind_Generate_Statement_Body => + Stmt := Get_Parent (Stmt); + case Get_Kind (Stmt) is + when Iir_Kind_For_Generate_Statement => + Apply_Block_Configuration_To_Iterative_Generate + (Stmt, Sub_Conf (I), Sub_Inst); + when Iir_Kind_If_Generate_Statement + | Iir_Kind_If_Generate_Else_Clause => + Elaborate_Block_Configuration + (Sub_Conf (I), Sub_Inst); + when others => + raise Internal_Error; + end case; + when Iir_Kind_Block_Statement => + Elaborate_Block_Configuration (Sub_Conf (I), Sub_Inst); + when Iir_Kind_Component_Instantiation_Statement => + if Is_Component_Instantiation (Stmt) then + Elaborate_Component_Configuration + (Stmt, Sub_Inst, Sub_Conf (I)); + else + -- Nothing to do for entity instantiation, will be + -- done during elaboration of statements. + null; + end if; + when others => + Error_Kind ("elaborate_block_configuration", Stmt); + end case; + end if; + end; + end loop; + end Elaborate_Block_Configuration; + + procedure Elaborate_Alias_Declaration + (Instance : Block_Instance_Acc; Decl : Iir_Object_Alias_Declaration) + is + Alias_Type : Iir; + Res : Iir_Value_Literal_Acc; + begin + -- LRM93 12.3.1.5 + -- Elaboration of an alias declaration consists of the elaboration + -- of the subtype indication to establish the subtype associated + -- with the alias, folloed by the creation of the alias as an + -- alternative name for the named entity. + -- The creation of an alias for an array object involves a check + -- that the subtype associated with the alias includes a matching + -- element for each element of the named object. + -- It is an error if this check fails. + Alias_Type := Get_Type (Decl); + Elaborate_Subtype_Indication_If_Anonymous (Instance, Alias_Type); + Create_Object (Instance, Decl); + Res := Execute_Name (Instance, Get_Name (Decl), True); + Implicit_Array_Conversion (Instance, Res, Alias_Type, Get_Name (Decl)); + Instance.Objects (Get_Info (Decl).Slot) := + Unshare_Bounds (Res, Instance_Pool); + end Elaborate_Alias_Declaration; + + -- LRM93 §12.3.2.3 Disconnection Specifications + procedure Elaborate_Disconnection_Specification + (Instance : Block_Instance_Acc; + Decl : Iir_Disconnection_Specification) + is + Time_Val : Iir_Value_Literal_Acc; + Time : Iir_Value_Time; + List : Iir_Flist; + Sig : Iir; + Val : Iir_Value_Literal_Acc; + begin + -- LRM93 §12.3.2.3 + -- Elaboration of a disconnection specification proceeds as follows: + -- 2. The time expression is evaluated to determine the disconnection + -- time for drivers of the affected signals. + Time_Val := Execute_Expression (Instance, Get_Expression (Decl)); + Time := Time_Val.I64; + + -- LRM93 5.3 + -- The time expression in a disconnection specification must be static + -- and must evaluate to a non-negative value. + + if Time < 0 then + Error_Msg_Sem (+Decl, "time must be non-negative"); + end if; + + -- LRM93 §12.3.2.3 + -- 1. The guarded signal specification is elaborated in order to + -- identify the signals affected by the disconnection specification. + -- + -- 3. The diconnection time is associated with each affected signal for + -- later use in constructing disconnection statements in the + -- equivalent processes for guarded assignments to the affected + -- signals. + List := Get_Signal_List (Decl); + case List is + when Iir_Flist_All + | Iir_Flist_Others => + Error_Kind ("elaborate_disconnection_specification", Decl); + when others => + for I in Flist_First .. Flist_Last (List) loop + Sig := Get_Nth_Element (List, I); + Val := Execute_Name (Instance, Sig, True); + Disconnection_Table.Append ((Sig => Val, Time => Time)); + end loop; + end case; + end Elaborate_Disconnection_Specification; + + procedure Elaborate_Branch_Quantity_Declaration + (Instance : Block_Instance_Acc; Decl : Iir) + is + Terminal_Plus, Terminal_Minus : Iir; + Plus, Minus : Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Quantity (Instance, Decl); + + Terminal_Plus := Get_Plus_Terminal (Decl); + Plus := Execute_Name (Instance, Terminal_Plus, True); + Terminal_Minus := Get_Minus_Terminal (Decl); + if Terminal_Minus = Null_Iir then + -- Get the reference of the nature + -- FIXME: select/index + Terminal_Minus := Get_Reference (Get_Nature (Terminal_Plus)); + end if; + Minus := Execute_Name (Instance, Terminal_Minus, True); + + case Iir_Kinds_Branch_Quantity_Declaration (Get_Kind (Decl)) is + when Iir_Kind_Across_Quantity_Declaration => + -- Expr: q - P'ref + M'ref + Add_Characteristic_Expression + (Structural, + Build + (Op_Plus, Res.Quantity, + Build (Op_Minus, + Get_Terminal_Reference (Plus.Terminal), + Build (Op_Plus, + Get_Terminal_Reference (Minus.Terminal))))); + when Iir_Kind_Through_Quantity_Declaration => + -- P'Contrib <- P'Contrib + q + -- M'Contrib <- M'Contrib - q + Append_Characteristic_Expression + (Plus.Terminal, Build (Op_Plus, Res.Quantity)); + Append_Characteristic_Expression + (Minus.Terminal, Build (Op_Minus, Res.Quantity)); + end case; + end Elaborate_Branch_Quantity_Declaration; + + -- LRM93 §12.3.1 Elaboration of a declaration + procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir) + is + Expr_Mark : Mark_Type; + Val : Iir_Value_Literal_Acc; + begin + Mark (Expr_Mark, Expr_Pool); + + -- Elaboration of a declaration has the effect of creating the declared + -- item. For each declaration, the language rules (in particular scope + -- and visibility rules) are such that it is either impossible or + -- illegal to use a given item before the elaboration of its + -- corresponding declaration. + -- Similarly, it is illegal to call a subprogram before its + -- corresponding body is elaborated. + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Implicit_Definition (Decl) in Iir_Predefined_Explicit + and then not Is_Second_Subprogram_Specification (Decl) + then + Elaborate_Subprogram_Declaration (Instance, Decl); + end if; + when Iir_Kind_Anonymous_Type_Declaration => + Elaborate_Type_Definition (Instance, Get_Type_Definition (Decl)); + when Iir_Kind_Type_Declaration => + Elaborate_Type_Declaration (Instance, Decl); + when Iir_Kind_Subtype_Declaration => + Elaborate_Subtype_Indication (Instance, Get_Type (Decl)); + when Iir_Kind_Iterator_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Create_Value_For_Type + (Instance, Get_Type (Decl), Init_Value_Default); + Create_Object (Instance, Decl); + Instance.Objects (Get_Info (Decl).Slot) := + Unshare (Val, Instance_Pool); + when Iir_Kind_Signal_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Elaborate_Default_Value (Instance, Decl); + Create_Signal (Instance, Decl); + Elaborate_Signal (Instance, Decl, Val); + when Iir_Kind_Variable_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Elaborate_Default_Value (Instance, Decl); + Create_Object (Instance, Decl); + Instance.Objects (Get_Info (Decl).Slot) := + Unshare (Val, Instance_Pool); + when Iir_Kind_Constant_Declaration => + declare + Deferred_Decl : constant Iir := Get_Deferred_Declaration (Decl); + First_Decl : Iir; + begin + if Deferred_Decl = Null_Iir + or else Get_Deferred_Declaration_Flag (Decl) + then + -- Create the object (except for full declaration of a + -- deferred constant). + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Create_Object (Instance, Decl); + end if; + -- Initialize the value (except for a deferred declaration). + if Deferred_Decl = Null_Iir then + First_Decl := Decl; + elsif not Get_Deferred_Declaration_Flag (Decl) then + First_Decl := Deferred_Decl; + else + First_Decl := Null_Iir; + end if; + if First_Decl /= Null_Iir then + Val := Execute_Expression_With_Type + (Instance, Get_Default_Value (Decl), + Get_Type (First_Decl)); + Instance.Objects (Get_Info (First_Decl).Slot) := + Unshare (Val, Instance_Pool); + end if; + end; + when Iir_Kind_File_Declaration => + -- LRM93 12.3.1.4 + -- Elaboration of a file object declaration consists of the + -- elaboration of the subtype indication... + null; -- FIXME ?? + -- ...followed by the creation of object. + Create_Object (Instance, Decl); + -- If the file object declaration contains file_open_information, + -- then the implicit call to FILE_OPEN is then executed. + Instance.Objects (Get_Info (Decl).Slot) := Unshare + (File_Operation.Elaborate_File_Declaration (Instance, Decl), + Instance_Pool); + when Iir_Kind_Object_Alias_Declaration => + Elaborate_Alias_Declaration (Instance, Decl); + when Iir_Kind_Component_Declaration => + -- LRM93 12.3.1.7 + -- Elaboration of a component declaration has no effect other + -- than to create a template for instantiating component + -- instances. + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Configuration_Specification => + -- Elaboration of a configuration specification proceeds as + -- follows: + -- 1. The component specification is elaborated in order to + -- determine which component instances are affected by the + -- configuration specification. + -- GHDL: this is done during sem. + + -- 2. The binding indication is elaborated to identify the design + -- entity to which the affected component instances will be + -- bound. + -- GHDL: this is already done during sem, according to rules + -- defined by section 5.3.1.1 + + -- 3. The binding information is associated with each affected + -- component instance label for later use in instantiating + -- those component instances. + -- GHDL: this is done during step 1. + + -- As part of this elaboration process, a check is made that both + -- the entity declaration and the corresponding architecture body + -- implied by the binding indication exist whithin the specified + -- library. + -- It is an error if this check fails. + -- GHDL: this is already done during sem, according to rules + -- defined by section 5.3.1.1 + null; + + when Iir_Kind_Attribute_Declaration => + -- LRM93 12.3.1.6 + -- Elaboration of an attribute declaration has no effect other + -- than to create a template for defining attributes of items. + null; + + when Iir_Kind_Attribute_Specification => + -- LRM93 12.3.2.1 + -- Elaboration of an attribute specification proceeds as follows: + -- 1. The entity specification is elaborated in order to + -- determine which items are affected by the attribute + -- specification. + -- GHDL: done by sem. + + declare + Attr_Decl : constant Iir := + Get_Named_Entity (Get_Attribute_Designator (Decl)); + Attr_Type : constant Iir := Get_Type (Attr_Decl); + Value : Iir_Attribute_Value; + Val : Iir_Value_Literal_Acc; + begin + Value := Get_Attribute_Value_Spec_Chain (Decl); + while Value /= Null_Iir loop + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Value)); + -- 2. The expression is evaluated to determine the value + -- of the attribute. + -- It is an error if the value of the expression does not + -- belong to the subtype of the attribute; if the + -- attribute is of an array type, then an implicit + -- subtype conversion is first performed on the value, + -- unless the attribute's subtype indication denotes an + -- unconstrained array type. + Val := Execute_Expression (Instance, Get_Expression (Decl)); + Check_Constraints (Instance, Val, Attr_Type, Decl); + + -- 3. A new instance of the designated attribute is created + -- and associated with each of the affected items. + -- + -- 4. Each new attribute instance is assigned the value of + -- the expression. + Create_Object (Instance, Value); + Instance.Objects (Get_Info (Value).Slot) := + Unshare (Val, Instance_Pool); + + Value := Get_Spec_Chain (Value); + end loop; + end; + + when Iir_Kind_Disconnection_Specification => + Elaborate_Disconnection_Specification (Instance, Decl); + + when Iir_Kind_Use_Clause => + null; + + when Iir_Kind_Signal_Attribute_Declaration => + declare + Attr : Iir; + begin + Attr := Get_Signal_Attribute_Chain (Decl); + while Is_Valid (Attr) loop + case Iir_Kinds_Signal_Attribute (Get_Kind (Attr)) is + when Iir_Kind_Delayed_Attribute => + Elaborate_Delayed_Signal (Instance, Attr); + when Iir_Kind_Stable_Attribute => + Elaborate_Implicit_Signal + (Instance, Attr, Mode_Stable); + when Iir_Kind_Quiet_Attribute => + Elaborate_Implicit_Signal + (Instance, Attr, Mode_Quiet); + when Iir_Kind_Transaction_Attribute => + Elaborate_Implicit_Signal + (Instance, Attr, Mode_Transaction); + end case; + Attr := Get_Attr_Chain (Attr); + end loop; + end; + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when Iir_Kind_Protected_Type_Body => + null; + + when Iir_Kind_Nature_Declaration => + Elaborate_Nature_Definition (Instance, Get_Nature (Decl)); + Create_Terminal (Instance, Get_Chain (Decl)); + + when Iir_Kind_Terminal_Declaration => + Create_Terminal (Instance, Decl); + + when Iir_Kinds_Branch_Quantity_Declaration => + Elaborate_Branch_Quantity_Declaration (Instance, Decl); + + when others => + Error_Kind ("elaborate_declaration", Decl); + end case; + + Release (Expr_Mark, Expr_Pool); + end Elaborate_Declaration; + + procedure Destroy_Iterator_Declaration + (Instance : Block_Instance_Acc; Decl : Iir) + is + Obj_Type : constant Iir := Get_Type (Decl); + Constraint : Iir; + Cons_Info : Sim_Info_Acc; + begin + if Get_Kind (Decl) /= Iir_Kind_Iterator_Declaration then + raise Internal_Error; + end if; + Destroy_Object (Instance, Decl); + + if Get_Kind (Obj_Type) = Iir_Kind_Range_Array_Attribute + or else not Is_Anonymous_Type_Definition (Obj_Type) + then + return; + end if; + + Constraint := Get_Range_Constraint (Obj_Type); + if Get_Kind (Constraint) /= Iir_Kind_Range_Expression then + return; + end if; + Cons_Info := Get_Info (Constraint); + if Cons_Info.Obj_Scope = Instance.Block_Scope + and then Cons_Info.Slot = Instance.Elab_Objects + then + Destroy_Object (Instance, Constraint); + end if; + end Destroy_Iterator_Declaration; + + procedure Finalize_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir) + is + Decl : Iir; + Val : Iir_Value_Literal_Acc; + begin + Decl := Decl_Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_File_Declaration => + -- LRM93 3.4.1 + -- An implicit call to FILE_CLOSE exists in a subprogram body + -- for every file object declared in the corresponding + -- subprogram declarative part. + -- Each such call associates a unique file object with the + -- formal parameter F and is called whenever the corresponding + -- subprogram completes its execution. + Val := Instance.Objects (Get_Info (Decl).Slot); + if Get_Text_File_Flag (Get_Type (Decl)) then + File_Operation.File_Close_Text (Val, Null_Iir); + File_Operation.File_Destroy_Text (Val); + else + File_Operation.File_Close_Binary (Val, Null_Iir); + File_Operation.File_Destroy_Binary (Val); + end if; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end Finalize_Declarative_Part; + + -- LRM93 §12.3 Elaboration of a Declarative Part + procedure Elaborate_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir) + is + Decl : Iir; + begin + -- The elaboration of a declarative part consists of the elaboration + -- of the declarative items, if any, in the order in which they are + -- given in the declarative part. + -- [Exception for 'foreign ] + Decl := Decl_Chain; + while Decl /= Null_Iir loop + -- In certain cases, the elaboration of a declarative item involves + -- the evaluation of expressions that appear within the declarative + -- item. + -- The value of any object denoted by a primary in such an expression + -- must be defined at the time the primary is read. + -- In addition, if a primary in such an expression is a function call + -- then the value of any object denoted or appearing as part of an + -- actual designator in the function call must be defined at the + -- time the expression is evaluated. + -- FIXME: check this. + Elaborate_Declaration (Instance, Decl); + Decl := Get_Chain (Decl); + end loop; + end Elaborate_Declarative_Part; + + function Elaborate_Architecture (Arch : Iir_Architecture_Body; + Conf : Iir_Block_Configuration; + Parent_Instance : Block_Instance_Acc; + Stmt : Iir; + Generic_Map : Iir; + Port_Map : Iir) + return Block_Instance_Acc + is + Entity : constant Iir_Entity_Declaration := Get_Entity (Arch); + Instance : Block_Instance_Acc; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + + if Trace_Elaboration then + Ada.Text_IO.Put ("elaborating "); + Ada.Text_IO.Put (Image_Identifier (Arch)); + Ada.Text_IO.Put (" of "); + Ada.Text_IO.Put_Line (Image_Identifier (Entity)); + end if; + + Instance := Create_Block_Instance (Parent_Instance, Arch, Stmt); + Instance.Up_Block := null; -- Packages_Instance; + + -- LRM93 §12.1 + -- Elaboration of a block statement involves first elaborating each not + -- yet elaborated package containing declarations referenced by the + -- block. + Elaborate_Dependence (Get_Design_Unit (Arch)); + + Current_Component := Parent_Instance; + Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Entity)); + Elaborate_Generic_Map_Aspect (Instance, Parent_Instance, + Get_Generic_Chain (Entity), Generic_Map); + Elaborate_Port_Clause (Instance, Get_Port_Chain (Entity)); + Elaborate_Port_Map_Aspect (Instance, Parent_Instance, + Get_Port_Chain (Entity), Port_Map); + Current_Component := null; + + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Entity)); + Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Arch)); + Elaborate_Statement_Part + (Instance, Get_Concurrent_Statement_Chain (Entity)); + Elaborate_Statement_Part + (Instance, Get_Concurrent_Statement_Chain (Arch)); + + -- Configure the unit. This will create sub units. + Elaborate_Block_Configuration (Conf, Instance); + + Release (Expr_Mark, Expr_Pool); + + return Instance; + end Elaborate_Architecture; + + function Override_Generic (Formal : Iir; Str : String) return Iir + is + use Evaluation; + Formal_Type : constant Iir := Get_Type (Formal); + Formal_Btype : constant Iir := Get_Base_Type (Formal_Type); + Res : Iir; + begin + case Get_Kind (Formal_Btype) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition => + Res := Eval_Value_Attribute (Str, Formal_Type, Formal); + if not Eval_Is_In_Bound (Res, Formal_Type) then + Error_Msg_Elab + ("override for %n is out of bounds", +Formal); + return Null_Iir; + end if; + return Res; + when Iir_Kind_Array_Type_Definition => + if Is_One_Dimensional_Array_Type (Formal_Btype) then + declare + use Str_Table; + Str8 : String8_Id; + Ntype : Iir; + begin + Str8 := Create_String8; + Append_String8_String (Str); + Res := Create_Iir (Iir_Kind_String_Literal8); + Set_String8_Id (Res, Str8); + -- FIXME: check characters are in the type. + Set_String_Length (Res, Str'Length); + Set_Expr_Staticness (Res, Locally); + Ntype := Create_Unidim_Array_By_Length + (Get_Base_Type (Formal_Type), Str'Length, Res); + Set_Type (Res, Ntype); + Set_Literal_Subtype (Res, Ntype); + return Res; + end; + end if; + when others => + null; + end case; + Error_Msg_Elab ("unhandled override for %n", +Formal); + return Null_Iir; + end Override_Generic; + + procedure Override_Generics + (Map : in out Iir; First : Grt.Options.Generic_Override_Acc) + is + use Grt.Options; + Over : Generic_Override_Acc; + Id : Name_Id; + Gen : Iir; + Prev : Iir; + Val : Iir; + Assoc : Iir; + begin + Over := First; + Prev := Null_Iir; + while Over /= null loop + Id := Name_Table.Get_Identifier (Over.Name.all); + + -- Find existing association in map. There should be one association + -- for each generic. + Gen := Map; + while Gen /= Null_Iir loop + exit when Get_Identifier (Get_Formal (Map)) = Id; + Prev := Gen; + Gen := Get_Chain (Gen); + end loop; + + if Gen = Null_Iir then + Error_Msg_Elab + ("no generic '" & Name_Table.Image (Id) & "' for -g"); + else + -- Replace the association with one for the override value. + Val := Override_Generic (Get_Formal (Map), Over.Value.all); + if Val /= Null_Iir then + Assoc := + Create_Iir (Iir_Kind_Association_Element_By_Expression); + Set_Actual (Assoc, Val); + Set_Whole_Association_Flag (Assoc, True); + Set_Formal (Assoc, Get_Formal (Map)); + + Set_Chain (Assoc, Get_Chain (Gen)); + if Prev = Null_Iir then + Map := Assoc; + else + Set_Chain (Prev, Assoc); + end if; + end if; + end if; + Over := Over.Next; + end loop; + end Override_Generics; + + procedure Check_No_Unconstrained (Ports : Iir; Map : Iir) + is + Assoc : Iir; + Port : Iir; + Formal : Iir; + begin + Assoc := Map; + Port := Ports; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then + Formal := Get_Association_Interface (Assoc, Port); + if Get_Default_Value (Formal) = Null_Iir + and then not Is_Fully_Constrained_Type (Get_Type (Formal)) + then + Error_Msg_Elab + (Formal, "top-level %n must have a value", +Formal); + end if; + end if; + Next_Association_Interface (Assoc, Port); + end loop; + end Check_No_Unconstrained; + + -- Elaborate a design. + procedure Elaborate_Design (Design: Iir_Design_Unit) + is + Unit : constant Iir := Get_Library_Unit (Design); + Conf_Unit : Iir_Design_Unit; + Conf : Iir_Block_Configuration; + Arch_Unit : Iir_Design_Unit; + Arch : Iir_Architecture_Body; + Entity : Iir_Entity_Declaration; + Generic_Map : Iir; + Port_Map : Iir; + begin + Package_Instances := new Package_Instances_Array (1 .. Nbr_Packages); + + -- Use a 'fake' process to execute code during elaboration. + Current_Process := No_Process; + + Instance_Pool := Global_Pool'Access; + + pragma Assert (Is_Empty (Expr_Pool)); + + -- Find architecture and configuration for the top unit + case Get_Kind (Unit) is + when Iir_Kind_Architecture_Body => + Arch := Unit; + Conf_Unit := Get_Default_Configuration_Declaration (Unit); + when Iir_Kind_Configuration_Declaration => + Conf_Unit := Design; + Arch := Get_Named_Entity + (Get_Block_Specification (Get_Block_Configuration (Unit))); + Elaborate_Dependence (Design); + Elaborate_Configuration_Declaration (Unit); + when others => + Error_Kind ("elaborate_design", Unit); + end case; + + Arch_Unit := Get_Design_Unit (Arch); + Entity := Get_Entity (Arch); + + pragma Assert (Is_Empty (Expr_Pool)); + + Elaborate_Dependence (Arch_Unit); + + -- Sanity check: memory area for expressions must be empty. + pragma Assert (Is_Empty (Expr_Pool)); + + -- Use default values for top entity generics and ports. + Generic_Map := Create_Default_Association + (Get_Generic_Chain (Entity), Null_Iir, Entity); + Port_Map := Create_Default_Association + (Get_Port_Chain (Entity), Null_Iir, Entity); + Override_Generics (Generic_Map, Grt.Options.First_Generic_Override); + + Check_No_Unconstrained (Get_Generic_Chain (Entity), Generic_Map); + Check_No_Unconstrained (Get_Port_Chain (Entity), Port_Map); + + -- Stop now in case of errors. + if Nbr_Errors /= 0 then + Grt.Errors.Fatal_Error; + end if; + + -- Elaborate from the top configuration. + Conf := Get_Block_Configuration (Get_Library_Unit (Conf_Unit)); + Top_Instance := Elaborate_Architecture + (Arch, Conf, null, Arch, Generic_Map, Port_Map); + + Current_Process := null; + + Instance_Pool := null; + + -- Stop now in case of errors. + if Nbr_Errors /= 0 then + Grt.Errors.Fatal_Error; + end if; + + -- Sanity check: memory area for expressions must be empty. + pragma Assert (Is_Empty (Expr_Pool)); + end Elaborate_Design; + +end Simul.Elaboration; diff --git a/src/vhdl/simulate/simul-elaboration.ads b/src/vhdl/simulate/simul-elaboration.ads new file mode 100644 index 000000000..07969719f --- /dev/null +++ b/src/vhdl/simulate/simul-elaboration.ads @@ -0,0 +1,187 @@ +-- Elaboration for interpretation +-- 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 Tables; +with Types; use Types; +with Iirs; use Iirs; +with Simul.Environments; use Simul.Environments; +with Grt.Types; use Grt.Types; +with Simul.Annotations; use Simul.Annotations; + +-- This package elaborates design hierarchy. + +package Simul.Elaboration is + Trace_Elaboration : Boolean := False; + Trace_Drivers : Boolean := False; + + -- Number of block instances and also Id of the last one. + Nbr_Block_Instances : Block_Instance_Id := 0; + + -- A block instance with its architecture/entity declaration is an + -- instancied entity. + + procedure Elaborate_Design (Design: Iir_Design_Unit); + + procedure Elaborate_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir); + + -- Reverse operation of Elaborate_Declarative_Part. + -- At least, finalize files. + procedure Finalize_Declarative_Part + (Instance : Block_Instance_Acc; Decl_Chain : Iir); + + procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir); + + procedure Destroy_Iterator_Declaration + (Instance : Block_Instance_Acc; Decl : Iir); + + -- How are created scalar values for Create_Value_For_Type. + type Init_Value_Kind is + (-- Use the default value for the type (lefmost value). + Init_Value_Default, + + -- Undefined. The caller doesn't care as it will overwrite the value. + Init_Value_Any, + + -- Create signal placeholder. Only for individual associations. + Init_Value_Signal); + + -- Create a value for type DECL. + function Create_Value_For_Type + (Block: Block_Instance_Acc; Decl: Iir; Init : Init_Value_Kind) + return Iir_Value_Literal_Acc; + + -- LRM93 §12.3.1.3 Subtype Declarations + -- The elaboration of a subtype indication creates a subtype. + -- Used for allocator. + procedure Elaborate_Subtype_Indication + (Instance : Block_Instance_Acc; Ind : Iir); + + -- Create object DECL. + -- This does nothing except marking DECL as elaborated. + -- Used by simulation to dynamically create subprograms interfaces. + procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir); + procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir); + + Top_Instance: Block_Instance_Acc; + + type Block_Instance_Acc_Array is array (Instance_Slot_Type range <>) of + Block_Instance_Acc; + + type Package_Instances_Array is array (Pkg_Index_Type range <>) of + Block_Instance_Acc; + type Package_Instances_Array_Acc is access Package_Instances_Array; + + Package_Instances : Package_Instances_Array_Acc; + + -- Disconnections. For each disconnection specification, the elaborator + -- adds an entry in the table. + type Disconnection_Entry is record + Sig : Iir_Value_Literal_Acc; + Time : Iir_Value_Time; + end record; + + package Disconnection_Table is new Tables + (Table_Component_Type => Disconnection_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 16); + + -- Connections. For each associations (block/component/entry), the + -- elaborator adds an entry in that table. + type Connect_Entry is record + Formal : Iir_Value_Literal_Acc; + Formal_Instance : Block_Instance_Acc; + Actual : Iir_Value_Literal_Acc; + Actual_Instance : Block_Instance_Acc; + Inter : Iir; + Assoc : Iir; + end record; + + package Connect_Table is new Tables + (Table_Component_Type => Connect_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 32); + + -- Signals. + + type Signal_Entry (Kind : Mode_Signal_Type := Mode_Signal) is record + Decl : Iir; + Sig : Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc; + Instance : Block_Instance_Acc; + case Kind is + when Mode_Signal_User => + null; + when Mode_Quiet | Mode_Stable | Mode_Delayed + | Mode_Transaction => + Time : Std_Time; + Prefix : Iir_Value_Literal_Acc; + when Mode_Guard => + null; + when Mode_Conv_In | Mode_Conv_Out | Mode_End => + -- Unused. + null; + end case; + end record; + + package Signals_Table is new Tables + (Table_Component_Type => Signal_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 128); + + type Process_Index_Type is new Natural; + + package Processes_Table is new Tables + (Table_Component_Type => Block_Instance_Acc, + Table_Index_Type => Process_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 128); + + package Protected_Table is new Tables + (Table_Component_Type => Block_Instance_Acc, + Table_Index_Type => Protected_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 2); + + package Environment_Table is new Tables + (Table_Component_Type => Block_Instance_Acc, + Table_Index_Type => Environment_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 2); + + type Boolean_Vector is array (Nat32 range <>) of Boolean; + type Boolean_Vector_Acc is access Boolean_Vector; + + type PSL_Entry is record + Instance : Block_Instance_Acc; + Stmt : Iir; + States : Boolean_Vector_Acc; + Done : Boolean; + end record; + + type PSL_Index_Type is new Natural; + + package PSL_Table is new Tables + (Table_Component_Type => PSL_Entry, + Table_Index_Type => PSL_Index_Type, + Table_Low_Bound => 1, + Table_Initial => 2); +end Simul.Elaboration; diff --git a/src/vhdl/simulate/simul-environments.adb b/src/vhdl/simulate/simul-environments.adb new file mode 100644 index 000000000..16f9bc3f0 --- /dev/null +++ b/src/vhdl/simulate/simul-environments.adb @@ -0,0 +1,1127 @@ +-- Naive values for 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 System; +with Ada.Unchecked_Conversion; +with GNAT.Debug_Utilities; +with Name_Table; +with Simul.Debugger; use Simul.Debugger; + +package body Simul.Environments is + + -- Functions for iir_value_literal + function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean is + begin + if Left.Kind /= Right.Kind then + raise Internal_Error; + end if; + case Left.Kind is + when Iir_Value_B1 => + return Left.B1 = Right.B1; + when Iir_Value_E8 => + return Left.E8 = Right.E8; + when Iir_Value_E32 => + return Left.E32 = Right.E32; + when Iir_Value_I64 => + return Left.I64 = Right.I64; + when Iir_Value_F64 => + return Left.F64 = Right.F64; + when Iir_Value_Access => + return Left.Val_Access = Right.Val_Access; + when Iir_Value_File => + raise Internal_Error; + when Iir_Value_Array => + if Left.Bounds.Nbr_Dims /= Right.Bounds.Nbr_Dims then + raise Internal_Error; + end if; + for I in Left.Bounds.D'Range loop + if Left.Bounds.D (I).Length /= Right.Bounds.D (I).Length then + return False; + end if; + end loop; + for I in Left.Val_Array.V'Range loop + if not Is_Equal (Left.Val_Array.V (I), + Right.Val_Array.V (I)) then + return False; + end if; + end loop; + return True; + when Iir_Value_Record => + if Left.Val_Record.Len /= Right.Val_Record.Len then + raise Constraint_Error; + end if; + for I in Left.Val_Record.V'Range loop + if not Is_Equal (Left.Val_Record.V (I), + Right.Val_Record.V (I)) then + return False; + end if; + end loop; + return True; + when Iir_Value_Range => + if Left.Dir /= Right.Dir then + return False; + end if; + if not Is_Equal (Left.Left, Right.Left) then + return False; + end if; + if not Is_Equal (Left.Right, Right.Right) then + return False; + end if; + return True; + when Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Is_Equal; + + function Compare_Value (Left, Right : Iir_Value_Literal_Acc) + return Order is + begin + if Left.Kind /= Right.Kind then + raise Constraint_Error; + end if; + case Left.Kind is + when Iir_Value_B1 => + if Left.B1 < Right.B1 then + return Less; + elsif Left.B1 = Right.B1 then + return Equal; + else + return Greater; + end if; + when Iir_Value_E8 => + if Left.E8 < Right.E8 then + return Less; + elsif Left.E8 = Right.E8 then + return Equal; + else + return Greater; + end if; + when Iir_Value_E32 => + if Left.E32 < Right.E32 then + return Less; + elsif Left.E32 = Right.E32 then + return Equal; + else + return Greater; + end if; + when Iir_Value_I64 => + if Left.I64 < Right.I64 then + return Less; + elsif Left.I64 = Right.I64 then + return Equal; + else + return Greater; + end if; + when Iir_Value_F64 => + if Left.F64 < Right.F64 then + return Less; + elsif Left.F64 = Right.F64 then + return Equal; + elsif Left.F64 > Right.F64 then + return Greater; + else + raise Constraint_Error; + end if; + when Iir_Value_Array => + -- LRM93 §7.2.2 + -- For discrete array types, the relation < (less than) is defined + -- such as the left operand is less than the right operand if + -- and only if: + -- * the left operand is a null array and the right operand is + -- a non-null array; otherwise + -- * both operands are non-null arrays, and one of the following + -- conditions is satisfied: + -- - the leftmost element of the left operand is less than + -- that of the right; or + -- - the leftmost element of the left operand is equal to + -- that of the right, and the tail of the left operand is + -- less than that of the right (the tail consists of the + -- remaining elements to the rights of the leftmost element + -- and can be null) + -- The relation <= (less than or equal) for discrete array types + -- is defined to be the inclusive disjunction of the results of + -- the < and = operators for the same two operands. + -- The relation > (greater than) and >= (greater than of equal) + -- are defined to be the complements of the <= and < operators + -- respectively for the same two operands. + if Left.Bounds.Nbr_Dims /= 1 or Right.Bounds.Nbr_Dims /= 1 then + raise Internal_Error; + end if; + for I in 1 .. Iir_Index32'Min (Left.Bounds.D (1).Length, + Right.Bounds.D (1).Length) + loop + case Compare_Value (Left.Val_Array.V (I), + Right.Val_Array.V (I)) is + when Less => + return Less; + when Greater => + return Greater; + when Equal => + null; + end case; + end loop; + if Left.Bounds.D (1).Length < Right.Bounds.D (1).Length then + return Less; + elsif Left.Bounds.D (1).Length = Right.Bounds.D (1).Length then + return Equal; + else + return Greater; + end if; + when Iir_Value_Signal + | Iir_Value_Access + | Iir_Value_Range + | Iir_Value_Record + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Compare_Value; + + function Is_Null_Range (Arange : Iir_Value_Literal_Acc) return Boolean + is + Cmp : Order; + begin + Cmp := Compare_Value (Arange.Left, Arange.Right); + case Arange.Dir is + when Iir_To => + return Cmp = Greater; + when Iir_Downto => + return Cmp = Less; + end case; + end Is_Null_Range; + + procedure Increment (Val : Iir_Value_Literal_Acc) is + begin + case Val.Kind is + when Iir_Value_B1 => + if Val.B1 = False then + Val.B1 := True; + else + raise Constraint_Error; + end if; + when Iir_Value_E8 => + Val.E8 := Val.E8 + 1; + when Iir_Value_E32 => + Val.E32 := Val.E32 + 1; + when Iir_Value_I64 => + Val.I64 := Val.I64 + 1; + when Iir_Value_F64 + | Iir_Value_Array + | Iir_Value_Record + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Increment; + + procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc) + is + begin + if Dest.Kind /= Src.Kind then + raise Constraint_Error; + end if; + case Dest.Kind is + when Iir_Value_Array => + if Dest.Val_Array.Len /= Src.Val_Array.Len then + raise Constraint_Error; + end if; + for I in Dest.Val_Array.V'Range loop + Store (Dest.Val_Array.V (I), Src.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + if Dest.Val_Record.Len /= Src.Val_Record.Len then + raise Constraint_Error; + end if; + for I in Dest.Val_Record.V'Range loop + Store (Dest.Val_Record.V (I), Src.Val_Record.V (I)); + end loop; + when Iir_Value_B1 => + Dest.B1 := Src.B1; + when Iir_Value_E8 => + Dest.E8 := Src.E8; + when Iir_Value_E32 => + Dest.E32 := Src.E32; + when Iir_Value_I64 => + Dest.I64 := Src.I64; + when Iir_Value_F64 => + Dest.F64 := Src.F64; + when Iir_Value_Access => + Dest.Val_Access := Src.Val_Access; + when Iir_Value_File => + Dest.File := Src.File; + when Iir_Value_Protected => + Dest.Prot := Src.Prot; + when Iir_Value_Signal => + pragma Assert (Dest.Sig = null); + Dest.Sig := Src.Sig; + when Iir_Value_Range + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Store; + + procedure Check_Bounds (Dest : Iir_Value_Literal_Acc; + Src : Iir_Value_Literal_Acc; + Loc : Iir) + is + begin + case Dest.Kind is + when Iir_Value_Array => + if Src.Kind /= Iir_Value_Array then + raise Internal_Error; + end if; + if Dest.Val_Array.Len /= Src.Val_Array.Len then + Error_Msg_Constraint (Loc); + end if; + if Dest.Val_Array.Len /= 0 then + Check_Bounds (Dest.Val_Array.V (1), Src.Val_Array.V (1), Loc); + end if; + when Iir_Value_Record => + if Src.Kind /= Iir_Value_Record then + raise Internal_Error; + end if; + if Dest.Val_Record.Len /= Src.Val_Record.Len then + raise Internal_Error; + end if; + for I in Dest.Val_Record.V'Range loop + Check_Bounds (Dest.Val_Record.V (I), Src.Val_Record.V (I), Loc); + end loop; + when Iir_Value_Access + | Iir_Value_File => + if Src.Kind /= Dest.Kind then + raise Internal_Error; + end if; + when Iir_Value_Scalars + | Iir_Value_Signal => + return; + when Iir_Value_Range + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Check_Bounds; + + function To_Iir_Value_Literal_Acc is new Ada.Unchecked_Conversion + (System.Address, Iir_Value_Literal_Acc); + function To_Value_Array_Acc is new Ada.Unchecked_Conversion + (System.Address, Value_Array_Acc); + function To_Value_Bounds_Array_Acc is new Ada.Unchecked_Conversion + (System.Address, Value_Bounds_Array_Acc); + + Last_Sig_Id : Signal_Index_Type := 0; + + function Get_Last_Signal_Index return Signal_Index_Type is + begin + return Last_Sig_Id; + end Get_Last_Signal_Index; + + function Create_Signal_Value (Sig : Ghdl_Signal_Ptr) + return Iir_Value_Literal_Acc + is + subtype Signal_Value is Iir_Value_Literal (Iir_Value_Signal); + function Alloc is new Alloc_On_Pool_Addr (Signal_Value); + begin + Last_Sig_Id := Last_Sig_Id + 1; + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Signal, + Sig => Sig, Sig_Id => Last_Sig_Id))); + end Create_Signal_Value; + + function Create_Terminal_Value (Terminal : Terminal_Index_Type) + return Iir_Value_Literal_Acc + is + subtype Terminal_Value is Iir_Value_Literal (Iir_Value_Terminal); + function Alloc is new Alloc_On_Pool_Addr (Terminal_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Terminal, Terminal => Terminal))); + end Create_Terminal_Value; + + function Create_Quantity_Value (Quantity : Quantity_Index_Type) + return Iir_Value_Literal_Acc + is + subtype Quantity_Value is Iir_Value_Literal (Iir_Value_Quantity); + function Alloc is new Alloc_On_Pool_Addr (Quantity_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Quantity, Quantity => Quantity))); + end Create_Quantity_Value; + + function Create_Environment_Value (Env : Environment_Index_Type) + return Iir_Value_Literal_Acc + is + subtype Environment_Value is Iir_Value_Literal (Iir_Value_Environment); + function Alloc is new Alloc_On_Pool_Addr (Environment_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Environment, Environment => Env))); + end Create_Environment_Value; + + function Create_Protected_Value (Prot : Protected_Index_Type) + return Iir_Value_Literal_Acc + is + subtype Protected_Value is Iir_Value_Literal (Iir_Value_Protected); + function Alloc is new Alloc_On_Pool_Addr (Protected_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Global_Pool'Access, + (Kind => Iir_Value_Protected, Prot => Prot))); + end Create_Protected_Value; + + function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc + is + subtype B1_Value is Iir_Value_Literal (Iir_Value_B1); + function Alloc is new Alloc_On_Pool_Addr (B1_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_B1, B1 => Val))); + end Create_B1_Value; + + function Create_E8_Value (Val : Ghdl_E8) return Iir_Value_Literal_Acc + is + subtype E8_Value is Iir_Value_Literal (Iir_Value_E8); + function Alloc is new Alloc_On_Pool_Addr (E8_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_E8, E8 => Val))); + end Create_E8_Value; + + function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc + is + subtype E32_Value is Iir_Value_Literal (Iir_Value_E32); + function Alloc is new Alloc_On_Pool_Addr (E32_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_E32, E32 => Val))); + end Create_E32_Value; + + function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc + is + subtype I64_Value is Iir_Value_Literal (Iir_Value_I64); + function Alloc is new Alloc_On_Pool_Addr (I64_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_I64, I64 => Val))); + end Create_I64_Value; + + function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc + is + subtype F64_Value is Iir_Value_Literal (Iir_Value_F64); + function Alloc is new Alloc_On_Pool_Addr (F64_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_F64, F64 => Val))); + end Create_F64_Value; + + function Create_Access_Value (Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + subtype Access_Value is Iir_Value_Literal (Iir_Value_Access); + function Alloc is new Alloc_On_Pool_Addr (Access_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, + (Kind => Iir_Value_Access, Val_Access => Val))); + end Create_Access_Value; + + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction; + Length : Iir_Index32) + return Iir_Value_Literal_Acc + is + subtype Range_Value is Iir_Value_Literal (Iir_Value_Range); + function Alloc is new Alloc_On_Pool_Addr (Range_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, + (Kind => Iir_Value_Range, + Left => Left, + Right => Right, + Dir => Dir, + Length => Length))); + end Create_Range_Value; + + function Create_File_Value (Val : Grt.Files.Ghdl_File_Index) + return Iir_Value_Literal_Acc + is + subtype File_Value is Iir_Value_Literal (Iir_Value_File); + function Alloc is new Alloc_On_Pool_Addr (File_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, + (Kind => Iir_Value_File, File => Val))); + end Create_File_Value; + + -- Create a range_value of life LIFE. + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction) + return Iir_Value_Literal_Acc + is + Low, High : Iir_Value_Literal_Acc; + Len : Iir_Index32; + begin + case Dir is + when Iir_To => + Low := Left; + High := Right; + when Iir_Downto => + Low := Right; + High := Left; + end case; + + case Iir_Value_Scalars (Low.Kind) is + when Iir_Value_B1 => + if High.B1 >= Low.B1 then + Len := Ghdl_B1'Pos (High.B1) - Ghdl_B1'Pos (Low.B1) + 1; + else + Len := 0; + end if; + when Iir_Value_E32 => + if High.E32 >= Low.E32 then + Len := Iir_Index32 (High.E32 - Low.E32 + 1); + else + Len := 0; + end if; + when Iir_Value_E8 => + if High.E8 >= Low.E8 then + Len := Ghdl_E8'Pos (High.E8) - Ghdl_E8'Pos (Low.E8) + 1; + else + Len := 0; + end if; + when Iir_Value_I64 => + declare + L : Ghdl_I64; + begin + if High.I64 = Ghdl_I64'Last and Low.I64 = Ghdl_I64'First + then + -- Prevent overflow + Len := Iir_Index32'Last; + else + L := High.I64 - Low.I64; + if L >= Ghdl_I64 (Iir_Index32'Last) then + -- Prevent overflow + Len := Iir_Index32'Last; + else + L := L + 1; + if L < 0 then + -- null range. + Len := 0; + else + Len := Iir_Index32 (L); + end if; + end if; + end if; + end; + when Iir_Value_F64 => + Len := 0; + end case; + return Create_Range_Value (Left, Right, Dir, Len); + end Create_Range_Value; + + -- Return an array of length LENGTH. + function Create_Array_Value (Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc + is + subtype Array_Value is Iir_Value_Literal (Iir_Value_Array); + function Alloc_Array is new Alloc_On_Pool_Addr (Array_Value); + subtype Dim_Type is Value_Bounds_Array (Dim); + function Alloc_Bounds is new Alloc_On_Pool_Addr (Dim_Type); + Res : Iir_Value_Literal_Acc; + begin + Res := To_Iir_Value_Literal_Acc + (Alloc_Array (Pool, + (Kind => Iir_Value_Array, + Bounds => null, Val_Array => null))); + + Res.Bounds := To_Value_Bounds_Array_Acc + (Alloc_Bounds (Pool, Dim_Type'(Nbr_Dims => Dim, + D => (others => null)))); + + return Res; + end Create_Array_Value; + + procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc; + Len : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + is + use System; + subtype Data_Type is Value_Array (Len); + Res : Address; + begin + -- Manually allocate the array to handle large arrays without + -- creating a large temporary value. + Allocate + (Pool.all, Res, Data_Type'Size / Storage_Unit, Data_Type'Alignment); + + declare + -- Discard the warnings for no pragma Import as we really want + -- to use the default initialization. + pragma Warnings (Off); + Addr1 : constant Address := Res; + Init : Data_Type; + for Init'Address use Addr1; + pragma Warnings (On); + begin + null; + end; + + Arr.Val_Array := To_Value_Array_Acc (Res); + end Create_Array_Data; + + function Create_Array_Value (Length: Iir_Index32; + Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value (Dim, Pool); + Create_Array_Data (Res, Length, Pool); + return Res; + end Create_Array_Value; + + function Create_Record_Value + (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc + is + subtype Record_Value is Iir_Value_Literal (Iir_Value_Record); + function Alloc_Record is new Alloc_On_Pool_Addr (Record_Value); + subtype Data_Type is Value_Array (Nbr); + function Alloc_Data is new Alloc_On_Pool_Addr (Data_Type); + Res : Iir_Value_Literal_Acc; + begin + Res := To_Iir_Value_Literal_Acc + (Alloc_Record (Pool, (Kind => Iir_Value_Record, Val_Record => null))); + + Res.Val_Record := To_Value_Array_Acc + (Alloc_Data (Pool, Data_Type'(Len => Nbr, V => (others => null)))); + + return Res; + end Create_Record_Value; + + -- Create a copy of SRC with a specified life. + function Copy (Src: in Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Src.Kind is + when Iir_Value_B1 => + return Create_B1_Value (Src.B1); + when Iir_Value_E32 => + return Create_E32_Value (Src.E32); + when Iir_Value_E8 => + return Create_E8_Value (Src.E8); + when Iir_Value_I64 => + return Create_I64_Value (Src.I64); + when Iir_Value_F64 => + return Create_F64_Value (Src.F64); + when Iir_Value_Access => + return Create_Access_Value (Src.Val_Access); + when Iir_Value_Array => + Res := Copy_Array_Bound (Src); + for I in Src.Val_Array.V'Range loop + Res.Val_Array.V (I) := Copy (Src.Val_Array.V (I)); + end loop; + return Res; + + when Iir_Value_Range => + return Create_Range_Value + (Left => Copy (Src.Left), + Right => Copy (Src.Right), + Dir => Src.Dir, + Length => Src.Length); + + when Iir_Value_Record => + Res := Copy_Record (Src); + for I in Src.Val_Record.V'Range loop + Res.Val_Record.V (I) := Copy (Src.Val_Record.V (I)); + end loop; + return Res; + + when Iir_Value_File => + return Create_File_Value (Src.File); + when Iir_Value_Protected => + return Create_Protected_Value (Src.Prot); + + when Iir_Value_Signal => + pragma Assert (Src.Sig = null); + return Create_Signal_Value (Src.Sig); + + when Iir_Value_Environment => + return Create_Environment_Value (Src.Environment); + + when Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Copy; + + function Copy_Array_Bound (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); + for I in Res.Bounds.D'Range loop + Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); + end loop; + return Res; + end Copy_Array_Bound; + + function Copy_Record (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Create_Record_Value (Src.Val_Record.Len); + end Copy_Record; + + function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc + is + Prev_Pool : constant Areapool_Acc := Current_Pool; + Res : Iir_Value_Literal_Acc; + begin + Current_Pool := Pool; + Res := Copy (Src); + Current_Pool := Prev_Pool; + return Res; + end Unshare; + + function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc is + begin + if Src.Kind /= Iir_Value_Array then + return Src; + end if; + declare + Prev_Pool : constant Areapool_Acc := Current_Pool; + Res : Iir_Value_Literal_Acc; + begin + Current_Pool := Pool; + Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); + for I in Src.Bounds.D'Range loop + Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); + end loop; + Res.Val_Array.V := Src.Val_Array.V; + Current_Pool := Prev_Pool; + return Res; + end; + end Unshare_Bounds; + + Heap_Pool : aliased Areapool; + + function Unshare_Heap (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + -- FIXME: this is never free. + return Unshare (Src, Heap_Pool'Access); + end Unshare_Heap; + + procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc) is + begin + null; + end Free_Heap_Value; + + function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural is + begin + case Val.Kind is + when Iir_Value_Scalars + | Iir_Value_Access + | Iir_Value_Signal => + return 1; + when Iir_Value_Record => + declare + Total : Natural := 0; + begin + for I in Val.Val_Record.V'Range loop + Total := Total + Get_Nbr_Of_Scalars (Val.Val_Record.V (I)); + end loop; + return Total; + end; + when Iir_Value_Array => + if Val.Val_Array.Len = 0 then + -- Nul array + return 0; + else + -- At least one element. + return Natural (Val.Val_Array.Len) + * Get_Nbr_Of_Scalars (Val.Val_Array.V (1)); + end if; + when Iir_Value_File + | Iir_Value_Range + | Iir_Value_Protected + | Iir_Value_Terminal + | Iir_Value_Quantity + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Get_Nbr_Of_Scalars; + + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural is + begin + case Val.Kind is + when Iir_Value_E8 => + return Ghdl_E8'Pos (Val.E8); + when Iir_Value_E32 => + return Ghdl_E32'Pos (Val.E32); + when Iir_Value_B1 => + return Ghdl_B1'Pos (Val.B1); + when others => + raise Internal_Error; + end case; + end Get_Enum_Pos; + + procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; + Tab: Ada.Text_IO.Count) + is + use Ada.Text_IO; + use GNAT.Debug_Utilities; + begin + Set_Col (Tab); + if Value = null then + Put_Line ("*NULL*"); + return; + end if; + + if Boolean'(True) then + Put (Image (Value.all'Address) & ' '); + end if; + + case Value.Kind is + when Iir_Value_B1 => + Put_Line ("b1:" & Ghdl_B1'Image (Value.B1)); + when Iir_Value_E8 => + Put_Line ("E8:" & Ghdl_E8'Image (Value.E8)); + when Iir_Value_E32 => + Put_Line ("e32:" & Ghdl_E32'Image (Value.E32)); + when Iir_Value_I64 => + Put_Line ("i64:" & Ghdl_I64'Image (Value.I64)); + when Iir_Value_F64 => + Put_Line ("F64:" & Ghdl_F64'Image (Value.F64)); + when Iir_Value_Access => + -- FIXME. + if Value.Val_Access = null then + Put_Line ("access: null"); + else + Put ("access: "); + Put_Line (Image (Value.Val_Access.all'Address)); + end if; + when Iir_Value_Array => + if Value.Val_Array = null then + Put_Line ("array, without elements"); + return; + else + Put_Line ("array, length: " + & Iir_Index32'Image (Value.Val_Array.Len)); + declare + Ntab: constant Count := Tab + Indentation; + begin + Set_Col (Ntab); + if Value.Bounds /= null then + Put_Line ("bounds 1 .." + & Iir_Index32'Image (Value.Bounds.Nbr_Dims) + & ':'); + for I in Value.Bounds.D'Range loop + Disp_Value_Tab (Value.Bounds.D (I), Ntab); + end loop; + else + Put_Line ("bounds = null"); + end if; + Set_Col (Ntab); + Put_Line ("values 1 .." + & Iir_Index32'Image (Value.Val_Array.Len) + & ':'); + for I in Value.Val_Array.V'Range loop + Disp_Value_Tab (Value.Val_Array.V (I), Ntab); + end loop; + end; + end if; + + when Iir_Value_Range => + Put_Line ("range:"); + Set_Col (Tab); + Put (" direction: "); + Put (Iir_Direction'Image (Value.Dir)); + Put (", length:"); + Put_Line (Iir_Index32'Image (Value.Length)); + if Value.Left /= null then + Set_Col (Tab); + Put (" left bound: "); + Disp_Value_Tab (Value.Left, Col); + end if; + if Value.Right /= null then + Set_Col (Tab); + Put (" right bound: "); + Disp_Value_Tab (Value.Right, Col); + end if; + + when Iir_Value_Record => + Put_Line ("record:"); + for I in Value.Val_Record.V'Range loop + Disp_Value_Tab (Value.Val_Record.V (I), Tab + Indentation); + end loop; + when Iir_Value_Signal => + Put ("signal: "); + if Value.Sig = null then + Put_Line ("(not created)"); + else + Put_Line (Image (Value.Sig.all'Address)); + end if; + + when Iir_Value_File => + Put_Line ("file:" & Grt.Files.Ghdl_File_Index'Image (Value.File)); + when Iir_Value_Protected => + Put_Line ("protected"); + when Iir_Value_Quantity => + Put_Line ("quantity"); + when Iir_Value_Terminal => + Put_Line ("terminal"); + when Iir_Value_Environment => + Put_Line ("environment"); + end case; + end Disp_Value_Tab; + + procedure Disp_Value (Value: Iir_Value_Literal_Acc) is + begin + Disp_Value_Tab (Value, 1); + end Disp_Value; + + -- Return TRUE if VALUE has an indirect value. + function Is_Indirect (Value : Iir_Value_Literal_Acc) return Boolean is + begin + case Value.Kind is + when Iir_Value_Scalars + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + return False; + when Iir_Value_Range => + return Is_Indirect (Value.Left) + or else Is_Indirect (Value.Right); + when Iir_Value_Array => + for I in Value.Val_Array.V'Range loop + if Is_Indirect (Value.Val_Array.V (I)) then + return True; + end if; + end loop; + return False; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + if Is_Indirect (Value.Val_Record.V (I)) then + return True; + end if; + end loop; + return False; + when Iir_Value_Signal => + return True; + end case; + end Is_Indirect; + + procedure Disp_Iir_Value_Array (Value: Iir_Value_Literal_Acc; + A_Type: Iir; + Dim: Iir_Index32; + Off : in out Iir_Index32) + is + use Ada.Text_IO; + type Last_Enum_Type is (None, Char, Identifier); + Last_Enum: Last_Enum_Type; + El_Type: Iir; + Enum_List: Iir_Flist; + El_Id : Name_Id; + El_Pos : Natural; + begin + if Dim = Value.Bounds.Nbr_Dims then + -- Last dimension + El_Type := Get_Base_Type (Get_Element_Subtype (A_Type)); + + -- Pretty print vectors of enumerated types + if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition + and then not Is_Indirect (Value) + then + Last_Enum := None; + Enum_List := Get_Enumeration_Literal_List (El_Type); + for I in 1 .. Value.Bounds.D (Dim).Length loop + El_Pos := Get_Enum_Pos (Value.Val_Array.V (Off)); + Off := Off + 1; + El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); + if Name_Table.Is_Character (El_Id) then + case Last_Enum is + when None => + Put (""""); + when Identifier => + Put (" & """); + when Char => + null; + end case; + Put (Name_Table.Get_Character (El_Id)); + Last_Enum := Char; + else + case Last_Enum is + when None => + null; + when Identifier => + Put (" & "); + when Char => + Put (""" & "); + end case; + Put (Name_Table.Image (El_Id)); + Last_Enum := Identifier; + end if; + end loop; + case Last_Enum is + when None => + Put (""""""); -- Simply "" + when Identifier => + null; + when Char => + Put (""""); + end case; + else + Put ("("); + for I in 1 .. Value.Bounds.D (Dim).Length loop + if I /= 1 then + Put (", "); + end if; + Disp_Iir_Value (Value.Val_Array.V (Off), El_Type); + Off := Off + 1; + end loop; + Put (")"); + end if; + else + Put ("("); + for I in 1 .. Value.Bounds.D (Dim).Length loop + if I /= 1 then + Put (", "); + end if; + Disp_Iir_Value_Array (Value, A_Type, Dim + 1, Off); + end loop; + Put (")"); + end if; + end Disp_Iir_Value_Array; + + procedure Disp_Iir_Value_Record + (Value: Iir_Value_Literal_Acc; A_Type: Iir) + is + use Ada.Text_IO; + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (A_Type)); + El : Iir_Element_Declaration; + begin + Put ("("); + for I in Value.Val_Record.V'Range loop + El := Get_Nth_Element (List, Natural (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Name_Table.Image (Get_Identifier (El))); + Put (" => "); + Disp_Iir_Value (Value.Val_Record.V (I), Get_Type (El)); + end loop; + Put (")"); + end Disp_Iir_Value_Record; + + procedure Disp_Iir_Value_Enum (Pos : Natural; A_Type : Iir) + is + Bt : constant Iir := Get_Base_Type (A_Type); + Id : Name_Id; + begin + Id := Get_Identifier + (Get_Nth_Element (Get_Enumeration_Literal_List (Bt), Pos)); + Ada.Text_IO.Put (Name_Table.Image (Id)); + end Disp_Iir_Value_Enum; + + procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir) is + use Ada.Text_IO; + begin + if Value = null then + Put ("!NULL!"); + return; + end if; + case Value.Kind is + when Iir_Value_I64 => + Put (Ghdl_I64'Image (Value.I64)); + when Iir_Value_F64 => + Put (Ghdl_F64'Image (Value.F64)); + when Iir_Value_E32 => + Disp_Iir_Value_Enum (Ghdl_E32'Pos (Value.E32), A_Type); + when Iir_Value_E8 => + Disp_Iir_Value_Enum (Ghdl_E8'Pos (Value.E8), A_Type); + when Iir_Value_B1 => + Disp_Iir_Value_Enum (Ghdl_B1'Pos (Value.B1), A_Type); + when Iir_Value_Access => + if Value.Val_Access = null then + Put ("null"); + else + -- FIXME. + Put ("*acc*"); + end if; + when Iir_Value_Array => + declare + Off : Iir_Index32; + begin + Off := 1; + Disp_Iir_Value_Array (Value, A_Type, 1, Off); + pragma Assert (Off = Value.Val_Array.Len + 1); + end; + when Iir_Value_File => + raise Internal_Error; + when Iir_Value_Record => + Disp_Iir_Value_Record (Value, A_Type); + when Iir_Value_Range => + -- FIXME. + raise Internal_Error; + when Iir_Value_Quantity => + Put ("[quantity]"); + when Iir_Value_Terminal => + Put ("[terminal]"); + when Iir_Value_Signal => + Put ("[signal]"); + when Iir_Value_Protected => + Put ("[protected]"); + when Iir_Value_Environment => + Put ("[environment]"); + end case; + end Disp_Iir_Value; +end Simul.Environments; diff --git a/src/vhdl/simulate/simul-environments.ads b/src/vhdl/simulate/simul-environments.ads new file mode 100644 index 000000000..e043659b3 --- /dev/null +++ b/src/vhdl/simulate/simul-environments.ads @@ -0,0 +1,481 @@ +-- Naive values for 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.Text_IO; +with Ada.Unchecked_Deallocation; +with Types; use Types; +with Iirs; use Iirs; +with Grt.Types; use Grt.Types; +with Grt.Signals; use Grt.Signals; +with Grt.Files; +with Areapools; use Areapools; +-- with System.Debug_Pools; + +package Simul.Environments is + -- During simulation, all values are contained into objects of type + -- iir_value_literal. The annotation pass creates such objects for every + -- literal of units. The elaboration pass creates such objects for + -- signals, variables, contants... + -- The simulator uses iir_value_literal for intermediate results, for + -- computed values... + + -- There is several kinds of iir_value_literal, mainly depending on the + -- type of the value: + -- + -- iir_value_e32: + -- the value is an enumeration literal. The enum field contains the + -- position of the literal (same as 'pos). + -- + -- iir_value_i64: + -- the value is an integer. + -- + -- iir_value_f64: + -- the value is a floating point. + -- + -- iir_value_range: + -- Boundaries and direction. + -- + -- iir_value_array: + -- All the values are contained in the array Val_Array. + -- Boundaries of the array are contained in the array BOUNDS, one element + -- per dimension, from 1 to number of dimensions. + -- + -- iir_value_signal: + -- Special case: the iir_value_literal designates a signal. + -- + -- iir_value_record + -- For records. + -- + -- iir_value_access + -- for accesses. + -- + -- iir_value_file + -- for files. + + -- Memory management: + -- The values are always allocated on areapool, which uses a mark/release + -- management. A release operation frees all the memory of the areapool + -- allocated since the mark. This memory management is very efficient. + -- + -- There is one areapool per processes; there is one mark per instances. + -- Objects (variables, signals, constants, iterators, ...) are allocated + -- on the per-process pool. When an activation frame is created (due + -- to a call to a subprogram), a mark is saved. When the activation frame + -- is removed (due to a return from subprogram), the memory is released to + -- the mark. That's simple. + -- + -- Objects for the process is allocated in that areapool, but never + -- released (could be if the process is waiting forever if the user don't + -- need to inspect values). + -- + -- Signals and constants for blocks/entity/architecture are allocated on + -- a global pool. + -- + -- In fact this is not so simple because of functions: they return a + -- value. The current solution is to compute every expressions on a + -- expression pool (only one is needed as the computation cannot be + -- suspended), use the result (copy in case of assignment or return), and + -- release that pool. + -- + -- It is highly recommended to share values as much as possible for + -- expressions (for example, alias the values of 'others =>'). Do not + -- share values for names, but be sure to keep the original nodes. + -- ??? In fact sharing is required to pass actual by references. + -- When an object is created, be sure to unshare the values. This is + -- usually achieved by Copy. + -- + -- Finally, a pool is also needed during elaboration (as elaboration is + -- not done within the context of a process). + + type Iir_Value_Kind is + (Iir_Value_B1, Iir_Value_E8, Iir_Value_E32, + Iir_Value_I64, Iir_Value_F64, + Iir_Value_Access, + Iir_Value_File, + Iir_Value_Range, + Iir_Value_Array, Iir_Value_Record, + Iir_Value_Protected, + Iir_Value_Signal, + Iir_Value_Terminal, + Iir_Value_Quantity, + Iir_Value_Environment); + + -- Uniq identifier for scalar signal. First identifier is 'First + 1. + type Signal_Index_Type is new Natural; + function Get_Last_Signal_Index return Signal_Index_Type; + + type Protected_Index_Type is new Natural; + type Quantity_Index_Type is new Natural; + type Terminal_Index_Type is new Natural; + type Environment_Index_Type is new Natural; + + -- Scalar values. Only these ones can be signals. + subtype Iir_Value_Scalars is + Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_F64; + + subtype Iir_Value_Discrete is + Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_I64; + + subtype Iir_Value_Enums is + Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_E32; + + -- Abstrace numeric types. + subtype Iir_Value_Numerics is + Iir_Value_Kind range Iir_Value_I64 .. Iir_Value_F64; + + subtype Iir_Value_Physicals is + Iir_Value_Kind range Iir_Value_I64 .. Iir_Value_I64; + + type Iir_Value_Literal (Kind: Iir_Value_Kind); + + type Iir_Value_Literal_Acc is access Iir_Value_Literal; + + -- Must start at 0. + -- Thus, length of the array is val_array'last - 1. + type Iir_Value_Literal_Array is array (Iir_Index32 range <>) of + Iir_Value_Literal_Acc; + + type Iir_Value_Literal_Array_Acc is access Iir_Value_Literal_Array; + + type Value_Bounds_Array (Nbr_Dims : Iir_Index32) is record + D : Iir_Value_Literal_Array (1 .. Nbr_Dims); + end record; + + type Value_Bounds_Array_Acc is access Value_Bounds_Array; + + type Value_Array (Len : Iir_Index32) is record + V : Iir_Value_Literal_Array (1 .. Len); + end record; + + type Value_Array_Acc is access Value_Array; + + -- A block instance with its architecture/entity declaration is an + -- instancied entity. + type Block_Instance_Type; + type Block_Instance_Acc is access Block_Instance_Type; + + type Iir_Value_Literal (Kind: Iir_Value_Kind) is record + case Kind is + when Iir_Value_B1 => + B1 : Ghdl_B1; + when Iir_Value_E8 => + E8 : Ghdl_E8; + when Iir_Value_E32 => + E32 : Ghdl_E32; + when Iir_Value_I64 => + I64 : Ghdl_I64; + when Iir_Value_F64 => + F64 : Ghdl_F64; + when Iir_Value_Access => + Val_Access: Iir_Value_Literal_Acc; + when Iir_Value_File => + File: Grt.Files.Ghdl_File_Index; + when Iir_Value_Array => + Val_Array: Value_Array_Acc; -- range 1 .. N + Bounds : Value_Bounds_Array_Acc; -- range 1 .. Dim + when Iir_Value_Record => + Val_Record: Value_Array_Acc; -- range 1 .. N + when Iir_Value_Signal => + Sig : Ghdl_Signal_Ptr; + -- Each signal has a uniq identifier. + Sig_Id : Signal_Index_Type; + when Iir_Value_Protected => + Prot : Protected_Index_Type; + when Iir_Value_Quantity => + Quantity : Quantity_Index_Type; + when Iir_Value_Terminal => + Terminal : Terminal_Index_Type; + when Iir_Value_Environment => + Environment : Environment_Index_Type; + when Iir_Value_Range => + Dir: Iir_Direction; + Length : Iir_Index32; + Left: Iir_Value_Literal_Acc; + Right: Iir_Value_Literal_Acc; + end case; + end record; + + type Object_Slot_Type is new Natural; + subtype Parameter_Slot_Type is Object_Slot_Type range 0 .. 2**15; + + type Pkg_Index_Type is new Natural; + + -- Scope corresponding to an object. + type Scope_Kind_Type is + ( + -- For a package, the depth is + Scope_Kind_Package, + Scope_Kind_Component, + Scope_Kind_Frame, + Scope_Kind_Pkg_Inst, + Scope_Kind_None + ); + type Scope_Depth_Type is range 0 .. 2**15; + type Scope_Type (Kind : Scope_Kind_Type := Scope_Kind_None) is record + case Kind is + when Scope_Kind_Package => + Pkg_Index : Pkg_Index_Type; + when Scope_Kind_Component => + null; + when Scope_Kind_Frame => + Depth : Scope_Depth_Type; + when Scope_Kind_Pkg_Inst => + Pkg_Param : Parameter_Slot_Type; + -- Pkg_Parent : Sim_Info_Acc; + when Scope_Kind_None => + null; + end case; + end record; + + type Block_Instance_Id is new Natural; + No_Block_Instance_Id : constant Block_Instance_Id := 0; + + type Objects_Array is array (Object_Slot_Type range <>) of + Iir_Value_Literal_Acc; + + type Block_Instance_Type (Max_Objs : Object_Slot_Type) is record + -- Flag for wait statement: true if not yet executed. + In_Wait_Flag : Boolean; + + -- Uniq number for a block instance. + Id : Block_Instance_Id; + + -- Useful informations for a dynamic block (ie, a frame). + -- The scope level and an access to the block of upper scope level. + Block_Scope : Scope_Type; + Up_Block : Block_Instance_Acc; + + -- Block, architecture, package, process, component instantiation for + -- this instance. + Label : Iir; + + -- For blocks: corresponding block (different from label for direct + -- component instantiation statement and generate iterator). + -- For packages: Null_Iir + -- For subprograms and processes: statement being executed. + Stmt : Iir; + + -- Instanciation tree. + + -- Parent is always set (but null for top-level block and packages) + Parent: Block_Instance_Acc; + + -- Chain of children. They are in declaration order after elaboration. + -- (in reverse order during elaboration). + -- Not null only for blocks and processes. + Children: Block_Instance_Acc; + Brother: Block_Instance_Acc; + + -- Port association map for this block, if any. + Ports_Map : Iir; + + -- Pool marker for the child (only for subprograms and processes). + Marker : Areapools.Mark_Type; + + -- Reference to the actuals, for copy-out when returning from a + -- procedure. + Actuals_Ref : Value_Array_Acc; + + -- Only for function frame; contains the result. + Result: Iir_Value_Literal_Acc; + + -- Last object elaborated (or number of objects elaborated). + -- Note: this is generally the slot index of the next object to be + -- elaborated (this may be wrong for dynamic objects due to execution + -- branches). + Elab_Objects : Object_Slot_Type := 0; + + -- Values of the objects in that frame. + Objects : Objects_Array (1 .. Max_Objs); + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Block_Instance_Type, Name => Block_Instance_Acc); + + + -- What is chosen for time. + subtype Iir_Value_Time is Ghdl_I64; + + Global_Pool : aliased Areapool; + Expr_Pool : aliased Areapool; + + -- Areapool used by Create_*_Value + Current_Pool : Areapool_Acc := Expr_Pool'Access; + + -- Pool for objects allocated in the current instance. + Instance_Pool : Areapool_Acc; + + function Create_Signal_Value (Sig : Ghdl_Signal_Ptr) + return Iir_Value_Literal_Acc; + function Create_Terminal_Value (Terminal : Terminal_Index_Type) + return Iir_Value_Literal_Acc; + function Create_Quantity_Value (Quantity : Quantity_Index_Type) + return Iir_Value_Literal_Acc; + function Create_Environment_Value (Env : Environment_Index_Type) + return Iir_Value_Literal_Acc; + + function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc; + function Create_E8_Value (Val : Ghdl_E8) return Iir_Value_Literal_Acc; + function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc; + + -- Return an iir_value_literal_acc (iir_value_int64). + function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc; + + -- Return an iir_value_literal_acc (iir_value_fp64) + function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc; + + function Create_Access_Value (Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Create_File_Value (Val : Grt.Files.Ghdl_File_Index) + return Iir_Value_Literal_Acc; + + function Create_Protected_Value (Prot : Protected_Index_Type) + return Iir_Value_Literal_Acc; + + -- Return an iir_value_literal (iir_value_record) of NBR elements. + function Create_Record_Value + (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc; + + -- Allocate array and the dimension vector (but bounds and values aren't + -- allocated). + function Create_Array_Value (Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc; + + -- Allocate the Val_Array vector. + procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc; + Len : Iir_Index32; + Pool : Areapool_Acc := Current_Pool); + + -- Return an array of length LENGTH and DIM bounds. + -- If DIM is 0, then the bounds array is not allocated. + function Create_Array_Value (Length: Iir_Index32; + Dim : Iir_Index32; + Pool : Areapool_Acc := Current_Pool) + return Iir_Value_Literal_Acc; + + -- Create a range_value of life LIFE. + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction; + Length : Iir_Index32) + return Iir_Value_Literal_Acc; + + -- Create a range_value (compute the length) + function Create_Range_Value + (Left, Right : Iir_Value_Literal_Acc; + Dir : Iir_Direction) + return Iir_Value_Literal_Acc; + + -- Return true if the value of LEFT and RIGHT are equal. + -- Return false if they are not equal. + -- Raise constraint_error if the types differes. + -- Value or sub-value must not be indirect. + function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean; + + -- Return TRUE iif ARANGE is a null range. + function Is_Null_Range (Arange : Iir_Value_Literal_Acc) return Boolean; + + -- Get order of LEFT with RIGHT. + -- Must be discrete kind (enum, int, fp, physical) or array (uni dim). + type Order is (Less, Equal, Greater); + function Compare_Value (Left, Right : Iir_Value_Literal_Acc) + return Order; + + -- Check that SRC has the same structure as DEST. Report an error at + -- LOC if not. + procedure Check_Bounds (Dest : Iir_Value_Literal_Acc; + Src : Iir_Value_Literal_Acc; + Loc : Iir); + + -- Store (by copy) SRC into DEST. + -- The type must be equal (otherwise constraint_error is raised). + -- Life of DEST must be Target, otherwise program_error is raised. + -- Value or sub-value must not be indirect. + procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc); + + -- Create a copy of SRC allocated in POOL. + function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc; + + -- If SRC is an array, just copy the bounds in POOL and return it. + -- Otherwise return SRC. Values are always kept, so that this could + -- be used by alias declarations. + function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) + return Iir_Value_Literal_Acc; + + -- Create a copy of SRC on the heap. + function Unshare_Heap (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Deallocate value accessed by ACC. + procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc); + + -- Increment. + -- VAL must be of kind integer or enumeration. + -- VAL must be of life temporary. + procedure Increment (Val : Iir_Value_Literal_Acc); + + -- Copy BOUNDS of SRC with a specified life. + -- Note: val_array is allocated but not filled. + function Copy_Array_Bound (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Copy the bounds (well the array containing the values) of SRC. + -- Val_record is allocated but not filled. + function Copy_Record (Src : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Return the number of scalars elements in VALS. + function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural; + + -- Return the position of an enumerated type value. + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural; + + -- Well known values. + -- Boolean_to_lit can be used to convert a boolean value from Ada to a + -- boolean value for vhdl. + type Lit_Enum_Type is array (Boolean) of Iir_Value_Literal_Acc; + Lit_Enum_0 : constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_B1, + B1 => False); + Lit_Enum_1 : constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_B1, + B1 => True); + Boolean_To_Lit: constant Lit_Enum_Type := + (False => Lit_Enum_0, True => Lit_Enum_1); + Lit_Boolean_False: Iir_Value_Literal_Acc + renames Boolean_To_Lit (False); + Lit_Boolean_True: Iir_Value_Literal_Acc + renames Boolean_To_Lit (True); + + -- Literal NULL. + Null_Lit: constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_Access, + Val_Access => null); + + -- Disp a value_literal in raw form. + procedure Disp_Value (Value: Iir_Value_Literal_Acc); + procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; + Tab: Ada.Text_IO.Count); + + -- Disp a value_literal in readable form. + procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir); +end Simul.Environments; diff --git a/src/vhdl/simulate/simul-execution.adb b/src/vhdl/simulate/simul-execution.adb new file mode 100644 index 000000000..d6639c06d --- /dev/null +++ b/src/vhdl/simulate/simul-execution.adb @@ -0,0 +1,4831 @@ +-- Interpreted simulation +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Conversion; +with Ada.Text_IO; use Ada.Text_IO; +with System; +with Grt.Types; use Grt.Types; +with Flags; use Flags; +with Errorout; use Errorout; +with Std_Package; +with Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Simul.Annotations; use Simul.Annotations; +with Name_Table; +with Simul.File_Operation; +with Simul.Debugger; use Simul.Debugger; +with Std_Names; +with Str_Table; +with Files_Map; +with Iir_Chains; use Iir_Chains; +with Simul.Simulation; use Simul.Simulation; +with Grt.Astdio; +with Grt.Stdio; +with Grt.Options; +with Grt.Vstrings; +with Simul.Grt_Interface; +with Grt.Values; +with Grt.Errors; +with Grt.Std_Logic_1164; +with Grt.Lib; +with Grt.Strings; +with Sem_Inst; + +package body Simul.Execution is + + function Execute_Function_Call + (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) + return Iir_Value_Literal_Acc; + + procedure Finish_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir); + procedure Init_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir); + procedure Update_Next_Statement (Proc : Process_State_Acc); + + -- Display a message when an assertion has failed. + procedure Execute_Failed_Assertion (Msg : String; + Report : String; + Severity : Natural; + Stmt: Iir); + + function Get_Instance_By_Scope + (Instance: Block_Instance_Acc; Scope: Scope_Type) + return Block_Instance_Acc is + begin + case Scope.Kind is + when Scope_Kind_Frame => + declare + Current : Block_Instance_Acc; + Last : Block_Instance_Acc; + begin + Current := Instance; + while Current /= null loop + if Current.Block_Scope = Scope then + return Current; + end if; + Last := Current; + Current := Current.Up_Block; + end loop; + if Scope.Depth = 0 + and then Last.Block_Scope.Kind = Scope_Kind_Package + then + -- For instantiated packages. + return Last; + end if; + raise Internal_Error; + end; + when Scope_Kind_Package => + -- Global scope (packages) + return Package_Instances (Scope.Pkg_Index); + when Scope_Kind_Component => + pragma Assert (Current_Component /= null); + return Current_Component; + when Scope_Kind_None => + raise Internal_Error; + when Scope_Kind_Pkg_Inst => + raise Internal_Error; + end case; + end Get_Instance_By_Scope; + + function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) + return Block_Instance_Acc is + begin + return Get_Instance_By_Scope (Instance, Get_Info (Decl).Obj_Scope); + end Get_Instance_For_Slot; + + procedure Create_Right_Bound_From_Length + (Bounds : Iir_Value_Literal_Acc; Len : Iir_Index32) + is + begin + pragma Assert (Bounds.Right = null); + + case Bounds.Left.Kind is + when Iir_Value_E32 => + declare + R : Ghdl_E32; + begin + case Bounds.Dir is + when Iir_To => + R := Bounds.Left.E32 + Ghdl_E32 (Len - 1); + when Iir_Downto => + R := Bounds.Left.E32 - Ghdl_E32 (Len - 1); + end case; + Bounds.Right := Create_E32_Value (R); + end; + when Iir_Value_I64 => + declare + R : Ghdl_I64; + begin + case Bounds.Dir is + when Iir_To => + R := Bounds.Left.I64 + Ghdl_I64 (Len - 1); + when Iir_Downto => + R := Bounds.Left.I64 - Ghdl_I64 (Len - 1); + end case; + Bounds.Right := Create_I64_Value (R); + end; + when others => + raise Internal_Error; + end case; + end Create_Right_Bound_From_Length; + + function Create_Bounds_From_Length (Block : Block_Instance_Acc; + Atype : Iir; + Len : Iir_Index32) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Index_Bounds : Iir_Value_Literal_Acc; + begin + Index_Bounds := Execute_Bounds (Block, Atype); + + Res := Create_Range_Value (Left => Index_Bounds.Left, + Right => null, + Dir => Index_Bounds.Dir, + Length => Len); + + if Len = 0 then + -- Special case. + Res.Right := Res.Left; + case Res.Left.Kind is + when Iir_Value_I64 => + case Index_Bounds.Dir is + when Iir_To => + Res.Left := Create_I64_Value (Res.Right.I64 + 1); + when Iir_Downto => + Res.Left := Create_I64_Value (Res.Right.I64 - 1); + end case; + when others => + raise Internal_Error; + end case; + else + Create_Right_Bound_From_Length (Res, Len); + end if; + return Res; + end Create_Bounds_From_Length; + + function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Right; + else + return Bounds.Left; + end if; + end Execute_High_Limit; + + function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Left; + else + return Bounds.Right; + end if; + end Execute_Low_Limit; + + function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Left; + end Execute_Left_Limit; + + function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Right; + end Execute_Right_Limit; + + function Execute_Length (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Create_I64_Value (Ghdl_I64 (Bounds.Length)); + end Execute_Length; + + function Create_Enum_Value (Pos : Natural; Etype : Iir) + return Iir_Value_Literal_Acc + is + Base_Type : constant Iir := Get_Base_Type (Etype); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + case Iir_Value_Enums (Mode) is + when Iir_Value_E8 => + return Create_E8_Value (Ghdl_E8 (Pos)); + when Iir_Value_E32 => + return Create_E32_Value (Ghdl_E32 (Pos)); + when Iir_Value_B1 => + return Create_B1_Value (Ghdl_B1'Val (Pos)); + end case; + end Create_Enum_Value; + + function String_To_Iir_Value (Str : String) return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value (Str'Length, 1); + Res.Bounds.D (1) := Create_Range_Value + (Create_I64_Value (1), + Create_I64_Value (Str'Length), + Iir_To); + for I in Str'Range loop + Res.Val_Array.V (1 + Iir_Index32 (I - Str'First)) := + Create_E8_Value (Character'Pos (Str (I))); + end loop; + return Res; + end String_To_Iir_Value; + + function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; + Expr_Type : Iir) + return String + is + begin + case Get_Kind (Expr_Type) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + declare + Str : String (1 .. 24); + Last : Natural; + begin + Grt.Vstrings.To_String (Str, Last, Val.F64); + return Str (Str'First .. Last); + end; + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + declare + Str : String (1 .. 21); + First : Natural; + begin + Grt.Vstrings.To_String (Str, First, Val.I64); + return Str (First .. Str'Last); + end; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + declare + Lits : constant Iir_Flist := + Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); + Pos : Natural; + begin + case Iir_Value_Enums (Val.Kind) is + when Iir_Value_B1 => + Pos := Ghdl_B1'Pos (Val.B1); + when Iir_Value_E8 => + Pos := Ghdl_E8'Pos (Val.E8); + when Iir_Value_E32 => + Pos := Ghdl_E32'Pos (Val.E32); + end case; + return Name_Table.Image + (Get_Identifier (Get_Nth_Element (Lits, Pos))); + end; + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Str : String (1 .. 21); + First : Natural; + Id : constant Name_Id := + Get_Identifier (Get_Primary_Unit (Get_Base_Type (Expr_Type))); + begin + Grt.Vstrings.To_String (Str, First, Val.I64); + return Str (First .. Str'Last) & ' ' & Name_Table.Image (Id); + end; + when others => + Error_Kind ("execute_image_attribute", Expr_Type); + end case; + end Execute_Image_Attribute; + + function Execute_Image_Attribute (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc + is + Val : Iir_Value_Literal_Acc; + Attr_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + begin + Val := Execute_Expression (Block, Get_Parameter (Expr)); + return String_To_Iir_Value + (Execute_Image_Attribute (Val, Attr_Type)); + end Execute_Image_Attribute; + + function Execute_Path_Instance_Name_Attribute + (Block : Block_Instance_Acc; Attr : Iir) return Iir_Value_Literal_Acc + is + use Evaluation; + use Grt.Vstrings; + use Name_Table; + + Name : constant Path_Instance_Name_Type := + Get_Path_Instance_Name_Suffix (Attr); + Instance : Block_Instance_Acc; + Rstr : Rstring; + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + if Name.Path_Instance = Null_Iir then + return String_To_Iir_Value (Name.Suffix); + end if; + + Instance := Get_Instance_By_Scope + (Block, Get_Info (Name.Path_Instance).Frame_Scope); + + loop + case Get_Kind (Instance.Label) is + when Iir_Kind_Entity_Declaration => + if Instance.Parent = null then + Prepend (Rstr, Image (Get_Identifier (Instance.Label))); + exit; + end if; + when Iir_Kind_Architecture_Body => + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Image (Get_Identifier (Instance.Label))); + Prepend (Rstr, '('); + end if; + + if Is_Instance or else Instance.Parent = null then + Prepend + (Rstr, + Image (Get_Identifier (Get_Entity (Instance.Label)))); + end if; + if Instance.Parent = null then + Prepend (Rstr, ':'); + exit; + else + Instance := Instance.Parent; + end if; + when Iir_Kind_Block_Statement => + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when Iir_Kind_Iterator_Declaration => + declare + Val : Iir_Value_Literal_Acc; + begin + Val := Execute_Name (Instance, Instance.Label); + Prepend (Rstr, ')'); + Prepend (Rstr, Execute_Image_Attribute + (Val, Get_Type (Instance.Label))); + Prepend (Rstr, '('); + end; + Instance := Instance.Parent; + when Iir_Kind_Generate_Statement_Body => + Prepend (Rstr, Image (Get_Label (Get_Parent (Instance.Label)))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when Iir_Kind_Component_Instantiation_Statement => + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when others => + Error_Kind ("Execute_Path_Instance_Name_Attribute", + Instance.Label); + end case; + end loop; + declare + Str1 : String (1 .. Length (Rstr)); + Len1 : Natural; + begin + Copy (Rstr, Str1, Len1); + Free (Rstr); + return String_To_Iir_Value (Str1 & ':' & Name.Suffix); + end; + end Execute_Path_Instance_Name_Attribute; + + function Execute_Shift_Operator (Left : Iir_Value_Literal_Acc; + Count : Ghdl_I64; + Expr : Iir) + return Iir_Value_Literal_Acc + is + Func : constant Iir_Predefined_Shift_Functions := + Get_Implicit_Definition (Get_Implementation (Expr)); + Cnt : Iir_Index32; + Len : constant Iir_Index32 := Left.Bounds.D (1).Length; + Dir_Left : Boolean; + P : Iir_Index32; + Res : Iir_Value_Literal_Acc; + E : Iir_Value_Literal_Acc; + begin + -- LRM93 7.2.3 + -- That is, if R is 0 or if L is a null array, the return value is L. + if Count = 0 or else Len = 0 then + return Left; + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Dir_Left := True; + when Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + Dir_Left := False; + end case; + if Count < 0 then + Cnt := Iir_Index32 (-Count); + Dir_Left := not Dir_Left; + else + Cnt := Iir_Index32 (Count); + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + E := Create_Enum_Value + (0, Get_Element_Subtype (Get_Base_Type (Get_Type (Expr)))); + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + E := Left.Val_Array.V (Len); + else + E := Left.Val_Array.V (1); + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Cnt := Cnt mod Len; + if not Dir_Left then + Cnt := (Len - Cnt) mod Len; + end if; + end case; + + Res := Create_Array_Value (1); + Res.Bounds.D (1) := Left.Bounds.D (1); + Create_Array_Data (Res, Len); + P := 1; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + if Cnt < Len then + for I in Cnt .. Len - 1 loop + Res.Val_Array.V (P) := Left.Val_Array.V (I + 1); + P := P + 1; + end loop; + else + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Res.Val_Array.V (P) := E; + P := P + 1; + end loop; + else + if Cnt > Len then + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Res.Val_Array.V (P) := E; + P := P + 1; + end loop; + for I in Cnt .. Len - 1 loop + Res.Val_Array.V (P) := Left.Val_Array.V (I - Cnt + 1); + P := P + 1; + end loop; + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + for I in 1 .. Len loop + Res.Val_Array.V (P) := Left.Val_Array.V (Cnt + 1); + P := P + 1; + Cnt := Cnt + 1; + if Cnt = Len then + Cnt := 0; + end if; + end loop; + end case; + return Res; + end Execute_Shift_Operator; + + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + function Execute_Bit_Vector_To_String (Val : Iir_Value_Literal_Acc; + Log_Base : Natural) + return Iir_Value_Literal_Acc + is + Base : constant Natural := 2 ** Log_Base; + Blen : constant Natural := Natural (Val.Bounds.D (1).Length); + Str : String (1 .. (Blen + Log_Base - 1) / Log_Base); + Pos : Natural; + V : Natural; + N : Natural; + begin + V := 0; + N := 1; + Pos := Str'Last; + for I in reverse Val.Val_Array.V'Range loop + V := V + Ghdl_B1'Pos (Val.Val_Array.V (I).B1) * N; + N := N * 2; + if N = Base or else I = Val.Val_Array.V'First then + Str (Pos) := Hex_Chars (V); + Pos := Pos - 1; + N := 1; + V := 0; + end if; + end loop; + return String_To_Iir_Value (Str); + end Execute_Bit_Vector_To_String; + + procedure Assert_Std_Ulogic_Dc (Loc : Iir) + is + use Grt.Std_Logic_1164; + begin + Execute_Failed_Assertion + ("assertion", + "STD_LOGIC_1164: '-' operand for matching ordering operator", + 1, Loc); + end Assert_Std_Ulogic_Dc; + + procedure Check_Std_Ulogic_Dc (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic) + is + use Grt.Std_Logic_1164; + begin + if V = '-' then + Assert_Std_Ulogic_Dc (Loc); + end if; + end Check_Std_Ulogic_Dc; + + -- EXPR is the expression whose implementation is an implicit function. + function Execute_Implicit_Function (Block : Block_Instance_Acc; + Expr: Iir; + Left_Param : Iir; + Right_Param : Iir; + Res_Type : Iir) + return Iir_Value_Literal_Acc + is + pragma Unsuppress (Overflow_Check); + + Imp : constant Iir := Strip_Denoting_Name (Get_Implementation (Expr)); + Func : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + + -- Rename definition for monadic operations. + Left, Right: Iir_Value_Literal_Acc; + Operand : Iir_Value_Literal_Acc renames Left; + Result: Iir_Value_Literal_Acc; + + procedure Eval_Right is + begin + Right := Execute_Expression (Block, Right_Param); + end Eval_Right; + + -- Eval right argument, check left and right have same length, + -- Create RESULT from left. + procedure Eval_Array is + begin + Eval_Right; + if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then + Error_Msg_Constraint (Expr); + end if; + -- Need to copy as the result is modified. + Result := Unshare (Left, Expr_Pool'Access); + end Eval_Array; + begin + -- Eval left operand. + case Func is + when Iir_Predefined_Now_Function => + Left := null; + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge=> + Operand := Execute_Name (Block, Left_Param, True); + when others => + Left := Execute_Expression (Block, Left_Param); + end case; + Right := null; + + case Func is + when Iir_Predefined_Error => + raise Internal_Error; + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Eval_Right; + + declare + -- Array length of the result. + Len: Iir_Index32; + + -- Index into the result. + Pos: Iir_Index32; + begin + -- Compute the length of the result. + case Func is + when Iir_Predefined_Array_Array_Concat => + Len := Left.Val_Array.Len + Right.Val_Array.Len; + when Iir_Predefined_Element_Array_Concat => + Len := 1 + Right.Val_Array.Len; + when Iir_Predefined_Array_Element_Concat => + Len := Left.Val_Array.Len + 1; + when Iir_Predefined_Element_Element_Concat => + Len := 1 + 1; + when others => + raise Program_Error; + end case; + + if Func = Iir_Predefined_Array_Array_Concat + and then Left.Val_Array.Len = 0 + then + if Flags.Vhdl_Std = Vhdl_87 then + -- LRM87 7.2.3 + -- [...], unless the left operand is a null array, in + -- which case the result of the concatenation is the + -- right operand. + return Right; + else + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of + -- the concatenation is the right operand. + if Right.Val_Array.Len = 0 then + return Right; + end if; + end if; + end if; + + if Flags.Vhdl_Std = Vhdl_87 + and then (Func = Iir_Predefined_Array_Array_Concat + or Func = Iir_Predefined_Array_Element_Concat) + then + -- LRM87 7.2.3 Adding Operators + -- The left bound if this result is the left bound of the + -- left operand, [...]. The direction of the result is the + -- direction of the left operand, unless the left operand + -- is a null array, in which case the direction of the + -- result is that of the right operand. + Result := Create_Array_Value (Len, 1); + Result.Bounds.D (1) := Create_Range_Value + (Left.Bounds.D (1).Left, null, Left.Bounds.D (1).Dir, Len); + Create_Right_Bound_From_Length (Result.Bounds.D (1), Len); + else + -- Create the array result. + Result := Create_Array_Value (Len, 1); + Result.Bounds.D (1) := Create_Bounds_From_Length + (Block, + Get_Nth_Element (Get_Index_Subtype_List (Res_Type), 0), + Len); + end if; + + -- Fill the result: left. + case Func is + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Array_Element_Concat => + for I in Left.Val_Array.V'Range loop + Result.Val_Array.V (I) := Left.Val_Array.V (I); + end loop; + Pos := Left.Val_Array.Len; + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Result.Val_Array.V (1) := Left; + Pos := 1; + when others => + raise Program_Error; + end case; + + -- Note: here POS is equal to the position of the last element + -- filled, or 0 if no elements were filled. + + -- Fill the result: right. + case Func is + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat => + for I in Right.Val_Array.V'Range loop + Result.Val_Array.V (Pos + I) := Right.Val_Array.V (I); + end loop; + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Result.Val_Array.V (Pos + 1) := Right; + when others => + raise Program_Error; + end case; + end; + + when Iir_Predefined_Bit_And + | Iir_Predefined_Boolean_And => + if Left.B1 = Lit_Enum_0.B1 then + -- Short circuit operator. + Result := Lit_Enum_0; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); + end if; + when Iir_Predefined_Bit_Nand + | Iir_Predefined_Boolean_Nand => + if Left.B1 = Lit_Enum_0.B1 then + -- Short circuit operator. + Result := Lit_Enum_1; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); + end if; + when Iir_Predefined_Bit_Or + | Iir_Predefined_Boolean_Or => + if Left.B1 = Lit_Enum_1.B1 then + -- Short circuit operator. + Result := Lit_Enum_1; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); + end if; + when Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_Nor => + if Left.B1 = Lit_Enum_1.B1 then + -- Short circuit operator. + Result := Lit_Enum_0; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); + end if; + when Iir_Predefined_Bit_Xor + | Iir_Predefined_Boolean_Xor => + Eval_Right; + Result := Boolean_To_Lit (Left.B1 /= Right.B1); + when Iir_Predefined_Bit_Xnor + | Iir_Predefined_Boolean_Xnor => + Eval_Right; + Result := Boolean_To_Lit (Left.B1 = Right.B1); + when Iir_Predefined_Bit_Not + | Iir_Predefined_Boolean_Not => + Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_0.B1); + + when Iir_Predefined_Bit_Condition => + Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_1.B1); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Eval_Right; + Result := Execute_Shift_Operator (Left, Right.I64, Expr); + + when Iir_Predefined_Enum_Equality + | Iir_Predefined_Integer_Equality + | Iir_Predefined_Array_Equality + | Iir_Predefined_Access_Equality + | Iir_Predefined_Physical_Equality + | Iir_Predefined_Floating_Equality + | Iir_Predefined_Record_Equality + | Iir_Predefined_Bit_Match_Equality + | Iir_Predefined_Bit_Array_Match_Equality => + Eval_Right; + Result := Boolean_To_Lit (Is_Equal (Left, Right)); + when Iir_Predefined_Enum_Inequality + | Iir_Predefined_Integer_Inequality + | Iir_Predefined_Array_Inequality + | Iir_Predefined_Access_Inequality + | Iir_Predefined_Physical_Inequality + | Iir_Predefined_Floating_Inequality + | Iir_Predefined_Record_Inequality + | Iir_Predefined_Bit_Match_Inequality + | Iir_Predefined_Bit_Array_Match_Inequality => + Eval_Right; + Result := Boolean_To_Lit (not Is_Equal (Left, Right)); + when Iir_Predefined_Integer_Less + | Iir_Predefined_Physical_Less + | Iir_Predefined_Enum_Less => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) < Equal); + when Iir_Predefined_Integer_Greater + | Iir_Predefined_Physical_Greater + | Iir_Predefined_Enum_Greater => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) > Equal); + when Iir_Predefined_Integer_Less_Equal + | Iir_Predefined_Physical_Less_Equal + | Iir_Predefined_Enum_Less_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); + when Iir_Predefined_Integer_Greater_Equal + | Iir_Predefined_Physical_Greater_Equal + | Iir_Predefined_Enum_Greater_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); + + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Physical_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Enum_Maximum + | Iir_Predefined_Physical_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + + when Iir_Predefined_Integer_Plus + | Iir_Predefined_Physical_Plus => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 + Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Minus + | Iir_Predefined_Physical_Minus => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 - Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Mul => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 * Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Mod => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 mod Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Rem => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 rem Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Div => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 / Right.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Absolute + | Iir_Predefined_Physical_Absolute => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (abs Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Negation + | Iir_Predefined_Physical_Negation => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (-Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Physical_Identity => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Exp => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 < 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 ** Natural (Right.I64)); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Minimum => + Eval_Right; + Result := Create_I64_Value (Ghdl_I64'Min (Left.I64, Right.I64)); + when Iir_Predefined_Integer_Maximum => + Eval_Right; + Result := Create_I64_Value (Ghdl_I64'Max (Left.I64, Right.I64)); + + when Iir_Predefined_Floating_Mul => + Eval_Right; + Result := Create_F64_Value (Left.F64 * Right.F64); + when Iir_Predefined_Floating_Div => + Eval_Right; + Result := Create_F64_Value (Left.F64 / Right.F64); + when Iir_Predefined_Floating_Minus => + Eval_Right; + Result := Create_F64_Value (Left.F64 - Right.F64); + when Iir_Predefined_Floating_Plus => + Eval_Right; + Result := Create_F64_Value (Left.F64 + Right.F64); + when Iir_Predefined_Floating_Exp => + Eval_Right; + Result := Create_F64_Value (Left.F64 ** Integer (Right.I64)); + when Iir_Predefined_Floating_Identity => + Result := Create_F64_Value (Operand.F64); + when Iir_Predefined_Floating_Negation => + Result := Create_F64_Value (-Operand.F64); + when Iir_Predefined_Floating_Absolute => + Result := Create_F64_Value (abs (Operand.F64)); + when Iir_Predefined_Floating_Less => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 < Right.F64); + when Iir_Predefined_Floating_Less_Equal => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 <= Right.F64); + when Iir_Predefined_Floating_Greater => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 > Right.F64); + when Iir_Predefined_Floating_Greater_Equal => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 >= Right.F64); + + when Iir_Predefined_Floating_Minimum => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64'Min (Left.F64, Right.F64)); + when Iir_Predefined_Floating_Maximum => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64'Max (Left.F64, Right.F64)); + + when Iir_Predefined_Integer_Physical_Mul => + Eval_Right; + Result := Create_I64_Value (Left.I64 * Right.I64); + when Iir_Predefined_Physical_Integer_Mul => + Eval_Right; + Result := Create_I64_Value (Left.I64 * Right.I64); + when Iir_Predefined_Physical_Physical_Div => + Eval_Right; + Result := Create_I64_Value (Left.I64 / Right.I64); + when Iir_Predefined_Physical_Integer_Div => + Eval_Right; + Result := Create_I64_Value (Left.I64 / Right.I64); + when Iir_Predefined_Real_Physical_Mul => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Left.F64 * Ghdl_F64 (Right.I64))); + when Iir_Predefined_Physical_Real_Mul => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Ghdl_F64 (Left.I64) * Right.F64)); + when Iir_Predefined_Physical_Real_Div => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Ghdl_F64 (Left.I64) / Right.F64)); + + when Iir_Predefined_Universal_I_R_Mul => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64 (Left.I64) * Right.F64); + when Iir_Predefined_Universal_R_I_Mul => + Eval_Right; + Result := Create_F64_Value (Left.F64 * Ghdl_F64 (Right.I64)); + + when Iir_Predefined_TF_Array_And => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Nand => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1); + end loop; + when Iir_Predefined_TF_Array_Or => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Nor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1); + end loop; + when Iir_Predefined_TF_Array_Xor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Xnor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1); + end loop; + + when Iir_Predefined_TF_Array_Element_And => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_And => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Or => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_Or => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Xor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_Xor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Nand => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Nand => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Element_Nor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Nor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Element_Xnor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Xnor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Not => + -- Need to copy as the result is modified. + Result := Unshare (Operand, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := not Result.Val_Array.V (I).B1; + end loop; + + when Iir_Predefined_TF_Reduction_And => + Result := Create_B1_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Nand => + Result := Create_B1_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + when Iir_Predefined_TF_Reduction_Or => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Nor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + when Iir_Predefined_TF_Reduction_Xor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Xnor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B1 = True); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B1 = False); + + when Iir_Predefined_Array_Greater => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) = Greater); + + when Iir_Predefined_Array_Greater_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); + + when Iir_Predefined_Array_Less => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) = Less); + + when Iir_Predefined_Array_Less_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); + + when Iir_Predefined_Array_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Array_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + + when Iir_Predefined_Vector_Maximum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_Low_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Greater then + Result := V; + end if; + end loop; + end; + when Iir_Predefined_Vector_Minimum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_High_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Less then + Result := V; + end if; + end loop; + end; + + when Iir_Predefined_Endfile => + Result := Boolean_To_Lit (File_Operation.Endfile (Left, Null_Iir)); + + when Iir_Predefined_Now_Function => + Result := Create_I64_Value (Ghdl_I64 (Grt.Types.Current_Time)); + + when Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Physical_To_String => + Result := String_To_Iir_Value + (Execute_Image_Attribute (Left, Get_Type (Left_Param))); + + when Iir_Predefined_Enum_To_String => + declare + use Name_Table; + Base_Type : constant Iir := + Get_Base_Type (Get_Type (Left_Param)); + Lits : constant Iir_Flist := + Get_Enumeration_Literal_List (Base_Type); + Pos : constant Natural := Get_Enum_Pos (Left); + Id : Name_Id; + begin + if Base_Type = Std_Package.Character_Type_Definition then + Result := String_To_Iir_Value ((1 => Character'Val (Pos))); + else + Id := Get_Identifier (Get_Nth_Element (Lits, Pos)); + if Is_Character (Id) then + Result := String_To_Iir_Value ((1 => Get_Character (Id))); + else + Image (Id); + if Nam_Buffer (1) = '\' then + -- Reformat extended identifiers for to_image. + pragma Assert (Nam_Buffer (Nam_Length) = '\'); + declare + Npos : Natural; + K : Natural; + C : Character; + begin + Npos := 1; + K := 2; + while K < Nam_Length loop + C := Nam_Buffer (K); + Nam_Buffer (Npos) := C; + Npos := Npos + 1; + if C = '\' then + K := K + 2; + else + K := K + 1; + end if; + end loop; + Nam_Length := Npos - 1; + end; + end if; + Result := + String_To_Iir_Value (Nam_Buffer (1 .. Nam_Length)); + end if; + end if; + end; + + when Iir_Predefined_Array_Char_To_String => + declare + Lits : constant Iir_Flist := + Get_Enumeration_Literal_List + (Get_Base_Type + (Get_Element_Subtype (Get_Type (Left_Param)))); + Str : String (1 .. Natural (Left.Bounds.D (1).Length)); + Pos : Natural; + begin + for I in Left.Val_Array.V'Range loop + Pos := Get_Enum_Pos (Left.Val_Array.V (I)); + Str (Positive (I)) := Name_Table.Get_Character + (Get_Identifier (Get_Nth_Element (Lits, Pos))); + end loop; + Result := String_To_Iir_Value (Str); + end; + + when Iir_Predefined_Bit_Vector_To_Hstring => + return Execute_Bit_Vector_To_String (Left, 4); + + when Iir_Predefined_Bit_Vector_To_Ostring => + return Execute_Bit_Vector_To_String (Left, 3); + + when Iir_Predefined_Real_To_String_Digits => + Eval_Right; + declare + Str : Grt.Vstrings.String_Real_Format; + Last : Natural; + begin + Grt.Vstrings.To_String + (Str, Last, Left.F64, Ghdl_I32 (Right.I64)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Real_To_String_Format => + Eval_Right; + declare + Format : String (1 .. Natural (Right.Val_Array.Len) + 1); + Str : Grt.Vstrings.String_Real_Format; + Last : Natural; + begin + for I in Right.Val_Array.V'Range loop + Format (Positive (I)) := + Character'Val (Right.Val_Array.V (I).E8); + end loop; + Format (Format'Last) := ASCII.NUL; + Grt.Vstrings.To_String + (Str, Last, Left.F64, To_Ghdl_C_String (Format'Address)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Time_To_String_Unit => + Eval_Right; + declare + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Unit : Iir; + begin + Unit := Get_Unit_Chain (Std_Package.Time_Type_Definition); + while Unit /= Null_Iir loop + exit when Evaluation.Get_Physical_Value (Unit) + = Iir_Int64 (Right.I64); + Unit := Get_Chain (Unit); + end loop; + if Unit = Null_Iir then + Error_Msg_Exec + ("to_string for time called with wrong unit", Expr); + end if; + Grt.Vstrings.To_String (Str, First, Left.I64, Right.I64); + Result := String_To_Iir_Value + (Str (First .. Str'Last) & ' ' + & Name_Table.Image (Get_Identifier (Unit))); + end; + + when Iir_Predefined_Std_Ulogic_Match_Equality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E8_Value + (Std_Ulogic'Pos + (Match_Eq_Table (Std_Ulogic'Val (Left.E8), + Std_Ulogic'Val (Right.E8)))); + end; + when Iir_Predefined_Std_Ulogic_Match_Inequality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E8_Value + (Std_Ulogic'Pos + (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E8), + Std_Ulogic'Val (Right.E8))))); + end; + when Iir_Predefined_Std_Ulogic_Match_Ordering_Functions => + Eval_Right; + declare + use Grt.Std_Logic_1164; + L : constant Std_Ulogic := Std_Ulogic'Val (Left.E8); + R : constant Std_Ulogic := Std_Ulogic'Val (Right.E8); + Res : Std_Ulogic; + begin + Check_Std_Ulogic_Dc (Expr, L); + Check_Std_Ulogic_Dc (Expr, R); + case Iir_Predefined_Std_Ulogic_Match_Ordering_Functions (Func) + is + when Iir_Predefined_Std_Ulogic_Match_Less => + Res := Match_Lt_Table (L, R); + when Iir_Predefined_Std_Ulogic_Match_Less_Equal => + Res := Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R)); + when Iir_Predefined_Std_Ulogic_Match_Greater => + Res := Not_Table (Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R))); + when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + Res := Not_Table (Match_Lt_Table (L, R)); + end case; + Result := Create_E8_Value (Std_Ulogic'Pos (Res)); + end; + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + Eval_Right; + if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then + Error_Msg_Constraint (Expr); + end if; + declare + use Grt.Std_Logic_1164; + Res : Std_Ulogic := '1'; + Le, Re : Std_Ulogic; + Has_Match_Err : Boolean; + begin + Has_Match_Err := False; + for I in Left.Val_Array.V'Range loop + Le := Std_Ulogic'Val (Left.Val_Array.V (I).E8); + Re := Std_Ulogic'Val (Right.Val_Array.V (I).E8); + if (Le = '-' or Re = '-') and then not Has_Match_Err then + Assert_Std_Ulogic_Dc (Expr); + Has_Match_Err := True; + end if; + Res := And_Table (Res, Match_Eq_Table (Le, Re)); + end loop; + if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then + Res := Not_Table (Res); + end if; + Result := Create_E8_Value (Std_Ulogic'Pos (Res)); + end; + + when others => + Error_Msg_Elab (Expr, "execute_implicit_function: unimplemented " & + Iir_Predefined_Functions'Image (Func)); + raise Internal_Error; + end case; + return Result; + exception + when Constraint_Error => + Error_Msg_Constraint (Expr); + end Execute_Implicit_Function; + + procedure Execute_Implicit_Procedure + (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) + is + Imp : constant Iir := Get_Implementation (Stmt); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Assoc: Iir; + Args: Iir_Value_Literal_Array (0 .. 3); + Inter_Chain : Iir; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + Assoc := Assoc_Chain; + for I in Iir_Index32 loop + exit when Assoc = Null_Iir; + Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + Inter_Chain := Get_Interface_Declaration_Chain (Imp); + case Get_Implicit_Definition (Imp) is + when Iir_Predefined_Deallocate => + if Args (0).Val_Access /= null then + Free_Heap_Value (Args (0)); + Args (0).Val_Access := null; + end if; + when Iir_Predefined_File_Open => + File_Operation.File_Open + (Args (0), Args (1), Args (2), Inter_Chain, Stmt); + when Iir_Predefined_File_Open_Status => + File_Operation.File_Open_Status + (Args (0), Args (1), Args (2), Args (3), + Get_Chain (Inter_Chain), Stmt); + when Iir_Predefined_Write => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.Write_Text (Args (0), Args (1)); + else + File_Operation.Write_Binary (Args (0), Args (1)); + end if; + when Iir_Predefined_Read_Length => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.Read_Length_Text + (Args (0), Args (1), Args (2)); + else + File_Operation.Read_Length_Binary + (Args (0), Args (1), Args (2)); + end if; + when Iir_Predefined_Read => + File_Operation.Read_Binary (Args (0), Args (1)); + when Iir_Predefined_Flush => + File_Operation.Flush (Args (0)); + when Iir_Predefined_File_Close => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.File_Close_Text (Args (0), Stmt); + else + File_Operation.File_Close_Binary (Args (0), Stmt); + end if; + when others => + Error_Kind ("execute_implicit_procedure", + Get_Implicit_Definition (Imp)); + end case; + Release (Expr_Mark, Expr_Pool); + end Execute_Implicit_Procedure; + + procedure Execute_Foreign_Procedure + (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) + is + Imp : constant Iir := Get_Implementation (Stmt); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Assoc: Iir; + Args: Iir_Value_Literal_Array (0 .. 3) := (others => null); + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + Assoc := Assoc_Chain; + for I in Args'Range loop + exit when Assoc = Null_Iir; + Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + case Get_Identifier (Imp) is + when Std_Names.Name_Untruncated_Text_Read => + File_Operation.Untruncated_Text_Read + (Args (0), Args (1), Args (2)); + when Std_Names.Name_Control_Simulation => + Grt.Lib.Ghdl_Control_Simulation + (Args (0).B1, Args (1).B1, Std_Integer (Args (2).I64)); + -- Do not return. + when Std_Names.Name_Textio_Write_Real => + File_Operation.Textio_Write_Real + (Args (0), Args (1), Args (2).F64, Std_Integer (Args (3).I64)); + when others => + Error_Msg_Exec ("unsupported foreign procedure call", Stmt); + end case; + Release (Expr_Mark, Expr_Pool); + end Execute_Foreign_Procedure; + + -- Compute the offset for INDEX into a range BOUNDS. + -- EXPR is only used in case of error. + function Get_Index_Offset + (Index: Iir_Value_Literal_Acc; + Bounds: Iir_Value_Literal_Acc; + Expr: Iir) + return Iir_Index32 + is + Left_Pos, Right_Pos: Iir_Value_Literal_Acc; + begin + Left_Pos := Bounds.Left; + Right_Pos := Bounds.Right; + if Index.Kind /= Left_Pos.Kind or else Index.Kind /= Right_Pos.Kind then + raise Internal_Error; + end if; + case Iir_Value_Discrete (Index.Kind) is + when Iir_Value_B1 => + case Bounds.Dir is + when Iir_To => + if Index.B1 >= Left_Pos.B1 and then + Index.B1 <= Right_Pos.B1 + then + -- to + return Ghdl_B1'Pos (Index.B1) - Ghdl_B1'Pos (Left_Pos.B1); + end if; + when Iir_Downto => + if Index.B1 <= Left_Pos.B1 and then + Index.B1 >= Right_Pos.B1 + then + -- downto + return Ghdl_B1'Pos (Left_Pos.B1) - Ghdl_B1'Pos (Index.B1); + end if; + end case; + when Iir_Value_E8 => + case Bounds.Dir is + when Iir_To => + if Index.E8 >= Left_Pos.E8 and then + Index.E8 <= Right_Pos.E8 + then + -- to + return Iir_Index32 (Index.E8 - Left_Pos.E8); + end if; + when Iir_Downto => + if Index.E8 <= Left_Pos.E8 and then + Index.E8 >= Right_Pos.E8 + then + -- downto + return Iir_Index32 (Left_Pos.E8 - Index.E8); + end if; + end case; + when Iir_Value_E32 => + case Bounds.Dir is + when Iir_To => + if Index.E32 >= Left_Pos.E32 and then + Index.E32 <= Right_Pos.E32 + then + -- to + return Iir_Index32 (Index.E32 - Left_Pos.E32); + end if; + when Iir_Downto => + if Index.E32 <= Left_Pos.E32 and then + Index.E32 >= Right_Pos.E32 + then + -- downto + return Iir_Index32 (Left_Pos.E32 - Index.E32); + end if; + end case; + when Iir_Value_I64 => + case Bounds.Dir is + when Iir_To => + if Index.I64 >= Left_Pos.I64 and then + Index.I64 <= Right_Pos.I64 + then + -- to + return Iir_Index32 (Index.I64 - Left_Pos.I64); + end if; + when Iir_Downto => + if Index.I64 <= Left_Pos.I64 and then + Index.I64 >= Right_Pos.I64 + then + -- downto + return Iir_Index32 (Left_Pos.I64 - Index.I64); + end if; + end case; + end case; + Error_Msg_Constraint (Expr); + return 0; + end Get_Index_Offset; + + -- Create an iir_value_literal of kind iir_value_array and of life LIFE. + -- Allocate the array of bounds, and fill it from A_TYPE. + -- Allocate the array of values. + function Create_Array_Bounds_From_Type + (Block : Block_Instance_Acc; + A_Type : Iir; + Create_Val_Array : Boolean) + return Iir_Value_Literal_Acc + is + -- Only for constrained subtypes. + pragma Assert (Get_Kind (A_Type) /= Iir_Kind_Array_Type_Definition); + + Index_List : constant Iir_Flist := Get_Index_Subtype_List (A_Type); + Res : Iir_Value_Literal_Acc; + Len : Iir_Index32; + Bound : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value + (Iir_Index32 (Get_Nbr_Elements (Index_List))); + Len := 1; + for I in 1 .. Res.Bounds.Nbr_Dims loop + Bound := Execute_Bounds + (Block, Get_Nth_Element (Index_List, Natural (I - 1))); + Len := Len * Bound.Length; + Res.Bounds.D (I) := Bound; + end loop; + if Create_Val_Array then + Create_Array_Data (Res, Len); + end if; + return Res; + end Create_Array_Bounds_From_Type; + + -- Return the steps (ie, offset in the array when index DIM is increased + -- by one) for array ARR and dimension DIM. + function Get_Step_For_Dim (Arr: Iir_Value_Literal_Acc; Dim : Natural) + return Iir_Index32 + is + Bounds : Value_Bounds_Array_Acc renames Arr.Bounds; + Res : Iir_Index32; + begin + Res := 1; + for I in Iir_Index32 (Dim + 1) .. Bounds.Nbr_Dims loop + Res := Res * Bounds.D (I).Length; + end loop; + return Res; + end Get_Step_For_Dim; + + -- Create a literal for a string or a bit_string + function String_To_Enumeration_Array_1 (Str: Iir; El_Type : Iir) + return Iir_Value_Literal_Acc + is + pragma Assert (Get_Kind (Str) = Iir_Kind_String_Literal8); + Id : constant String8_Id := Get_String8_Id (Str); + Len : constant Iir_Index32 := Iir_Index32 (Get_String_Length (Str)); + + El_Btype : constant Iir := Get_Base_Type (El_Type); + + Lit: Iir_Value_Literal_Acc; + El : Iir_Value_Literal_Acc; + Element_Mode : Iir_Value_Scalars; + + Pos : Nat8; + begin + Element_Mode := Get_Info (El_Btype).Scalar_Mode; + + Lit := Create_Array_Value (Len, 1); + + for I in Lit.Val_Array.V'Range loop + -- FIXME: use literal from type ?? + Pos := Str_Table.Element_String8 (Id, Pos32 (I)); + case Element_Mode is + when Iir_Value_B1 => + El := Create_B1_Value (Ghdl_B1'Val (Pos)); + when Iir_Value_E8 => + El := Create_E8_Value (Ghdl_E8'Val (Pos)); + when Iir_Value_E32 => + El := Create_E32_Value (Ghdl_E32'Val (Pos)); + when others => + raise Internal_Error; + end case; + Lit.Val_Array.V (I) := El; + end loop; + + return Lit; + end String_To_Enumeration_Array_1; + + -- Create a literal for a string or a bit_string + function String_To_Enumeration_Array (Block: Block_Instance_Acc; Str: Iir) + return Iir_Value_Literal_Acc + is + Array_Type: constant Iir := Get_Type (Str); + Index_Types : constant Iir_Flist := Get_Index_Subtype_List (Array_Type); + Res : Iir_Value_Literal_Acc; + begin + -- Array must be unidimensional. + pragma Assert (Get_Nbr_Elements (Index_Types) = 1); + + Res := String_To_Enumeration_Array_1 + (Str, Get_Element_Subtype (Array_Type)); + + -- When created from static evaluation, a string may still have an + -- unconstrained type. + if Get_Constraint_State (Array_Type) /= Fully_Constrained then + Res.Bounds.D (1) := + Create_Range_Value (Create_I64_Value (1), + Create_I64_Value (Ghdl_I64 (Res.Val_Array.Len)), + Iir_To, + Res.Val_Array.Len); + else + Res.Bounds.D (1) := + Execute_Bounds (Block, Get_Nth_Element (Index_Types, 0)); + end if; + + -- The range may not be statically constant. + if Res.Bounds.D (1).Length /= Res.Val_Array.Len then + Error_Msg_Constraint (Str); + end if; + + return Res; + end String_To_Enumeration_Array; + + -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. + -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. + -- EL_TYPE is the type of the array element. + procedure Fill_Array_Aggregate_1 + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc; + Orig : Iir_Index32; + Step : Iir_Index32; + Dim : Iir_Index32; + Nbr_Dim : Iir_Index32; + El_Type : Iir) + is + Value : Iir; + Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim); + + procedure Set_Elem (Pos : Iir_Index32) + is + Val : Iir_Value_Literal_Acc; + begin + if Dim = Nbr_Dim then + -- VALUE is an expression (which may be an aggregate, but not + -- a sub-aggregate. + Val := Execute_Expression_With_Type (Block, Value, El_Type); + -- LRM93 7.3.2.2 + -- For a multi-dimensional aggregate of dimension n, a check + -- is made that all (n-1)-dimensional subaggregates have the + -- same bounds. + -- GHDL: I have added an implicit array conversion, however + -- it may be useful to allow cases like this: + -- type str_array is array (natural range <>) + -- of string (10 downto 1); + -- constant floats : str_array := + -- ( "00000000.0", HT & "+1.5ABCDE"); + -- The subtype of the first sub-aggregate (0.0) is + -- determinated by the context, according to rule 9 and 4 + -- of LRM93 7.3.2.2 and therefore is string (10 downto 1), + -- while the subtype of the second sub-aggregate (HT & ...) + -- is determinated by rules 1 and 2 of LRM 7.2.4, and is + -- string (1 to 10). + -- Unless an implicit conversion is used, according to the + -- LRM, this should fail, but it makes no sens. + -- + -- FIXME: Add a warning, a flag ? + --Implicit_Array_Conversion (Block, Val, El_Type, Value); + --Check_Constraints (Block, Val, El_Type, Value); + Res.Val_Array.V (1 + Orig + Pos * Step) := Val; + else + case Get_Kind (Value) is + when Iir_Kind_Aggregate => + -- VALUE is a sub-aggregate. + Fill_Array_Aggregate_1 (Block, Value, Res, + Orig + Pos * Step, + Step / Res.Bounds.D (Dim + 1).Length, + Dim + 1, Nbr_Dim, El_Type); + when Iir_Kind_String_Literal8 => + pragma Assert (Dim + 1 = Nbr_Dim); + Val := String_To_Enumeration_Array_1 (Value, El_Type); + if Val.Val_Array.Len /= Res.Bounds.D (Nbr_Dim).Length then + Error_Msg_Constraint (Value); + end if; + for I in Val.Val_Array.V'Range loop + Res.Val_Array.V (Orig + Pos * Step + I) := + Val.Val_Array.V (I); + end loop; + when others => + Error_Kind ("fill_array_aggregate_1", Value); + end case; + end if; + end Set_Elem; + + procedure Set_Elem_By_Expr (Expr : Iir) + is + Expr_Pos: Iir_Value_Literal_Acc; + begin + Expr_Pos := Execute_Expression (Block, Expr); + Set_Elem (Get_Index_Offset (Expr_Pos, Bound, Expr)); + end Set_Elem_By_Expr; + + procedure Set_Elem_By_Range (Expr : Iir) + is + A_Range : Iir_Value_Literal_Acc; + High, Low : Iir_Value_Literal_Acc; + begin + A_Range := Execute_Bounds (Block, Expr); + if Is_Null_Range (A_Range) then + return; + end if; + if A_Range.Dir = Iir_To then + High := A_Range.Right; + Low := A_Range.Left; + else + High := A_Range.Left; + Low := A_Range.Right; + end if; + + -- Locally modified (incremented) + Low := Unshare (Low, Expr_Pool'Access); + + loop + Set_Elem (Get_Index_Offset (Low, Bound, Expr)); + exit when Is_Equal (Low, High); + Increment (Low); + end loop; + end Set_Elem_By_Range; + + Length : constant Iir_Index32 := Bound.Length; + Assoc : Iir; + Pos : Iir_Index32; + begin + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 0; + while Assoc /= Null_Iir loop + Value := Get_Associated_Expr (Assoc); + loop + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if Pos >= Length then + Error_Msg_Constraint (Assoc); + end if; + Set_Elem (Pos); + Pos := Pos + 1; + when Iir_Kind_Choice_By_Expression => + Set_Elem_By_Expr (Get_Choice_Expression (Assoc)); + when Iir_Kind_Choice_By_Range => + Set_Elem_By_Range (Get_Choice_Range (Assoc)); + when Iir_Kind_Choice_By_Others => + for J in 1 .. Length loop + if Res.Val_Array.V (Orig + J * Step) = null then + Set_Elem (J - 1); + end if; + end loop; + return; + when others => + raise Internal_Error; + end case; + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + exit when not Get_Same_Alternative_Flag (Assoc); + end loop; + end loop; + + -- Check each elements have been set. + -- FIXME: check directly with type. + for J in 1 .. Length loop + if Res.Val_Array.V (Orig + J * Step) = null then + Error_Msg_Constraint (Aggregate); + end if; + end loop; + end Fill_Array_Aggregate_1; + + -- Use expressions from (BLOCK, AGGREGATE) to fill RES. + procedure Fill_Array_Aggregate + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc) + is + Aggr_Type : constant Iir := Get_Type (Aggregate); + El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); + Index_List : constant Iir_Flist := Get_Index_Subtype_List (Aggr_Type); + Nbr_Dim : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Step : Iir_Index32; + begin + Step := Get_Step_For_Dim (Res, 1); + Fill_Array_Aggregate_1 + (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); + end Fill_Array_Aggregate; + + function Execute_Record_Aggregate (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); + + Res: Iir_Value_Literal_Acc; + Expr : Iir; + + procedure Set_Expr (Pos : Iir_Index32) is + El : constant Iir := Get_Nth_Element (List, Natural (Pos - 1)); + begin + Res.Val_Record.V (Pos) := + Execute_Expression_With_Type (Block, Expr, Get_Type (El)); + end Set_Expr; + + Pos : Iir_Index32; + Assoc: Iir; + N_Expr : Iir; + begin + Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); + + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 1; + loop + N_Expr := Get_Associated_Expr (Assoc); + if N_Expr /= Null_Iir then + Expr := N_Expr; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + Set_Expr (Pos); + Pos := Pos + 1; + when Iir_Kind_Choice_By_Name => + Set_Expr (1 + Get_Element_Position + (Get_Named_Entity (Get_Choice_Name (Assoc)))); + when Iir_Kind_Choice_By_Others => + for I in Res.Val_Record.V'Range loop + if Res.Val_Record.V (I) = null then + Set_Expr (I); + end if; + end loop; + when others => + Error_Kind ("execute_record_aggregate", Assoc); + end case; + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + end loop; + return Res; + end Execute_Record_Aggregate; + + function Execute_Aggregate (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc is + begin + case Get_Kind (Aggregate_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Bounds_From_Type + (Block, Aggregate_Type, True); + Fill_Array_Aggregate (Block, Aggregate, Res); + return Res; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Execute_Record_Aggregate + (Block, Aggregate, Aggregate_Type); + when others => + Error_Kind ("execute_aggregate", Aggregate_Type); + end case; + end Execute_Aggregate; + + function Execute_Simple_Aggregate (Block: Block_Instance_Acc; Aggr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + List : constant Iir_Flist := Get_Simple_Aggregate_List (Aggr); + begin + Res := Create_Array_Bounds_From_Type (Block, Get_Type (Aggr), True); + for I in Res.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Expression (Block, Get_Nth_Element (List, Natural (I - 1))); + end loop; + return Res; + end Execute_Simple_Aggregate; + + -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. + -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. + -- EL_TYPE is the type of the array element. + procedure Execute_Name_Array_Aggregate + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc; + Orig : Iir_Index32; + Step : Iir_Index32; + Dim : Iir_Index32; + Nbr_Dim : Iir_Index32; + El_Type : Iir) + is + Value : Iir; + Bound : Iir_Value_Literal_Acc; + + procedure Set_Elem (Pos : Iir_Index32) + is + Val : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + if Dim = Nbr_Dim then + -- VALUE is an expression (which may be an aggregate, but not + -- a sub-aggregate. + Execute_Name_With_Base (Block, Value, null, Val, Is_Sig); + Res.Val_Array.V (1 + Orig + Pos * Step) := Val; + else + -- VALUE is a sub-aggregate. + Execute_Name_Array_Aggregate + (Block, Value, Res, + Orig + Pos * Step, + Step / Res.Bounds.D (Dim + 1).Length, + Dim + 1, Nbr_Dim, El_Type); + end if; + end Set_Elem; + + Assoc : Iir; + Pos : Iir_Index32; + begin + Assoc := Get_Association_Choices_Chain (Aggregate); + Bound := Res.Bounds.D (Dim); + Pos := 0; + while Assoc /= Null_Iir loop + Value := Get_Associated_Expr (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + null; + when Iir_Kind_Choice_By_Expression => + declare + Expr_Pos: Iir_Value_Literal_Acc; + Val : constant Iir := Get_Expression (Assoc); + begin + Expr_Pos := Execute_Expression (Block, Val); + Pos := Get_Index_Offset (Expr_Pos, Bound, Val); + end; + when others => + raise Internal_Error; + end case; + Set_Elem (Pos); + Pos := Pos + 1; + Assoc := Get_Chain (Assoc); + end loop; + end Execute_Name_Array_Aggregate; + + function Execute_Record_Name_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); + Res: Iir_Value_Literal_Acc; + Expr : Iir; + Pos : Iir_Index32; + El_Pos : Iir_Index32; + Is_Sig : Boolean; + Assoc: Iir; + begin + Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 0; + loop + Expr := Get_Associated_Expr (Assoc); + if Expr = Null_Iir then + -- List of choices is not allowed. + raise Internal_Error; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + El_Pos := Pos; + Pos := Pos + 1; + when Iir_Kind_Choice_By_Name => + El_Pos := Get_Element_Position (Get_Name (Assoc)); + when Iir_Kind_Choice_By_Others => + raise Internal_Error; + when others => + Error_Kind ("execute_record_name_aggregate", Assoc); + end case; + Execute_Name_With_Base + (Block, Expr, null, Res.Val_Record.V (1 + El_Pos), Is_Sig); + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + end loop; + return Res; + end Execute_Record_Name_Aggregate; + + function Execute_Name_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + begin + case Get_Kind (Aggregate_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type); + Index_List : constant Iir_Flist := + Get_Index_Subtype_List (Aggregate_Type); + Nbr_Dim : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Res : Iir_Value_Literal_Acc; + Step : Iir_Index32; + begin + Res := Create_Array_Bounds_From_Type + (Block, Aggregate_Type, True); + Step := Get_Step_For_Dim (Res, 1); + Execute_Name_Array_Aggregate + (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); + return Res; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Execute_Record_Name_Aggregate + (Block, Aggregate, Aggregate_Type); + when others => + Error_Kind ("execute_name_aggregate", Aggregate_Type); + end case; + end Execute_Name_Aggregate; + + -- Return the indexes range for prefix of ATTR. + function Execute_Indexes (Block: Block_Instance_Acc; Attr : Iir) + return Iir_Value_Literal_Acc + is + Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Attr)); + Dim : constant Natural := + Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); + begin + case Get_Kind (Prefix) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + declare + Index : Iir; + begin + Index := Get_Nth_Element + (Get_Index_Subtype_List (Get_Type (Prefix)), Dim - 1); + return Execute_Bounds (Block, Index); + end; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + Error_Kind ("execute_indexes", Prefix); + when others => + declare + Orig : Iir_Value_Literal_Acc; + begin + Orig := Execute_Name (Block, Prefix, True); + return Orig.Bounds.D (Iir_Index32 (Dim)); + end; + end case; + end Execute_Indexes; + + function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) + return Iir_Value_Literal_Acc + is + Bound : Iir_Value_Literal_Acc; + begin + case Get_Kind (Prefix) is + when Iir_Kind_Range_Expression => + declare + Info : constant Sim_Info_Acc := Get_Info (Prefix); + begin + if Info = null then + Bound := Create_Range_Value + (Execute_Expression (Block, Get_Left_Limit (Prefix)), + Execute_Expression (Block, Get_Right_Limit (Prefix)), + Get_Direction (Prefix)); + elsif Info.Kind = Kind_Object then + Bound := Get_Instance_For_Slot + (Block, Prefix).Objects (Info.Slot); + else + raise Internal_Error; + end if; + end; + + when Iir_Kind_Subtype_Declaration => + return Execute_Bounds (Block, Get_Type (Prefix)); + + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + -- FIXME: move this block before and avoid recursion. + return Execute_Bounds (Block, Get_Range_Constraint (Prefix)); + + when Iir_Kind_Range_Array_Attribute => + Bound := Execute_Indexes (Block, Prefix); + when Iir_Kind_Reverse_Range_Array_Attribute => + Bound := Execute_Indexes (Block, Prefix); + case Bound.Dir is + when Iir_To => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_Downto, Bound.Length); + when Iir_Downto => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_To, Bound.Length); + end case; + + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Integer_Type_Definition => + return Execute_Bounds + (Block, + Get_Range_Constraint (Get_Type (Get_Type_Declarator (Prefix)))); + + when Iir_Kinds_Denoting_Name => + return Execute_Bounds (Block, Get_Named_Entity (Prefix)); + + when others => + -- Error_Kind ("execute_bounds", Get_Kind (Prefix)); + declare + Prefix_Val: Iir_Value_Literal_Acc; + begin + Prefix_Val := Execute_Expression (Block, Prefix); + Bound := Prefix_Val.Bounds.D (1); + end; + end case; + if not Bound.Dir'Valid then + raise Internal_Error; + end if; + return Bound; + end Execute_Bounds; + + -- Perform type conversion as desribed in LRM93 7.3.5 + function Execute_Type_Conversion (Block: Block_Instance_Acc; + Val : Iir_Value_Literal_Acc; + Target_Type : Iir; + Loc : Iir) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + Res := Val; + case Get_Kind (Target_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + case Iir_Value_Numerics (Res.Kind) is + when Iir_Value_I64 => + null; + when Iir_Value_F64 => + if Res.F64 > Ghdl_F64 (Iir_Int64'Last) or + Res.F64 < Ghdl_F64 (Iir_Int64'First) + then + Error_Msg_Constraint (Loc); + end if; + Res := Create_I64_Value (Ghdl_I64 (Res.F64)); + end case; + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + case Iir_Value_Numerics (Res.Kind) is + when Iir_Value_F64 => + null; + when Iir_Value_I64 => + Res := Create_F64_Value (Ghdl_F64 (Res.I64)); + end case; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + -- Must be same type. + null; + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + -- Same type. + null; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + -- Same type. + null; + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + -- LRM93 7.3.5 + -- if the type mark denotes an unconstrained array type and the + -- operand is not a null array, then for each index position, the + -- bounds of the result are obtained by converting the bounds of + -- the operand to the corresponding index type of the target type. + -- + -- LRM93 7.3.5 + -- If the type mark denotes a constrained array subtype, then the + -- bounds of the result are those imposed by the type mark. + if Get_Constraint_State (Target_Type) = Fully_Constrained then + Implicit_Array_Conversion (Block, Res, Target_Type, Loc); + else + declare + Idx_List : constant Iir_Flist := + Get_Index_Subtype_List (Target_Type); + Idx_Type : Iir; + begin + Res := Create_Array_Value (Val.Bounds.Nbr_Dims); + Res.Val_Array := Val.Val_Array; + for I in Val.Bounds.D'Range loop + Idx_Type := Get_Index_Type (Idx_List, Natural (I - 1)); + Res.Bounds.D (I) := Create_Range_Value + (Left => Execute_Type_Conversion + (Block, Val.Bounds.D (I).Left, Idx_Type, Loc), + Right => Execute_Type_Conversion + (Block, Val.Bounds.D (I).Right, Idx_Type, Loc), + Dir => Val.Bounds.D (I).Dir, + Length => Val.Bounds.D (I).Length); + end loop; + end; + end if; + when others => + Error_Kind ("execute_type_conversion", Target_Type); + end case; + Check_Constraints (Block, Res, Target_Type, Loc); + return Res; + end Execute_Type_Conversion; + + -- Decrement VAL. + -- May raise a constraint error using EXPR. + function Execute_Dec (Val : Iir_Value_Literal_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Iir_Value_Discrete (Val.Kind) is + when Iir_Value_B1 => + if Val.B1 = False then + Error_Msg_Constraint (Expr); + end if; + Res := Create_B1_Value (False); + when Iir_Value_E8 => + if Val.E8 = 0 then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E8_Value (Val.E8 - 1); + when Iir_Value_E32 => + if Val.E32 = 0 then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E32_Value (Val.E32 - 1); + when Iir_Value_I64 => + if Val.I64 = Ghdl_I64'First then + Error_Msg_Constraint (Expr); + end if; + Res := Create_I64_Value (Val.I64 - 1); + end case; + return Res; + end Execute_Dec; + + -- Increment VAL. + -- May raise a constraint error using EXPR. + function Execute_Inc (Val : Iir_Value_Literal_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Iir_Value_Discrete (Val.Kind) is + when Iir_Value_B1 => + if Val.B1 = True then + Error_Msg_Constraint (Expr); + end if; + Res := Create_B1_Value (True); + when Iir_Value_E32 => + if Val.E32 = Ghdl_E32'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E32_Value (Val.E32 + 1); + when Iir_Value_E8 => + if Val.E8 = Ghdl_E8'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E8_Value (Val.E8 + 1); + when Iir_Value_I64 => + if Val.I64 = Ghdl_I64'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_I64_Value (Val.I64 + 1); + end case; + return Res; + end Execute_Inc; + + function Execute_Expression_With_Type + (Block: Block_Instance_Acc; + Expr: Iir; + Expr_Type : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + if Get_Kind (Expr) = Iir_Kind_Aggregate + and then not Is_Fully_Constrained_Type (Get_Type (Expr)) + then + return Execute_Aggregate (Block, Expr, Expr_Type); + else + Res := Execute_Expression (Block, Expr); + Implicit_Array_Conversion (Block, Res, Expr_Type, Expr); + Check_Constraints (Block, Res, Expr_Type, Expr); + return Res; + end if; + end Execute_Expression_With_Type; + + function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Base : constant Iir := Get_Object_Prefix (Expr, False); + Info : constant Sim_Info_Acc := Get_Info (Base); + Bblk : Block_Instance_Acc; + Base_Val : Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + if Get_Kind (Base) = Iir_Kind_Object_Alias_Declaration then + Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); + Base_Val := Execute_Signal_Init_Value (Bblk, Get_Name (Base)); + else + Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); + Base_Val := Bblk.Objects (Info.Slot + 1); + end if; + Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig); + pragma Assert (Is_Sig); + return Res; + end Execute_Signal_Init_Value; + + -- Indexed element will be at Pfx.Val_Array.V (Pos + 1) + procedure Execute_Indexed_Name (Block: Block_Instance_Acc; + Expr: Iir; + Pfx : Iir_Value_Literal_Acc; + Pos : out Iir_Index32) + is + pragma Assert (Get_Kind (Expr) = Iir_Kind_Indexed_Name); + Index_List : constant Iir_Flist := Get_Index_List (Expr); + Nbr_Dimensions : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Index: Iir; + Value: Iir_Value_Literal_Acc; + Off : Iir_Index32; + begin + for I in 1 .. Nbr_Dimensions loop + Index := Get_Nth_Element (Index_List, Natural (I - 1)); + Value := Execute_Expression (Block, Index); + Off := Get_Index_Offset (Value, Pfx.Bounds.D (I), Expr); + if I = 1 then + Pos := Off; + else + Pos := Pos * Pfx.Bounds.D (I).Length + Off; + end if; + end loop; + end Execute_Indexed_Name; + + -- Indexed element will be at Pfx.Val_Array.V (Pos) + procedure Execute_Slice_Name (Prefix_Array: Iir_Value_Literal_Acc; + Srange : Iir_Value_Literal_Acc; + Low : out Iir_Index32; + High : out Iir_Index32; + Loc : Iir) + is + Index_Order : Order; + -- Lower and upper bounds of the slice. + begin + pragma Assert (Prefix_Array /= null); + + -- LRM93 6.5 + -- It is an error if the direction of the discrete range is not + -- the same as that of the index range of the array denoted by + -- the prefix of the slice name. + if Srange.Dir /= Prefix_Array.Bounds.D (1).Dir then + Error_Msg_Exec ("slice direction mismatch", Loc); + end if; + + -- LRM93 6.5 + -- It is an error if either of the bounds of the + -- discrete range does not belong to the index range of the + -- prefixing array, unless the slice is a null slice. + Index_Order := Compare_Value (Srange.Left, Srange.Right); + if (Srange.Dir = Iir_To and Index_Order = Greater) + or (Srange.Dir = Iir_Downto and Index_Order = Less) + then + -- Null slice. + Low := 1; + High := 0; + else + Low := Get_Index_Offset + (Srange.Left, Prefix_Array.Bounds.D (1), Loc); + High := Get_Index_Offset + (Srange.Right, Prefix_Array.Bounds.D (1), Loc); + end if; + end Execute_Slice_Name; + + procedure Execute_Name_With_Base (Block: Block_Instance_Acc; + Expr: Iir; + Base : Iir_Value_Literal_Acc; + Res : out Iir_Value_Literal_Acc; + Is_Sig : out Boolean) + is + Slot_Block: Block_Instance_Acc; + begin + -- Default value + Is_Sig := False; + + case Get_Kind (Expr) is + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + Is_Sig := True; + if Base /= null then + Res := Base; + else + Slot_Block := Get_Instance_For_Slot (Block, Expr); + Res := Slot_Block.Objects (Get_Info (Expr).Slot); + end if; + + when Iir_Kind_Object_Alias_Declaration => + -- FIXME: add a flag ? + Is_Sig := Is_Signal_Object (Expr); + if Base /= null then + Res := Base; + else + Slot_Block := Get_Instance_For_Slot (Block, Expr); + Res := Slot_Block.Objects (Get_Info (Expr).Slot); + end if; + + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kinds_Quantity_Declaration => + if Base /= null then + Res := Base; + else + declare + Info : constant Sim_Info_Acc := Get_Info (Expr); + begin + Slot_Block := Get_Instance_By_Scope (Block, Info.Obj_Scope); + Res := Slot_Block.Objects (Info.Slot); + end; + end if; + + when Iir_Kind_Indexed_Name => + declare + Pfx : Iir_Value_Literal_Acc; + Pos : Iir_Index32; + begin + Execute_Name_With_Base + (Block, Get_Prefix (Expr), Base, Pfx, Is_Sig); + Execute_Indexed_Name (Block, Expr, Pfx, Pos); + Res := Pfx.Val_Array.V (Pos + 1); + end; + + when Iir_Kind_Slice_Name => + declare + Prefix_Array: Iir_Value_Literal_Acc; + Srange : Iir_Value_Literal_Acc; + Low, High: Iir_Index32; + begin + Execute_Name_With_Base + (Block, Get_Prefix (Expr), Base, Prefix_Array, Is_Sig); + + Srange := Execute_Bounds (Block, Get_Suffix (Expr)); + Execute_Slice_Name (Prefix_Array, Srange, Low, High, Expr); + + Res := Create_Array_Value (High - Low + 1, 1); + Res.Bounds.D (1) := Srange; + for I in Low .. High loop + Res.Val_Array.V (1 + I - Low) := + Prefix_Array.Val_Array.V (1 + I); + end loop; + end; + + when Iir_Kind_Selected_Element => + declare + Prefix: Iir_Value_Literal_Acc; + Pos: Iir_Index32; + begin + Execute_Name_With_Base + (Block, Get_Prefix (Expr), Base, Prefix, Is_Sig); + Pos := Get_Element_Position (Get_Selected_Element (Expr)); + Res := Prefix.Val_Record.V (Pos + 1); + end; + + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + declare + Prefix: Iir_Value_Literal_Acc; + begin + Prefix := Execute_Name (Block, Get_Prefix (Expr)); + Res := Prefix.Val_Access; + if Res = null then + Error_Msg_Exec ("deferencing null access", Expr); + end if; + end; + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name => + Execute_Name_With_Base + (Block, Get_Named_Entity (Expr), Base, Res, Is_Sig); + + when Iir_Kind_Function_Call => + -- A prefix can be an expression + if Base /= null then + raise Internal_Error; + end if; + Res := Execute_Expression (Block, Expr); + + when Iir_Kind_Aggregate => + Res := Execute_Name_Aggregate (Block, Expr, Get_Type (Expr)); + -- FIXME: is_sig ? + + when Iir_Kind_Image_Attribute => + Res := Execute_Image_Attribute (Block, Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + Res := Execute_Path_Instance_Name_Attribute (Block, Expr); + + when others => + Error_Kind ("execute_name_with_base", Expr); + end case; + end Execute_Name_With_Base; + + function Execute_Name (Block: Block_Instance_Acc; + Expr: Iir; + Ref : Boolean := False) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base (Block, Expr, null, Res, Is_Sig); + if not Is_Sig or else Ref then + return Res; + else + return Execute_Signal_Value (Res); + end if; + end Execute_Name; + + function Execute_Value_Attribute (Block: Block_Instance_Acc; + Str_Val : Iir_Value_Literal_Acc; + Expr: Iir) + return Iir_Value_Literal_Acc + is + use Grt_Interface; + use Name_Table; + pragma Unreferenced (Block); + + Expr_Type : constant Iir := Get_Type (Expr); + Res : Iir_Value_Literal_Acc; + + Str_Bnd : aliased Std_String_Bound := Build_Bound (Str_Val); + Str_Str : aliased Std_String_Uncons (1 .. Str_Bnd.Dim_1.Length); + Str : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), + To_Std_String_Boundp (Str_Bnd'Address)); + begin + Set_Std_String_From_Iir_Value (Str, Str_Val); + case Get_Kind (Expr_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + Res := Create_I64_Value + (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access)); + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + Res := Create_F64_Value + (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access)); + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Is_Real : Boolean; + Lit_Pos : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + Unit_Pos : Ghdl_Index_Type; + Unit_Len : Ghdl_Index_Type; + Mult : Ghdl_I64; + Unit : Iir; + Unit_Id : Name_Id; + begin + Grt.Values.Ghdl_Value_Physical_Split + (Str'Unrestricted_Access, + Is_Real, Lit_Pos, Lit_End, Unit_Pos); + + -- Find unit. + Unit_Len := 0; + Unit_Pos := Unit_Pos + 1; -- From 0 based to 1 based + for I in Unit_Pos .. Str_Bnd.Dim_1.Length loop + exit when Grt.Strings.Is_Whitespace (Str_Str (I)); + Unit_Len := Unit_Len + 1; + Str_Str (I) := Grt.Strings.To_Lower (Str_Str (I)); + end loop; + + Unit := Get_Primary_Unit (Expr_Type); + while Unit /= Null_Iir loop + Unit_Id := Get_Identifier (Unit); + exit when Get_Name_Length (Unit_Id) = Natural (Unit_Len) + and then Image (Unit_Id) = + String (Str_Str (Unit_Pos .. Unit_Pos + Unit_Len - 1)); + Unit := Get_Chain (Unit); + end loop; + + if Unit = Null_Iir then + Error_Msg_Exec ("incorrect unit name", Expr); + end if; + Mult := Ghdl_I64 (Get_Value (Get_Physical_Unit (Unit))); + + Str_Bnd.Dim_1.Length := Lit_End; + if Is_Real then + Res := Create_I64_Value + (Ghdl_I64 + (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access) + * Ghdl_F64 (Mult))); + else + Res := Create_I64_Value + (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access) + * Mult); + end if; + end; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + declare + Enums : constant Iir_Flist := + Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); + Lit_Start : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + Enum : Iir; + Lit_Id : Name_Id; + Enum_Id : Name_Id; + begin + -- Remove leading and trailing blanks + for I in Str_Str'Range loop + if not Grt.Strings.Is_Whitespace (Str_Str (I)) then + Lit_Start := I; + exit; + end if; + end loop; + for I in reverse Lit_Start .. Str_Str'Last loop + if not Grt.Strings.Is_Whitespace (Str_Str (I)) then + Lit_End := I; + exit; + end if; + end loop; + + if Str_Str (Lit_Start) = ''' + and then Str_Str (Lit_End) = ''' + and then Lit_End = Lit_Start + 2 + then + -- Enumeration literal. + Lit_Id := Get_Identifier (Str_Str (Lit_Start + 1)); + + for I in Natural loop + Enum := Get_Nth_Element (Enums, I); + exit when Enum = Null_Iir; + exit when Get_Identifier (Enum) = Lit_Id; + end loop; + else + -- Literal identifier. + -- Convert to lower case. + for I in Lit_Start .. Lit_End loop + Str_Str (I) := Grt.Strings.To_Lower (Str_Str (I)); + end loop; + + for I in Natural loop + Enum := Get_Nth_Element (Enums, I); + exit when Enum = Null_Iir; + Enum_Id := Get_Identifier (Enum); + exit when (Get_Name_Length (Enum_Id) = + Natural (Lit_End - Lit_Start + 1)) + and then (Image (Enum_Id) = + String (Str_Str (Lit_Start .. Lit_End))); + end loop; + end if; + + if Enum = Null_Iir then + Error_Msg_Exec + ("incorrect enumeration literal for 'value", Expr); + end if; + + return Create_Enum_Value + (Natural (Get_Enum_Pos (Enum)), Expr_Type); + end; + when others => + Error_Kind ("value_attribute", Expr_Type); + end case; + return Res; + end Execute_Value_Attribute; + + -- For 'Last_Event and 'Last_Active: convert the absolute last time to + -- a relative delay. + function To_Relative_Time (T : Ghdl_I64) return Iir_Value_Literal_Acc is + A : Ghdl_I64; + begin + if T = -Ghdl_I64'Last then + A := Ghdl_I64'Last; + else + A := Ghdl_I64 (Grt.Types.Current_Time) - T; + end if; + return Create_I64_Value (A); + end To_Relative_Time; + + -- Evaluate an expression. + function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Get_Kind (Expr) is + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Object_Alias_Declaration => + Res := Execute_Name (Block, Expr); + return Res; + + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + return Execute_Name (Block, Expr); + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name => + return Execute_Expression (Block, Get_Named_Entity (Expr)); + + when Iir_Kind_Aggregate => + return Execute_Aggregate (Block, Expr, Get_Type (Expr)); + when Iir_Kind_Simple_Aggregate => + return Execute_Simple_Aggregate (Block, Expr); + + when Iir_Kinds_Dyadic_Operator + | Iir_Kinds_Monadic_Operator => + declare + Imp : constant Iir := Get_Implementation (Expr); + begin + if Get_Implicit_Definition (Imp) in Iir_Predefined_Explicit then + return Execute_Function_Call (Block, Expr, Imp); + else + if Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator then + Res := Execute_Implicit_Function + (Block, Expr, Get_Left (Expr), Get_Right (Expr), + Get_Type (Expr)); + else + Res := Execute_Implicit_Function + (Block, Expr, Get_Operand (Expr), Null_Iir, + Get_Type (Expr)); + end if; + return Res; + end if; + end; + + when Iir_Kind_Function_Call => + declare + Imp : constant Iir := Get_Implementation (Expr); + Assoc : Iir; + Args : Iir_Array (0 .. 1); + begin + if Get_Implicit_Definition (Imp) in Iir_Predefined_Explicit then + return Execute_Function_Call (Block, Expr, Imp); + else + Assoc := Get_Parameter_Association_Chain (Expr); + if Assoc /= Null_Iir then + Args (0) := Get_Actual (Assoc); + Assoc := Get_Chain (Assoc); + else + Args (0) := Null_Iir; + end if; + if Assoc /= Null_Iir then + Args (1) := Get_Actual (Assoc); + else + Args (1) := Null_Iir; + end if; + return Execute_Implicit_Function + (Block, Expr, Args (0), Args (1), Get_Type (Expr)); + end if; + end; + + when Iir_Kind_Integer_Literal => + declare + Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); + Lit : constant Iir_Int64 := Get_Value (Expr); + begin + case Get_Info (Lit_Type).Scalar_Mode is + when Iir_Value_I64 => + return Create_I64_Value (Ghdl_I64 (Lit)); + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Floating_Point_Literal => + return Create_F64_Value (Ghdl_F64 (Get_Fp_Value (Expr))); + + when Iir_Kind_Enumeration_Literal => + declare + Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); + Lit : constant Iir_Int32 := Get_Enum_Pos (Expr); + begin + case Get_Info (Lit_Type).Scalar_Mode is + when Iir_Value_B1 => + return Create_B1_Value (Ghdl_B1'Val (Lit)); + when Iir_Value_E8 => + return Create_E8_Value (Ghdl_E8'Val (Lit)); + when Iir_Value_E32 => + return Create_E32_Value (Ghdl_E32 (Lit)); + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return Create_I64_Value + (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr))); + + when Iir_Kind_String_Literal8 => + return String_To_Enumeration_Array (Block, Expr); + + when Iir_Kind_Null_Literal => + return Null_Lit; + + when Iir_Kind_Overflow_Literal => + Error_Msg_Constraint (Expr); + return null; + + when Iir_Kind_Parenthesis_Expression => + return Execute_Expression (Block, Get_Expression (Expr)); + + when Iir_Kind_Type_Conversion => + return Execute_Type_Conversion + (Block, Execute_Expression (Block, Get_Expression (Expr)), + Get_Type (Expr), Expr); + + when Iir_Kind_Qualified_Expression => + Res := Execute_Expression_With_Type + (Block, Get_Expression (Expr), Get_Type (Get_Type_Mark (Expr))); + return Res; + + when Iir_Kind_Allocator_By_Expression => + Res := Execute_Expression (Block, Get_Expression (Expr)); + Res := Unshare_Heap (Res); + return Create_Access_Value (Res); + + when Iir_Kind_Allocator_By_Subtype => + Res := Create_Value_For_Type + (Block, + Get_Type_Of_Subtype_Indication (Get_Subtype_Indication (Expr)), + Init_Value_Default); + Res := Unshare_Heap (Res); + return Create_Access_Value (Res); + + when Iir_Kind_Left_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Left_Limit (Res); + + when Iir_Kind_Right_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Right_Limit (Res); + + when Iir_Kind_High_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_High_Limit (Res); + + when Iir_Kind_Low_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Low_Limit (Res); + + when Iir_Kind_High_Array_Attribute => + Res := Execute_Indexes (Block, Expr); + return Execute_High_Limit (Res); + + when Iir_Kind_Low_Array_Attribute => + Res := Execute_Indexes (Block, Expr); + return Execute_Low_Limit (Res); + + when Iir_Kind_Left_Array_Attribute => + Res := Execute_Indexes (Block, Expr); + return Execute_Left_Limit (Res); + + when Iir_Kind_Right_Array_Attribute => + Res := Execute_Indexes (Block, Expr); + return Execute_Right_Limit (Res); + + when Iir_Kind_Length_Array_Attribute => + Res := Execute_Indexes (Block, Expr); + return Execute_Length (Res); + + when Iir_Kind_Ascending_Array_Attribute => + Res := Execute_Indexes (Block, Expr); + return Boolean_To_Lit (Res.Dir = Iir_To); + + when Iir_Kind_Event_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Event_Attribute (Res)); + + when Iir_Kind_Active_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Active_Attribute (Res)); + + when Iir_Kind_Driving_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Driving_Attribute (Res)); + + when Iir_Kind_Last_Value_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Execute_Last_Value_Attribute (Res); + + when Iir_Kind_Driving_Value_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Execute_Driving_Value_Attribute (Res); + + when Iir_Kind_Last_Event_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return To_Relative_Time (Execute_Last_Event_Attribute (Res)); + + when Iir_Kind_Last_Active_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return To_Relative_Time (Execute_Last_Active_Attribute (Res)); + + when Iir_Kind_Val_Attribute => + declare + Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Base_Type : constant Iir := Get_Base_Type (Prefix_Type); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + case Iir_Value_Discrete (Mode) is + when Iir_Value_I64 => + null; + when Iir_Value_E8 => + Res := Create_E8_Value (Ghdl_E8 (Res.I64)); + when Iir_Value_E32 => + Res := Create_E32_Value (Ghdl_E32 (Res.I64)); + when Iir_Value_B1 => + Res := Create_B1_Value (Ghdl_B1'Val (Res.I64)); + end case; + Check_Constraints (Block, Res, Prefix_Type, Expr); + return Res; + end; + + when Iir_Kind_Pos_Attribute => + declare + N_Res: Iir_Value_Literal_Acc; + Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Base_Type : constant Iir := Get_Base_Type (Prefix_Type); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + case Iir_Value_Discrete (Mode) is + when Iir_Value_I64 => + null; + when Iir_Value_B1 => + N_Res := Create_I64_Value (Ghdl_B1'Pos (Res.B1)); + Res := N_Res; + when Iir_Value_E8 => + N_Res := Create_I64_Value (Ghdl_I64 (Res.E8)); + Res := N_Res; + when Iir_Value_E32 => + N_Res := Create_I64_Value (Ghdl_I64 (Res.E32)); + Res := N_Res; + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Succ_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Res := Execute_Inc (Res, Expr); + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + + when Iir_Kind_Pred_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Res := Execute_Dec (Res, Expr); + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + + when Iir_Kind_Leftof_Attribute => + declare + Bound : Iir_Value_Literal_Acc; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Bound := Execute_Bounds + (Block, Get_Type (Get_Prefix (Expr))); + case Bound.Dir is + when Iir_To => + Res := Execute_Dec (Res, Expr); + when Iir_Downto => + Res := Execute_Inc (Res, Expr); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Rightof_Attribute => + declare + Bound : Iir_Value_Literal_Acc; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Bound := Execute_Bounds + (Block, Get_Type (Get_Prefix (Expr))); + case Bound.Dir is + when Iir_Downto => + Res := Execute_Dec (Res, Expr); + when Iir_To => + Res := Execute_Inc (Res, Expr); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Image_Attribute => + return Execute_Image_Attribute (Block, Expr); + + when Iir_Kind_Value_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + return Execute_Value_Attribute (Block, Res, Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + return Execute_Path_Instance_Name_Attribute (Block, Expr); + + when others => + Error_Kind ("execute_expression", Expr); + end case; + end Execute_Expression; + + procedure Execute_Dyadic_Association + (Out_Block: Block_Instance_Acc; + In_Block: Block_Instance_Acc; + Expr : Iir; + Inter_Chain: Iir) + is + Inter: Iir; + Val: Iir_Value_Literal_Acc; + begin + Inter := Inter_Chain; + for I in 0 .. 1 loop + if I = 0 then + Val := Execute_Expression (Out_Block, Get_Left (Expr)); + else + Val := Execute_Expression (Out_Block, Get_Right (Expr)); + end if; + Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); + Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); + + Elaboration.Create_Object (In_Block, Inter); + In_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + Inter := Get_Chain (Inter); + end loop; + end Execute_Dyadic_Association; + + procedure Execute_Monadic_Association + (Out_Block: Block_Instance_Acc; + In_Block: Block_Instance_Acc; + Expr : Iir; + Inter: Iir) + is + Val: Iir_Value_Literal_Acc; + begin + Val := Execute_Expression (Out_Block, Get_Operand (Expr)); + Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); + Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); + + Elaboration.Create_Object (In_Block, Inter); + In_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + end Execute_Monadic_Association; + + -- Create a block instance for subprogram IMP. + function Create_Subprogram_Instance (Instance : Block_Instance_Acc; + Prot_Obj : Block_Instance_Acc; + Imp : Iir) + return Block_Instance_Acc + is + Func_Info : constant Sim_Info_Acc := Get_Info (Imp); + + subtype Block_Type is Block_Instance_Type (Func_Info.Nbr_Objects); + function To_Block_Instance_Acc is new + Ada.Unchecked_Conversion (System.Address, Block_Instance_Acc); + function Alloc_Block_Instance is new + Alloc_On_Pool_Addr (Block_Type); + + Up_Block: Block_Instance_Acc; + Up_Info : Sim_Info_Acc; + Res : Block_Instance_Acc; + + Origin : Iir; + Label : Iir; + begin + pragma Assert (Get_Kind (Imp) in Iir_Kinds_Subprogram_Declaration + or else Get_Kind (Imp) = Iir_Kind_Protected_Type_Body); + + if Prot_Obj /= null then + Up_Block := Prot_Obj; + Label := Imp; + else + Up_Info := Get_Info (Get_Parent (Imp)); + Up_Block := Get_Instance_By_Scope (Instance, Up_Info.Frame_Scope); + + Origin := Sem_Inst.Get_Origin (Imp); + if Origin /= Null_Iir then + -- Call to a subprogram of an instantiated package. + -- For a generic package, only the spec is instantiated, the body + -- is shared by all the instances. + + -- Execute code of the 'shared' body + Label := Origin; + + -- Get the real instance for package interface. + if Up_Info.Kind = Kind_Environment then + Up_Block := Environment_Table.Table + (Up_Block.Objects (Up_Info.Env_Slot).Environment); + end if; + else + Label := Imp; + end if; + end if; + + Res := To_Block_Instance_Acc + (Alloc_Block_Instance + (Instance_Pool, + Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects, + Id => No_Block_Instance_Id, + Block_Scope => Get_Info (Label).Frame_Scope, + Up_Block => Up_Block, + Label => Label, + Stmt => Null_Iir, + Parent => Instance, + Children => null, + Brother => null, + Ports_Map => Null_Iir, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + Actuals_Ref => null, + Result => null))); + return Res; + end Create_Subprogram_Instance; + + -- Destroy a dynamic block_instance. + procedure Execute_Subprogram_Call_Final (Instance : Block_Instance_Acc) + is + Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); + begin + Finalize_Declarative_Part + (Instance, Get_Declaration_Chain (Subprg_Body)); + end Execute_Subprogram_Call_Final; + + function Execute_Function_Body (Instance : Block_Instance_Acc) + return Iir_Value_Literal_Acc + is + Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); + Res : Iir_Value_Literal_Acc; + begin + Current_Process.Instance := Instance; + + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Subprg_Body)); + + -- execute statements + Instance.Stmt := Get_Sequential_Statement_Chain (Subprg_Body); + Execute_Sequential_Statements (Current_Process); + pragma Assert (Current_Process.Instance = Instance); + + if Instance.Result = null then + Error_Msg_Exec + ("function scope exited without a return statement", + Instance.Label); + end if; + + -- Free variables, slots... + -- Need to copy the return value, because it can contains values from + -- arguments. + Res := Instance.Result; + + Current_Process.Instance := Instance.Parent; + Execute_Subprogram_Call_Final (Instance); + + return Res; + end Execute_Function_Body; + + function Execute_Assoc_Function_Conversion + (Block : Block_Instance_Acc; Func : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Inter : Iir; + Instance : Block_Instance_Acc; + Res : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + Mark (Marker, Instance_Pool.all); + + -- Create an instance for this function. + Instance := Create_Subprogram_Instance (Block, null, Func); + + Inter := Get_Interface_Declaration_Chain (Func); + Elaboration.Create_Object (Instance, Inter); + -- FIXME: implicit conversion + Instance.Objects (Get_Info (Inter).Slot) := Val; + + Res := Execute_Function_Body (Instance); + Res := Unshare (Res, Expr_Pool'Access); + Release (Marker, Instance_Pool.all); + return Res; + end Execute_Assoc_Function_Conversion; + + function Execute_Assoc_Conversion + (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Ent : Iir; + begin + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + -- FIXME: shouldn't CONV always be a denoting_name ? + return Execute_Assoc_Function_Conversion + (Block, Get_Implementation (Conv), Val); + when Iir_Kind_Type_Conversion => + -- FIXME: shouldn't CONV always be a denoting_name ? + return Execute_Type_Conversion (Block, Val, Get_Type (Conv), Conv); + when Iir_Kinds_Denoting_Name + | Iir_Kind_Function_Declaration => + Ent := Strip_Denoting_Name (Conv); + if Get_Kind (Ent) = Iir_Kind_Function_Declaration then + return Execute_Assoc_Function_Conversion (Block, Ent, Val); + elsif Get_Kind (Ent) in Iir_Kinds_Type_Declaration then + return Execute_Type_Conversion + (Block, Val, Get_Type (Ent), Ent); + else + Error_Kind ("execute_assoc_conversion(1)", Ent); + end if; + when others => + Error_Kind ("execute_assoc_conversion(2)", Conv); + end case; + end Execute_Assoc_Conversion; + + procedure Associate_By_Reference (Block : Block_Instance_Acc; + Formal : Iir; + Formal_Base : Iir_Value_Literal_Acc; + Actual : Iir_Value_Literal_Acc) + is + Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Formal)); + Is_Sig : Boolean; + Pfx : Iir_Value_Literal_Acc; + Pos : Iir_Index32; + begin + if Get_Kind (Prefix) = Iir_Kind_Slice_Name then + -- That case is not handled correctly. + raise Program_Error; + end if; + Execute_Name_With_Base (Block, Prefix, Formal_Base, Pfx, Is_Sig); + + case Get_Kind (Formal) is + when Iir_Kind_Indexed_Name => + Execute_Indexed_Name (Block, Formal, Pfx, Pos); + Store (Pfx.Val_Array.V (Pos + 1), Actual); + when Iir_Kind_Slice_Name => + declare + Low, High : Iir_Index32; + Srange : Iir_Value_Literal_Acc; + begin + Srange := Execute_Bounds (Block, Get_Suffix (Formal)); + Execute_Slice_Name (Pfx, Srange, Low, High, Formal); + for I in 1 .. High - Low + 1 loop + Store (Pfx.Val_Array.V (Low + I), Actual.Val_Array.V (I)); + end loop; + end; + when Iir_Kind_Selected_Element => + Pos := Get_Element_Position (Get_Selected_Element (Formal)); + Store (Pfx.Val_Record.V (Pos + 1), Actual); + when others => + Error_Kind ("associate_by_reference", Formal); + end case; + end Associate_By_Reference; + + -- Establish correspondance for association list ASSOC_LIST from block + -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK. + procedure Execute_Association + (Out_Block : Block_Instance_Acc; + Subprg_Block : Block_Instance_Acc; + Inter_Chain : Iir; + Assoc_Chain : Iir) + is + Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain); + Assoc: Iir; + Assoc_Inter : Iir; + Actual : Iir; + Inter: Iir; + Formal : Iir; + Conv : Iir; + Val: Iir_Value_Literal_Acc; + Assoc_Idx : Iir_Index32; + Last_Individual : Iir_Value_Literal_Acc; + Mode : Iir_Mode; + Marker : Mark_Type; + begin + Subprg_Block.Actuals_Ref := null; + Mark (Marker, Expr_Pool); + + Assoc := Assoc_Chain; + Assoc_Inter := Inter_Chain; + Assoc_Idx := 1; + while Assoc /= Null_Iir loop + Inter := Get_Association_Interface (Assoc, Assoc_Inter); + Formal := Get_Association_Formal (Assoc, Inter); + + -- Extract the actual value. + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + -- Not allowed in individual association. + pragma Assert (Formal = Inter); + pragma Assert (Get_Whole_Association_Flag (Assoc)); + Actual := Get_Default_Value (Inter); + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + when Iir_Kind_Association_Element_By_Individual => + -- Directly create the whole value on the instance pool, as its + -- life is longer than the statement. + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + Last_Individual := Create_Value_For_Type + (Out_Block, Get_Actual_Type (Assoc), Init_Value_Signal); + else + Last_Individual := Create_Value_For_Type + (Out_Block, Get_Actual_Type (Assoc), Init_Value_Any); + end if; + Last_Individual := + Unshare (Last_Individual, Instance_Pool); + Elaboration.Create_Object (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual; + goto Continue; + when others => + Error_Kind ("execute_association(1)", Assoc); + end case; + + -- Compute actual value. + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + Val := Execute_Expression (Out_Block, Actual); + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + Check_Constraints (Subprg_Block, Val, Get_Type (Formal), Assoc); + when Iir_Kind_Interface_Signal_Declaration => + Val := Execute_Name (Out_Block, Actual, True); + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + when Iir_Kind_Interface_Variable_Declaration => + Mode := Get_Mode (Inter); + if Mode = Iir_In_Mode then + -- FIXME: Ref ? + Val := Execute_Expression (Out_Block, Actual); + else + Val := Execute_Name (Out_Block, Actual, False); + end if; + + -- FIXME: by value for scalars ? + + -- Keep ref for back-copy + if Mode /= Iir_In_Mode then + if Subprg_Block.Actuals_Ref = null then + declare + subtype Actuals_Ref_Type is + Value_Array (Iir_Index32 (Nbr_Assoc)); + function To_Value_Array_Acc is new + Ada.Unchecked_Conversion (System.Address, + Value_Array_Acc); + function Alloc_Actuals_Ref is new + Alloc_On_Pool_Addr (Actuals_Ref_Type); + + begin + Subprg_Block.Actuals_Ref := To_Value_Array_Acc + (Alloc_Actuals_Ref + (Instance_Pool, + Actuals_Ref_Type'(Len => Iir_Index32 (Nbr_Assoc), + V => (others => null)))); + end; + end if; + Subprg_Block.Actuals_Ref.V (Assoc_Idx) := + Unshare_Bounds (Val, Instance_Pool); + end if; + + if Mode = Iir_Out_Mode then + if Get_Formal_Conversion (Assoc) /= Null_Iir then + -- For an OUT variable using an out conversion, don't + -- associate with the actual, create a temporary value. + Val := Create_Value_For_Type + (Out_Block, Get_Type (Formal), Init_Value_Default); + elsif Get_Kind (Get_Type (Formal)) in + Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + -- These are passed by value. Must be reset. + Val := Create_Value_For_Type + (Out_Block, Get_Type (Formal), Init_Value_Default); + end if; + else + if Get_Kind (Assoc) = + Iir_Kind_Association_Element_By_Expression + then + Conv := Get_Actual_Conversion (Assoc); + if Conv /= Null_Iir then + Val := Execute_Assoc_Conversion + (Subprg_Block, Conv, Val); + end if; + end if; + + -- FIXME: check constraints ? + end if; + + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + + when others => + Error_Kind ("execute_association(2)", Inter); + end case; + + if Get_Whole_Association_Flag (Assoc) then + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_File_Declaration => + -- FIXME: Arguments are passed by copy. + Elaboration.Create_Object (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + when Iir_Kind_Interface_Signal_Declaration => + Elaboration.Create_Signal (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := + Unshare_Bounds (Val, Instance_Pool); + when others => + Error_Kind ("execute_association", Inter); + end case; + else + Associate_By_Reference + (Subprg_Block, Formal, Last_Individual, Val); + end if; + + << Continue >> null; + Next_Association_Interface (Assoc, Assoc_Inter); + Assoc_Idx := Assoc_Idx + 1; + end loop; + + Release (Marker, Expr_Pool); + end Execute_Association; + + procedure Execute_Back_Association (Instance : Block_Instance_Acc) + is + Call : constant Iir := Get_Procedure_Call (Instance.Parent.Stmt); + Imp : constant Iir := Get_Implementation (Call); + Assoc : Iir; + Assoc_Inter : Iir; + Inter : Iir; + Formal : Iir; + Assoc_Idx : Iir_Index32; + begin + Assoc := Get_Parameter_Association_Chain (Call); + Assoc_Inter := Get_Interface_Declaration_Chain (Imp); + Assoc_Idx := 1; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then + Inter := Get_Association_Interface (Assoc, Assoc_Inter); + Formal := Get_Association_Formal (Assoc, Inter); + + case Get_Kind (Inter) is + when Iir_Kind_Interface_Variable_Declaration => + if Get_Mode (Inter) /= Iir_In_Mode + and then Get_Kind (Get_Type (Inter)) /= + Iir_Kind_File_Type_Definition + then + -- For out/inout variable interface, the value must + -- be copied (FIXME: unless when passed by reference ?). + declare + Targ : constant Iir_Value_Literal_Acc := + Instance.Actuals_Ref.V (Assoc_Idx); + Base : constant Iir_Value_Literal_Acc := + Instance.Objects (Get_Info (Inter).Slot); + Val : Iir_Value_Literal_Acc; + Conv : Iir; + Is_Sig : Boolean; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + + -- Extract for individual association. + Execute_Name_With_Base + (Instance, Formal, Base, Val, Is_Sig); + Conv := Get_Formal_Conversion (Assoc); + if Conv /= Null_Iir then + Val := Execute_Assoc_Conversion + (Instance, Conv, Val); + -- FIXME: free val ? + end if; + Store (Targ, Val); + + Release (Expr_Mark, Expr_Pool); + end; + end if; + when Iir_Kind_Interface_File_Declaration => + null; + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration => + null; + when others => + Error_Kind ("execute_back_association", Inter); + end case; + end if; + Next_Association_Interface (Assoc, Assoc_Inter); + Assoc_Idx := Assoc_Idx + 1; + end loop; + end Execute_Back_Association; + + function Get_Protected_Object_Instance + (Block : Block_Instance_Acc; Call : Iir) return Block_Instance_Acc + is + Meth_Obj : constant Iir := Get_Method_Object (Call); + Obj : Iir_Value_Literal_Acc; + begin + if Meth_Obj = Null_Iir then + return null; + else + Obj := Execute_Name (Block, Meth_Obj, True); + return Protected_Table.Table (Obj.Prot); + end if; + end Get_Protected_Object_Instance; + + function Execute_Foreign_Function_Call + (Block: Block_Instance_Acc; Expr : Iir; Imp : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Get_Identifier (Imp) is + when Std_Names.Name_Get_Resolution_Limit => + Res := Create_I64_Value + (Ghdl_I64 + (Evaluation.Get_Physical_Value (Std_Package.Time_Base))); + when Std_Names.Name_Textio_Read_Real => + Res := Create_F64_Value + (File_Operation.Textio_Read_Real (Block.Objects (1))); + when others => + Error_Msg_Exec ("unsupported foreign function call", Expr); + end case; + return Res; + end Execute_Foreign_Function_Call; + + -- BLOCK is the block instance in which the function call appears. + function Execute_Function_Call + (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) + return Iir_Value_Literal_Acc + is + Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); + Subprg_Block: Block_Instance_Acc; + Prot_Block : Block_Instance_Acc; + Assoc_Chain: Iir; + Res : Iir_Value_Literal_Acc; + begin + Mark (Block.Marker, Instance_Pool.all); + + case Get_Kind (Expr) is + when Iir_Kind_Function_Call => + Prot_Block := Get_Protected_Object_Instance (Block, Expr); + Subprg_Block := + Create_Subprogram_Instance (Block, Prot_Block, Imp); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Execute_Association + (Block, Subprg_Block, Inter_Chain, Assoc_Chain); + -- No out/inout interface for functions. + pragma Assert (Subprg_Block.Actuals_Ref = null); + when Iir_Kinds_Dyadic_Operator => + Subprg_Block := Create_Subprogram_Instance (Block, null, Imp); + Execute_Dyadic_Association + (Block, Subprg_Block, Expr, Inter_Chain); + when Iir_Kinds_Monadic_Operator => + Subprg_Block := Create_Subprogram_Instance (Block, null, Imp); + Execute_Monadic_Association + (Block, Subprg_Block, Expr, Inter_Chain); + when others => + Error_Kind ("execute_subprogram_call_init", Expr); + end case; + + if Get_Foreign_Flag (Imp) then + Res := Execute_Foreign_Function_Call (Subprg_Block, Expr, Imp); + else + Res := Execute_Function_Body (Subprg_Block); + end if; + + -- Unfortunately, we don't know where the result has been allocated, + -- so copy it before releasing the instance pool. + Res := Unshare (Res, Expr_Pool'Access); + + Release (Block.Marker, Instance_Pool.all); + + return Res; + end Execute_Function_Call; + + -- Slide an array VALUE using bounds from REF_VALUE. Do not modify + -- VALUE if not an array. + procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; + Ref_Value : Iir_Value_Literal_Acc; + Expr : Iir) + is + Res : Iir_Value_Literal_Acc; + begin + if Value.Kind /= Iir_Value_Array then + return; + end if; + Res := Create_Array_Value (Value.Bounds.Nbr_Dims); + Res.Val_Array := Value.Val_Array; + for I in Value.Bounds.D'Range loop + if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + return; + end if; + Res.Bounds.D (I) := Ref_Value.Bounds.D (I); + end loop; + Value := Res; + end Implicit_Array_Conversion; + + procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; + Value : in out Iir_Value_Literal_Acc; + Ref_Type : Iir; + Expr : Iir) + is + Ref_Value : Iir_Value_Literal_Acc; + begin + -- Do array conversion only if REF_TYPE is a constrained array type + -- definition. + if Value.Kind /= Iir_Value_Array then + return; + end if; + if Get_Constraint_State (Ref_Type) /= Fully_Constrained then + return; + end if; + Ref_Value := Create_Array_Bounds_From_Type (Instance, Ref_Type, True); + for I in Value.Bounds.D'Range loop + if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + return; + end if; + end loop; + Ref_Value.Val_Array.V := Value.Val_Array.V; + Value := Ref_Value; + end Implicit_Array_Conversion; + + procedure Check_Array_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; + Expr: Iir) + is + Index_List : Iir_Flist; + Element_Subtype : Iir; + New_Bounds : Iir_Value_Literal_Acc; + begin + -- Nothing to check for unconstrained arrays. + if not Get_Index_Constraint_Flag (Def) then + return; + end if; + + Index_List := Get_Index_Subtype_List (Def); + for I in Value.Bounds.D'Range loop + New_Bounds := Execute_Bounds + (Instance, Get_Nth_Element (Index_List, Natural (I - 1))); + if not Is_Equal (Value.Bounds.D (I), New_Bounds) then + Error_Msg_Constraint (Expr); + return; + end if; + end loop; + + if Boolean'(False) then + Index_List := Get_Index_List (Def); + Element_Subtype := Get_Element_Subtype (Def); + for I in Value.Val_Array.V'Range loop + Check_Constraints + (Instance, Value.Val_Array.V (I), Element_Subtype, Expr); + end loop; + end if; + end Check_Array_Constraints; + + -- Check DEST and SRC are array compatible. + procedure Check_Array_Match + (Instance: Block_Instance_Acc; + Dest: Iir_Value_Literal_Acc; + Src : Iir_Value_Literal_Acc; + Expr: Iir) + is + pragma Unreferenced (Instance); + begin + for I in Dest.Bounds.D'Range loop + if Dest.Bounds.D (I).Length /= Src.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + exit; + end if; + end loop; + end Check_Array_Match; + pragma Unreferenced (Check_Array_Match); + + procedure Check_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; + Expr: Iir) + is + Base_Type : constant Iir := Get_Base_Type (Def); + High, Low: Iir_Value_Literal_Acc; + Bound : Iir_Value_Literal_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + Bound := Execute_Bounds (Instance, Def); + if Bound.Dir = Iir_To then + High := Bound.Right; + Low := Bound.Left; + else + High := Bound.Left; + Low := Bound.Right; + end if; + case Iir_Value_Scalars (Get_Info (Base_Type).Scalar_Mode) is + when Iir_Value_I64 => + if Value.I64 in Low.I64 .. High.I64 then + return; + end if; + when Iir_Value_E8 => + if Value.E8 in Low.E8 .. High.E8 then + return; + end if; + when Iir_Value_E32 => + if Value.E32 in Low.E32 .. High.E32 then + return; + end if; + when Iir_Value_F64 => + if Value.F64 in Low.F64 .. High.F64 then + return; + end if; + when Iir_Value_B1 => + if Value.B1 in Low.B1 .. High.B1 then + return; + end if; + end case; + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + Check_Array_Constraints (Instance, Value, Def, Expr); + return; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + List : constant Iir_Flist := + Get_Elements_Declaration_List (Get_Base_Type (Def)); + El : Iir_Element_Declaration; + begin + for I in Flist_First .. Flist_Last (List) loop + El := Get_Nth_Element (List, I); + Check_Constraints + (Instance, + Value.Val_Record.V (Get_Element_Position (El) + 1), + Get_Type (El), + Expr); + end loop; + end; + return; + when Iir_Kind_Integer_Type_Definition => + return; + when Iir_Kind_Floating_Type_Definition => + return; + when Iir_Kind_Physical_Type_Definition => + return; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return; + when Iir_Kind_File_Type_Definition => + return; + when others => + Error_Kind ("check_constraints", Def); + end case; + Error_Msg_Constraint (Expr); + end Check_Constraints; + + function Execute_Resolution_Function + (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Inter : Iir; + Instance : Block_Instance_Acc; + begin + -- Create a frame for this function. + Instance := Create_Subprogram_Instance (Block, null, Imp); + + Inter := Get_Interface_Declaration_Chain (Imp); + Elaboration.Create_Object (Instance, Inter); + Instance.Objects (Get_Info (Inter).Slot) := Arr; + + return Execute_Function_Body (Instance); + end Execute_Resolution_Function; + + procedure Execute_Signal_Assignment + (Instance: Block_Instance_Acc; + Stmt: Iir_Signal_Assignment_Statement) + is + Wf : constant Iir_Waveform_Element := Get_Waveform_Chain (Stmt); + Nbr_We : constant Natural := Get_Chain_Length (Wf); + + Transactions : Transaction_Type (Nbr_We); + + We: Iir_Waveform_Element; + Res: Iir_Value_Literal_Acc; + Rdest: Iir_Value_Literal_Acc; + Targ_Type : Iir; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + + Rdest := Execute_Name (Instance, Get_Target (Stmt), True); + Targ_Type := Get_Type (Get_Target (Stmt)); + + -- Disconnection statement. + if Wf = Null_Iir then + Disconnect_Signal (Rdest); + Release (Marker, Expr_Pool); + return; + end if; + + Transactions.Stmt := Stmt; + + -- LRM93 8.4.1 + -- Evaluation of a waveform consists of the evaluation of each waveform + -- elements in the waveform. + We := Wf; + for I in Transactions.Els'Range loop + declare + Trans : Transaction_El_Type renames Transactions.Els (I); + begin + if Get_Time (We) /= Null_Iir then + Res := Execute_Expression (Instance, Get_Time (We)); + -- LRM93 8.4.1 + -- It is an error if the time expression in a waveform element + -- evaluates to a negative value. + if Res.I64 < 0 then + Error_Msg_Exec ("time value is negative", Get_Time (We)); + end if; + Trans.After := Std_Time (Res.I64); + else + -- LRM93 8.4.1 + -- If the after clause of a waveform element is not present, + -- then an implicit "after 0 ns" is assumed. + Trans.After := 0; + end if; + + -- LRM93 8.4.1 + -- It is an error if the sequence of new transactions is not in + -- ascending order with respect to time. + if I > 1 + and then Trans.After <= Transactions.Els (I - 1).After + then + Error_Msg_Exec + ("sequence not in ascending order with respect to time", We); + end if; + + if Get_Kind (Get_We_Value (We)) = Iir_Kind_Null_Literal then + -- null transaction. + Trans.Value := null; + else + -- LRM93 8.4.1 + -- For the first form of waveform element, the value component + -- of the transaction is determined by the value expression in + -- the waveform element. + Trans.Value := Execute_Expression_With_Type + (Instance, Get_We_Value (We), Targ_Type); + end if; + end; + We := Get_Chain (We); + end loop; + pragma Assert (We = Null_Iir); + + case Get_Delay_Mechanism (Stmt) is + when Iir_Transport_Delay => + Transactions.Reject := 0; + when Iir_Inertial_Delay => + -- LRM93 8.4 + -- or, in the case that a pulse rejection limit is specified, + -- a pulse whose duration is shorter than that limit will not + -- be transmitted. + -- Every inertially delayed signal assignment has a pulse + -- rejection limit. + if Get_Reject_Time_Expression (Stmt) /= Null_Iir then + -- LRM93 8.4 + -- If the delay mechanism specifies inertial delay, and if the + -- reserved word reject followed by a time expression is + -- present, then the time expression specifies the pulse + -- rejection limit. + Res := Execute_Expression + (Instance, Get_Reject_Time_Expression (Stmt)); + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any + -- inertially delayed signal assignement statement is either + -- negative ... + if Res.I64 < 0 then + Error_Msg_Exec ("reject time negative", Stmt); + end if; + -- LRM93 8.4 + -- ... or greather than the time expression associated with + -- the first waveform element. + Transactions.Reject := Std_Time (Res.I64); + if Transactions.Reject > Transactions.Els (1).After then + Error_Msg_Exec + ("reject time greather than time expression", Stmt); + end if; + else + -- LRM93 8.4 + -- In all other cases, the pulse rejection limit is the time + -- expression associated ith the first waveform element. + Transactions.Reject := Transactions.Els (1).After; + end if; + end case; + + -- FIXME: slice Transactions to remove transactions after end of time. + Assign_Value_To_Signal (Instance, Rdest, Transactions); + + Release (Marker, Expr_Pool); + end Execute_Signal_Assignment; + + -- Display a message when an assertion has failed. + -- REPORT is the value (string) to display, or null to use default message. + -- SEVERITY is the severity or null to use default (error). + -- STMT is used to display location. + procedure Execute_Failed_Assertion (Msg : String; + Report : String; + Severity : Natural; + Stmt: Iir) is + begin + -- LRM93 8.2 + -- The error message consists of at least: + + -- 4: name of the design unit containing the assertion. + Put (Standard_Error, Disp_Location (Stmt)); + + -- 1: an indication that this message is from an assertion. + Put (Standard_Error, '('); + Put (Standard_Error, Msg); + Put (Standard_Error, ' '); + + -- 2: the value of the severity level. + case Severity is + when 0 => + Put (Standard_Error, "note"); + when 1 => + Put (Standard_Error, "warning"); + when 2 => + Put (Standard_Error, "error"); + when 3 => + Put (Standard_Error, "failure"); + when others => + Error_Internal (Null_Iir, "execute_failed_assertion"); + end case; + if Disp_Time_Before_Values then + Put (Standard_Error, " at "); + Grt.Astdio.Put_Time (Grt.Stdio.stderr, Current_Time); + end if; + Put (Standard_Error, "): "); + + -- 3: the value of the message string. + Put_Line (Standard_Error, Report); + + -- Stop execution if the severity is too high. + if Severity >= Grt.Options.Severity_Level then + Debug (Reason_Assert); + Grt.Errors.Fatal_Error; + end if; + end Execute_Failed_Assertion; + + procedure Execute_Failed_Assertion + (Instance: Block_Instance_Acc; + Label : String; + Stmt : Iir; + Default_Msg : String; + Default_Severity : Natural) + is + Expr: Iir; + Report, Severity_Lit: Iir_Value_Literal_Acc; + Severity : Natural; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + Expr := Get_Report_Expression (Stmt); + if Expr /= Null_Iir then + Report := Execute_Expression (Instance, Expr); + else + Report := null; + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Severity_Lit := Execute_Expression (Instance, Expr); + Severity := Natural'Val (Severity_Lit.E8); + else + Severity := Default_Severity; + end if; + if Report /= null then + declare + Msg : String (1 .. Natural (Report.Val_Array.Len)); + begin + for I in Report.Val_Array.V'Range loop + Msg (Positive (I)) := + Character'Val (Report.Val_Array.V (I).E8); + end loop; + Execute_Failed_Assertion (Label, Msg, Severity, Stmt); + end; + else + Execute_Failed_Assertion (Label, Default_Msg, Severity, Stmt); + end if; + Release (Marker, Expr_Pool); + end Execute_Failed_Assertion; + + function Is_In_Choice + (Instance: Block_Instance_Acc; + Choice: Iir; + Expr: Iir_Value_Literal_Acc) + return Boolean + is + Res : Boolean; + begin + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + return True; + when Iir_Kind_Choice_By_Expression => + declare + Expr1: Iir_Value_Literal_Acc; + begin + Expr1 := Execute_Expression + (Instance, Get_Choice_Expression (Choice)); + Res := Is_Equal (Expr, Expr1); + return Res; + end; + when Iir_Kind_Choice_By_Range => + declare + A_Range : Iir_Value_Literal_Acc; + begin + A_Range := Execute_Bounds + (Instance, Get_Choice_Range (Choice)); + Res := Is_In_Range (Expr, A_Range); + end; + return Res; + when others => + Error_Kind ("is_in_choice", Choice); + end case; + end Is_In_Choice; + + -- Return TRUE iff VAL is in the range defined by BOUNDS. + function Is_In_Range (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc) + return Boolean + is + Max, Min : Iir_Value_Literal_Acc; + begin + case Bounds.Dir is + when Iir_To => + Min := Bounds.Left; + Max := Bounds.Right; + when Iir_Downto => + Min := Bounds.Right; + Max := Bounds.Left; + end case; + + case Iir_Value_Discrete (Val.Kind) is + when Iir_Value_E8 => + return Val.E8 >= Min.E8 and Val.E8 <= Max.E8; + when Iir_Value_E32 => + return Val.E32 >= Min.E32 and Val.E32 <= Max.E32; + when Iir_Value_B1 => + return Val.B1 >= Min.B1 and Val.B1 <= Max.B1; + when Iir_Value_I64 => + return Val.I64 >= Min.I64 and Val.I64 <= Max.I64; + end case; + end Is_In_Range; + + -- Increment or decrement VAL according to BOUNDS.DIR. + -- FIXME: use increment ? + procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc) + is + begin + case Iir_Value_Discrete (Val.Kind) is + when Iir_Value_E8 => + case Bounds.Dir is + when Iir_To => + Val.E8 := Val.E8 + 1; + when Iir_Downto => + Val.E8 := Val.E8 - 1; + end case; + when Iir_Value_E32 => + case Bounds.Dir is + when Iir_To => + Val.E32 := Val.E32 + 1; + when Iir_Downto => + Val.E32 := Val.E32 - 1; + end case; + when Iir_Value_B1 => + case Bounds.Dir is + when Iir_To => + Val.B1 := True; + when Iir_Downto => + Val.B1 := False; + end case; + when Iir_Value_I64 => + case Bounds.Dir is + when Iir_To => + Val.I64 := Val.I64 + 1; + when Iir_Downto => + Val.I64 := Val.I64 - 1; + end case; + end case; + end Update_Loop_Index; + + procedure Finalize_For_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) + is + begin + Destroy_Iterator_Declaration + (Instance, Get_Parameter_Specification (Stmt)); + end Finalize_For_Loop_Statement; + + procedure Finalize_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) + is + begin + if Get_Kind (Stmt) = Iir_Kind_For_Loop_Statement then + Finalize_For_Loop_Statement (Instance, Stmt); + end if; + end Finalize_Loop_Statement; + + procedure Execute_For_Loop_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir_For_Loop_Statement := Instance.Stmt; + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Bounds : Iir_Value_Literal_Acc; + Index : Iir_Value_Literal_Acc; + Stmt_Chain : Iir; + Is_Nul : Boolean; + Marker : Mark_Type; + begin + -- Elaborate the iterator (and its type). + Elaborate_Declaration (Instance, Iterator); + + -- Extract bounds. + Mark (Marker, Expr_Pool); + Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); + Index := Instance.Objects (Get_Info (Iterator).Slot); + Store (Index, Bounds.Left); + Is_Nul := Is_Null_Range (Bounds); + Release (Marker, Expr_Pool); + + if Is_Nul then + -- Loop is complete. + Finalize_For_Loop_Statement (Instance, Stmt); + Update_Next_Statement (Proc); + else + Stmt_Chain := Get_Sequential_Statement_Chain (Stmt); + if Stmt_Chain = Null_Iir then + -- Nothing to do for an empty loop. + Finalize_For_Loop_Statement (Instance, Stmt); + Update_Next_Statement (Proc); + else + Instance.Stmt := Stmt_Chain; + end if; + end if; + end Execute_For_Loop_Statement; + + -- This function is called when there is no more statements to execute + -- in the statement list of a for_loop. Returns FALSE in case of end of + -- loop. + function Finish_For_Loop_Statement (Instance : Block_Instance_Acc) + return Boolean + is + Iterator : constant Iir := Get_Parameter_Specification (Instance.Stmt); + Bounds : Iir_Value_Literal_Acc; + Index : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + -- FIXME: avoid allocation. + Mark (Marker, Expr_Pool); + Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); + Index := Instance.Objects (Get_Info (Iterator).Slot); + + if Is_Equal (Index, Bounds.Right) then + -- Loop is complete. + Release (Marker, Expr_Pool); + Finalize_For_Loop_Statement (Instance, Instance.Stmt); + return False; + else + -- Update the loop index. + Update_Loop_Index (Index, Bounds); + + Release (Marker, Expr_Pool); + + -- start the loop again. + Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); + return True; + end if; + end Finish_For_Loop_Statement; + + -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. + function Execute_Condition (Instance : Block_Instance_Acc; + Cond : Iir) return Boolean + is + V : Iir_Value_Literal_Acc; + Res : Boolean; + Marker : Mark_Type; + begin + if Cond = Null_Iir then + return True; + end if; + + Mark (Marker, Expr_Pool); + V := Execute_Expression (Instance, Cond); + Res := V.B1 = True; + Release (Marker, Expr_Pool); + return Res; + end Execute_Condition; + + -- Start a while loop statement, or return FALSE if the loop is not + -- executed. + procedure Execute_While_Loop_Statement (Proc : Process_State_Acc) + is + Instance: constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Cond : Boolean; + begin + Cond := Execute_Condition (Instance, Get_Condition (Stmt)); + if Cond then + Init_Sequential_Statements (Proc, Stmt); + else + Update_Next_Statement (Proc); + end if; + end Execute_While_Loop_Statement; + + -- This function is called when there is no more statements to execute + -- in the statement list of a while loop. Returns FALSE iff loop is + -- completed. + function Finish_While_Loop_Statement (Instance : Block_Instance_Acc) + return Boolean + is + Cond : Boolean; + begin + Cond := Execute_Condition (Instance, Get_Condition (Instance.Stmt)); + + if Cond then + -- start the loop again. + Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); + return True; + else + -- Loop is complete. + return False; + end if; + end Finish_While_Loop_Statement; + + -- Return TRUE if the loop must be executed again + function Finish_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) return Boolean is + begin + Instance.Stmt := Stmt; + case Get_Kind (Stmt) is + when Iir_Kind_While_Loop_Statement => + return Finish_While_Loop_Statement (Instance); + when Iir_Kind_For_Loop_Statement => + return Finish_For_Loop_Statement (Instance); + when others => + Error_Kind ("finish_loop_statement", Stmt); + end case; + end Finish_Loop_Statement; + + -- Return FALSE if the next statement should be executed (possibly + -- updated). + procedure Execute_Exit_Next_Statement (Proc : Process_State_Acc; + Is_Exit : Boolean) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Label : constant Iir := Get_Named_Entity (Get_Loop_Label (Stmt)); + Cond : Boolean; + Parent : Iir; + begin + Cond := Execute_Condition (Instance, Get_Condition (Stmt)); + if not Cond then + Update_Next_Statement (Proc); + return; + end if; + + Parent := Stmt; + loop + Parent := Get_Parent (Parent); + case Get_Kind (Parent) is + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + if Label = Null_Iir or else Label = Parent then + -- Target is this statement. + if Is_Exit then + Finalize_Loop_Statement (Instance, Parent); + Instance.Stmt := Parent; + Update_Next_Statement (Proc); + elsif not Finish_Loop_Statement (Instance, Parent) then + Update_Next_Statement (Proc); + else + Init_Sequential_Statements (Proc, Parent); + end if; + return; + else + Finalize_Loop_Statement (Instance, Parent); + end if; + when others => + null; + end case; + end loop; + end Execute_Exit_Next_Statement; + + procedure Execute_Case_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Value: Iir_Value_Literal_Acc; + Assoc: Iir; + Stmt_Chain : Iir; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + + Value := Execute_Expression (Instance, Get_Expression (Stmt)); + Assoc := Get_Case_Statement_Alternative_Chain (Stmt); + + while Assoc /= Null_Iir loop + if not Get_Same_Alternative_Flag (Assoc) then + Stmt_Chain := Get_Associated_Chain (Assoc); + end if; + + if Is_In_Choice (Instance, Assoc, Value) then + if Stmt_Chain = Null_Iir then + Update_Next_Statement (Proc); + else + Instance.Stmt := Stmt_Chain; + end if; + Release (Marker, Expr_Pool); + return; + end if; + + Assoc := Get_Chain (Assoc); + end loop; + -- FIXME: infinite loop??? + Error_Msg_Exec ("no choice for expression", Stmt); + raise Internal_Error; + end Execute_Case_Statement; + + procedure Execute_Call_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Implementation (Call); + Subprg_Instance : Block_Instance_Acc; + Prot_Block : Block_Instance_Acc; + Assoc_Chain: Iir; + Inter_Chain : Iir; + Subprg_Body : Iir; + begin + if Get_Implicit_Definition (Imp) in Iir_Predefined_Implicit then + Execute_Implicit_Procedure (Instance, Call); + Update_Next_Statement (Proc); + elsif Get_Foreign_Flag (Imp) then + Execute_Foreign_Procedure (Instance, Call); + Update_Next_Statement (Proc); + else + Mark (Instance.Marker, Instance_Pool.all); + Prot_Block := Get_Protected_Object_Instance (Instance, Call); + Subprg_Instance := + Create_Subprogram_Instance (Instance, Prot_Block, Imp); + Assoc_Chain := Get_Parameter_Association_Chain (Call); + Inter_Chain := Get_Interface_Declaration_Chain (Imp); + Execute_Association + (Instance, Subprg_Instance, Inter_Chain, Assoc_Chain); + + Current_Process.Instance := Subprg_Instance; + Subprg_Body := Get_Subprogram_Body (Imp); + Elaborate_Declarative_Part + (Subprg_Instance, Get_Declaration_Chain (Subprg_Body)); + + Init_Sequential_Statements (Proc, Subprg_Body); + end if; + end Execute_Call_Statement; + + procedure Finish_Procedure_Frame (Proc : Process_State_Acc) + is + Old_Instance : constant Block_Instance_Acc := Proc.Instance; + begin + Execute_Back_Association (Old_Instance); + Proc.Instance := Old_Instance.Parent; + Execute_Subprogram_Call_Final (Old_Instance); + Release (Proc.Instance.Marker, Instance_Pool.all); + end Finish_Procedure_Frame; + + procedure Execute_If_Statement + (Proc : Process_State_Acc; Stmt: Iir_Wait_Statement) + is + Clause: Iir; + Cond: Boolean; + begin + Clause := Stmt; + loop + Cond := Execute_Condition (Proc.Instance, Get_Condition (Clause)); + if Cond then + Init_Sequential_Statements (Proc, Clause); + return; + end if; + Clause := Get_Else_Clause (Clause); + exit when Clause = Null_Iir; + end loop; + Update_Next_Statement (Proc); + end Execute_If_Statement; + + procedure Execute_Variable_Assignment + (Proc : Process_State_Acc; Stmt : Iir) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Target : constant Iir := Get_Target (Stmt); + Target_Type : constant Iir := Get_Type (Target); + Expr : constant Iir := Get_Expression (Stmt); + Expr_Type : constant Iir := Get_Type (Expr); + Target_Val: Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + Target_Val := Execute_Expression (Instance, Target); + + -- If the type of the target is not static and the value is + -- an aggregate, then the aggregate may be contrained by the + -- target. + if Get_Kind (Expr) = Iir_Kind_Aggregate + and then Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition + then + Res := Copy_Array_Bound (Target_Val); + Fill_Array_Aggregate (Instance, Expr, Res); + else + Res := Execute_Expression (Instance, Expr); + end if; + if Get_Kind (Target_Type) in Iir_Kinds_Array_Type_Definition then + -- Note: target_type may be dynamic (slice case), so + -- check_constraints is not called. + Implicit_Array_Conversion (Res, Target_Val, Stmt); + else + Check_Constraints (Instance, Res, Target_Type, Stmt); + end if; + + -- Note: we need to unshare before copying to avoid + -- overwrites (in assignments like: v (1 to 4) := v (3 to 6)). + -- FIXME: improve that handling (detect overlaps before). + Store (Target_Val, Unshare (Res, Expr_Pool'Access)); + + Release (Marker, Expr_Pool); + end Execute_Variable_Assignment; + + function Execute_Return_Statement (Proc : Process_State_Acc) + return Boolean + is + Res : Iir_Value_Literal_Acc; + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Expr : constant Iir := Get_Expression (Stmt); + begin + if Expr /= Null_Iir then + Res := Execute_Expression (Instance, Expr); + Implicit_Array_Conversion (Instance, Res, Get_Type (Stmt), Stmt); + Check_Constraints (Instance, Res, Get_Type (Stmt), Stmt); + Instance.Result := Res; + end if; + + case Get_Kind (Instance.Label) is + when Iir_Kind_Procedure_Declaration => + Finish_Procedure_Frame (Proc); + Update_Next_Statement (Proc); + return False; + when Iir_Kind_Function_Declaration => + return True; + when others => + raise Internal_Error; + end case; + end Execute_Return_Statement; + + procedure Finish_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir) + is + Instance : Block_Instance_Acc := Proc.Instance; + Stmt : Iir; + begin + Stmt := Complex_Stmt; + loop + Instance.Stmt := Stmt; + case Get_Kind (Stmt) is + when Iir_Kind_For_Loop_Statement => + if Finish_For_Loop_Statement (Instance) then + return; + end if; + when Iir_Kind_While_Loop_Statement => + if Finish_While_Loop_Statement (Instance) then + return; + end if; + when Iir_Kind_Case_Statement + | Iir_Kind_If_Statement => + null; + when Iir_Kind_Sensitized_Process_Statement => + Instance.Stmt := Null_Iir; + return; + when Iir_Kind_Process_Statement => + -- Start again. + Instance.Stmt := Get_Sequential_Statement_Chain (Stmt); + return; + when Iir_Kind_Procedure_Body => + Finish_Procedure_Frame (Proc); + Instance := Proc.Instance; + when Iir_Kind_Function_Body => + Error_Msg_Exec ("missing return statement in function", Stmt); + when others => + Error_Kind ("execute_next_statement", Stmt); + end case; + Stmt := Get_Chain (Instance.Stmt); + if Stmt /= Null_Iir then + Instance.Stmt := Stmt; + return; + end if; + Stmt := Get_Parent (Instance.Stmt); + end loop; + end Finish_Sequential_Statements; + + procedure Init_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir) + is + Stmt : Iir; + begin + Stmt := Get_Sequential_Statement_Chain (Complex_Stmt); + if Stmt /= Null_Iir then + Proc.Instance.Stmt := Stmt; + else + Finish_Sequential_Statements (Proc, Complex_Stmt); + end if; + end Init_Sequential_Statements; + + procedure Update_Next_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : Iir; + begin + Stmt := Get_Chain (Instance.Stmt); + if Stmt /= Null_Iir then + Instance.Stmt := Stmt; + return; + end if; + Finish_Sequential_Statements (Proc, Get_Parent (Instance.Stmt)); + end Update_Next_Statement; + + procedure Execute_Sequential_Statements (Proc : Process_State_Acc) + is + Instance : Block_Instance_Acc; + Stmt: Iir; + begin + loop + Instance := Proc.Instance; + Stmt := Instance.Stmt; + + -- End of process or subprogram. + exit when Stmt = Null_Iir; + + if Trace_Statements then + declare + Name : Name_Id; + Line : Natural; + Col : Natural; + begin + Files_Map.Location_To_Position + (Get_Location (Stmt), Name, Line, Col); + Put_Line ("Execute statement at " + & Name_Table.Image (Name) + & Natural'Image (Line)); + end; + end if; + + if Flag_Need_Debug then + Debug (Reason_Break); + end if; + + -- execute statement STMT. + case Get_Kind (Stmt) is + when Iir_Kind_Null_Statement => + Update_Next_Statement (Proc); + + when Iir_Kind_If_Statement => + Execute_If_Statement (Proc, Stmt); + + when Iir_Kind_Simple_Signal_Assignment_Statement => + Execute_Signal_Assignment (Instance, Stmt); + Update_Next_Statement (Proc); + + when Iir_Kind_Assertion_Statement => + declare + Res : Boolean; + begin + Res := Execute_Condition + (Instance, Get_Assertion_Condition (Stmt)); + if not Res then + Execute_Failed_Assertion (Instance, "assertion", Stmt, + "Assertion violation.", 2); + end if; + end; + Update_Next_Statement (Proc); + + when Iir_Kind_Report_Statement => + Execute_Failed_Assertion (Instance, "report", Stmt, + "Assertion violation.", 0); + Update_Next_Statement (Proc); + + when Iir_Kind_Variable_Assignment_Statement => + Execute_Variable_Assignment (Proc, Stmt); + Update_Next_Statement (Proc); + + when Iir_Kind_Return_Statement => + if Execute_Return_Statement (Proc) then + return; + end if; + + when Iir_Kind_For_Loop_Statement => + Execute_For_Loop_Statement (Proc); + + when Iir_Kind_While_Loop_Statement => + Execute_While_Loop_Statement (Proc); + + when Iir_Kind_Case_Statement => + Execute_Case_Statement (Proc); + + when Iir_Kind_Wait_Statement => + if Execute_Wait_Statement (Instance, Stmt) then + return; + end if; + Update_Next_Statement (Proc); + + when Iir_Kind_Procedure_Call_Statement => + Execute_Call_Statement (Proc); + + when Iir_Kind_Exit_Statement => + Execute_Exit_Next_Statement (Proc, True); + when Iir_Kind_Next_Statement => + Execute_Exit_Next_Statement (Proc, False); + + when others => + Error_Kind ("execute_sequential_statements", Stmt); + end case; + end loop; + end Execute_Sequential_Statements; +end Simul.Execution; diff --git a/src/vhdl/simulate/simul-execution.ads b/src/vhdl/simulate/simul-execution.ads new file mode 100644 index 000000000..358c26eae --- /dev/null +++ b/src/vhdl/simulate/simul-execution.ads @@ -0,0 +1,192 @@ +-- 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 Types; use Types; +with Iirs; use Iirs; +with Simul.Environments; use Simul.Environments; +with Simul.Elaboration; use Simul.Elaboration; +with Areapools; use Areapools; + +package Simul.Execution is + Trace_Statements : Boolean := False; + + -- If true, disp current time in assert message. + Disp_Time_Before_Values: Boolean := False; + + Current_Component : Block_Instance_Acc := null; + + -- State associed with each process. + type Process_State_Type is record + -- The process instance. + Top_Instance: Block_Instance_Acc := null; + Proc: Iir := Null_Iir; + + -- Memory pool to allocate objects from. + Pool : aliased Areapool; + + -- The stack of the process. + Instance : Block_Instance_Acc := null; + end record; + type Process_State_Acc is access all Process_State_Type; + + type Process_State_Array is + array (Process_Index_Type range <>) of aliased Process_State_Type; + type Process_State_Array_Acc is access Process_State_Array; + + -- Array containing all processes. + Processes_State: Process_State_Array_Acc; + + Simulation_Finished : exception; + + -- Current process being executed. This is only for the debugger. + Current_Process : Process_State_Acc; + + -- Pseudo process used for resolution functions, ... + No_Process : Process_State_Acc := new Process_State_Type; + -- Execute a list of sequential statements. + -- Return when there is no more statements to execute. + procedure Execute_Sequential_Statements (Proc : Process_State_Acc); + + -- Evaluate an expression. + function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc; + + -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. + function Execute_Condition (Instance : Block_Instance_Acc; + Cond : Iir) return Boolean; + + -- Execute a name. Return the value if Ref is False, or the reference + -- (for a signal, a quantity or a terminal) if Ref is True. + function Execute_Name (Block: Block_Instance_Acc; + Expr: Iir; + Ref : Boolean := False) + return Iir_Value_Literal_Acc; + + 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); + + -- Return the initial value (default value) of signal name EXPR. To be + -- used only during (non-dynamic) elaboration. + function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) + return Iir_Value_Literal_Acc; + + function Execute_Expression_With_Type + (Block: Block_Instance_Acc; + Expr: Iir; + Expr_Type : Iir) + return Iir_Value_Literal_Acc; + + procedure Execute_Failed_Assertion + (Instance: Block_Instance_Acc; + Label : String; + Stmt : Iir; + Default_Msg : String; + Default_Severity : Natural); + + function Execute_Resolution_Function + (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Execute_Assoc_Conversion + (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Sub function common for left/right/length/low/high attributes. + -- Return bounds of PREFIX. + function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) + return Iir_Value_Literal_Acc; + + -- 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; + + function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Get_Instance_By_Scope + (Instance: Block_Instance_Acc; Scope: Scope_Type) + return Block_Instance_Acc; + + function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) + return Block_Instance_Acc; + + -- Check VALUE follows the constraints of DEF. + -- INSTANCE,DEF is the definition of a subtype. + -- EXPR is just used in case of error to display the location + -- If there is no location, EXPR can be null. + -- Implicitly convert VALUE (array cases). + -- Return in case of success. + -- Raise errorout.execution_constraint_error in case of failure. + procedure Check_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; Expr: Iir); + + -- If VALUE is not an array, then this is a no-op. + -- If VALUE is an array, then bounds are checked and converted. INSTANCE + -- is the instance corresponding to REF_TYPE. + -- EXPR is used in case of error. + procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; + Ref_Value : Iir_Value_Literal_Acc; + Expr : Iir); + procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; + Value : in out Iir_Value_Literal_Acc; + Ref_Type : Iir; + Expr : Iir); + + -- 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; + + -- Create a range from LEN for scalar type ATYPE. + function Create_Bounds_From_Length (Block : Block_Instance_Acc; + Atype : Iir; + Len : Iir_Index32) + return Iir_Value_Literal_Acc; + + -- 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; + + -- Increment or decrement VAL according to BOUNDS.DIR. + procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc); + + -- Create a block instance for subprogram IMP. + function Create_Subprogram_Instance (Instance : Block_Instance_Acc; + Prot_Obj : Block_Instance_Acc; + Imp : Iir) + return Block_Instance_Acc; + + function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; + Expr_Type : Iir) + return String; +end Simul.Execution; diff --git a/src/vhdl/simulate/simul-file_operation.adb b/src/vhdl/simulate/simul-file_operation.adb new file mode 100644 index 000000000..98b1729c2 --- /dev/null +++ b/src/vhdl/simulate/simul-file_operation.adb @@ -0,0 +1,384 @@ +-- File operations for interpreter +-- 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 Types; use Types; +with Simul.Annotations; use Simul.Annotations; +with Simul.Execution; use Simul.Execution; +with Simul.Debugger; use Simul.Debugger; +with Simul.Grt_Interface; use Simul.Grt_Interface; +with Grt.Lib; + +package body Simul.File_Operation is + -- Open a file. + -- See LRM93 3.4.1 for definition of arguments. + -- IS_TEXT is true if the file format is text. + -- The purpose of the IS_TEXT is to allow a text implementation of file + -- type TEXT, defined in std.textio. + procedure File_Open (Status : out Ghdl_I32; + File : Iir_Value_Literal_Acc; + External_Name : Iir_Value_Literal_Acc; + Mode : Ghdl_I32; + Is_Text : Boolean; + Return_Status : Boolean) + is + Name_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (External_Name.Bounds.D (1).Length); + Name_Str : aliased Std_String_Uncons (1 .. Name_Len); + Name_Bnd : aliased Std_String_Bound := Build_Bound (External_Name); + Name : aliased Std_String := (To_Std_String_Basep (Name_Str'Address), + To_Std_String_Boundp (Name_Bnd'Address)); + begin + -- Convert the string to an Ada string. + for I in External_Name.Val_Array.V'Range loop + Name_Str (Name_Str'First + Ghdl_Index_Type (I - 1)) := + Character'Val (External_Name.Val_Array.V (I).E8); + end loop; + + if Is_Text then + if Return_Status then + Status := Ghdl_Text_File_Open_Status + (File.File, Mode, Name'Unrestricted_Access); + else + Ghdl_Text_File_Open (File.File, Mode, Name'Unrestricted_Access); + Status := Open_Ok; + end if; + else + if Return_Status then + Status := Ghdl_File_Open_Status + (File.File, Mode, Name'Unrestricted_Access); + else + Ghdl_File_Open (File.File, Mode, Name'Unrestricted_Access); + Status := Open_Ok; + end if; + end if; + end File_Open; + + -- Open a file. + procedure File_Open (File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir) + is + pragma Unreferenced (Stmt); + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); + File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E8); + Status : Ghdl_I32; + begin + File_Open (Status, File, Name, File_Mode, Is_Text, False); + if Status /= Open_Ok then + raise Program_Error; + end if; + end File_Open; + + procedure File_Open_Status (Status : Iir_Value_Literal_Acc; + File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir) + is + pragma Unreferenced (Stmt); + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); + File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E8); + R_Status : Ghdl_I32; + begin + File_Open (R_Status, File, Name, File_Mode, Is_Text, True); + Status.E8 := Ghdl_E8 (R_Status); + end File_Open_Status; + + function Elaborate_File_Declaration + (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration) + return Iir_Value_Literal_Acc + is + Def : constant Iir := Get_Type (Decl); + External_Name : Iir; + File_Name: Iir_Value_Literal_Acc; + Is_Text : constant Boolean := Get_Text_File_Flag (Def); + File_Mode : Ghdl_I32; + Res : Iir_Value_Literal_Acc; + Status : Ghdl_I32; + Mode : Iir_Value_Literal_Acc; + begin + if Is_Text then + Res := Create_File_Value (Ghdl_Text_File_Elaborate); + else + declare + Sig : constant String_Acc := Get_Info (Def).File_Signature; + Cstr : Ghdl_C_String; + begin + if Sig = null then + Cstr := null; + else + Cstr := To_Ghdl_C_String (Sig.all'Address); + end if; + Res := Create_File_Value (Ghdl_File_Elaborate (Cstr)); + end; + end if; + + External_Name := Get_File_Logical_Name (Decl); + + -- LRM93 4.3.1.4 + -- If file open information is not included in a given file declaration, + -- then the file declared by the declaration is not opened when the file + -- declaration is elaborated. + if External_Name = Null_Iir then + return Res; + end if; + + File_Name := Execute_Expression (Instance, External_Name); + if Get_File_Open_Kind (Decl) /= Null_Iir then + Mode := Execute_Expression (Instance, Get_File_Open_Kind (Decl)); + File_Mode := Ghdl_I32 (Mode.E8); + else + case Get_Mode (Decl) is + when Iir_In_Mode => + File_Mode := Read_Mode; + when Iir_Out_Mode => + File_Mode := Write_Mode; + when others => + raise Internal_Error; + end case; + end if; + File_Open (Status, Res, File_Name, File_Mode, Is_Text, False); + return Res; + end Elaborate_File_Declaration; + + procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir) is + pragma Unreferenced (Stmt); + begin + Ghdl_Text_File_Close (File.File); + end File_Close_Text; + + procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir) is + pragma Unreferenced (Stmt); + begin + Ghdl_File_Close (File.File); + end File_Close_Binary; + + procedure File_Destroy_Text (File : Iir_Value_Literal_Acc) is + begin + Ghdl_Text_File_Finalize (File.File); + end File_Destroy_Text; + + procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Finalize (File.File); + end File_Destroy_Binary; + + + procedure Write_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) is + begin + case Value.Kind is + when Iir_Value_B1 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_E8 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.E8'Address), 1); + when Iir_Value_E32 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); + when Iir_Value_F64 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); + when Iir_Value_Array => + for I in Value.Bounds.D'Range loop + Ghdl_Write_Scalar + (File.File, Ghdl_Ptr (Value.Bounds.D (I).Length'Address), 4); + end loop; + for I in Value.Val_Array.V'Range loop + Write_Binary (File, Value.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + Write_Binary (File, Value.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Write_Binary; + + procedure Write_Text (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) + is + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Value.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + begin + -- Convert the string to an Ada string. + for I in Value.Val_Array.V'Range loop + Val_Str (Val_Str'First + Ghdl_Index_Type (I - 1)) := + Character'Val (Value.Val_Array.V (I).E8); + end loop; + + Ghdl_Text_Write (File.File, Val'Unrestricted_Access); + end Write_Text; + + function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) + return Boolean + is + pragma Unreferenced (Stmt); + begin + return Grt.Files.Ghdl_File_Endfile (File.File); + end Endfile; + + procedure Read_Length_Text (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Value.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + Len : Std_Integer; + begin + Len := Ghdl_Text_Read_Length (File.File, Val'Unrestricted_Access); + for I in 1 .. Len loop + Value.Val_Array.V (Iir_Index32 (I)).E8 := + Character'Pos (Val_Str (Ghdl_Index_Type (I))); + end loop; + Length.I64 := Ghdl_I64 (Len); + end Read_Length_Text; + + procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc; + Str : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Len : Std_Integer; + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Str.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Str); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + begin + Ghdl_Untruncated_Text_Read + (File.File, Val'Unrestricted_Access, Len'Unrestricted_Access); + for I in 1 .. Len loop + Str.Val_Array.V (Iir_Index32 (I)).E8 := + Character'Pos (Val_Str (Ghdl_Index_Type (I))); + end loop; + Length.I64 := Ghdl_I64 (Len); + end Untruncated_Text_Read; + + procedure Read_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) + is + begin + case Value.Kind is + when Iir_Value_B1 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_E8 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E8'Address), 1); + when Iir_Value_E32 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); + when Iir_Value_F64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); + when Iir_Value_Array => + for I in Value.Bounds.D'Range loop + declare + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + if Len /= Value.Bounds.D (I).Length then + Error_Msg_Constraint (Null_Iir); -- FIXME: loc + end if; + end; + end loop; + for I in Value.Val_Array.V'Range loop + Read_Binary (File, Value.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + Read_Binary (File, Value.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Read_Binary; + + procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + for I in 1 .. Len loop + if I <= Value.Bounds.D (1).Length then + Read_Binary (File, Value.Val_Array.V (I)); + else + -- FIXME: for empty arrays ?? + -- Lose_Binary (File, Value.Val_Array (0)); + raise Internal_Error; + end if; + end loop; + Length.I64 := Ghdl_I64 (Len); + end Read_Length_Binary; + + procedure Flush (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Flush (File.File); + end Flush; + + procedure Textio_Write_Real (Str : Iir_Value_Literal_Acc; + Len : Iir_Value_Literal_Acc; + Val : Ghdl_F64; + Ndigits : Std_Integer) + is + Len_Arg : aliased Std_Integer; + Str_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Str.Bounds.D (1).Length); + Str_Str : aliased Std_String_Uncons (1 .. Str_Len); + Str_Bnd : aliased Std_String_Bound := Build_Bound (Str); + Str_Arg : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), + To_Std_String_Boundp (Str_Bnd'Address)); + begin + Grt.Lib.Textio_Write_Real + (Str_Arg'Unrestricted_Access, Len_Arg'Unrestricted_Access, + Val, Ndigits); + for I in 1 .. Len_Arg loop + Str.Val_Array.V (Iir_Index32 (I)).E8 := + Character'Pos (Str_Str (Ghdl_Index_Type (I))); + end loop; + Len.I64 := Ghdl_I64 (Len_Arg); + end Textio_Write_Real; + + function Textio_Read_Real (Str : Iir_Value_Literal_Acc) return Ghdl_F64 + is + Str_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Str.Bounds.D (1).Length); + Str_Str : aliased Std_String_Uncons (1 .. Str_Len); + Str_Bnd : aliased Std_String_Bound := Build_Bound (Str); + Str_Arg : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), + To_Std_String_Boundp (Str_Bnd'Address)); + begin + for I in Str.Val_Array.V'Range loop + Str_Str (Ghdl_Index_Type (I)) := + Character'Val (Str.Val_Array.V (I).E8); + end loop; + return Grt.Lib.Textio_Read_Real (Str_Arg'Unrestricted_Access); + end Textio_Read_Real; +end Simul.File_Operation; diff --git a/src/vhdl/simulate/simul-file_operation.ads b/src/vhdl/simulate/simul-file_operation.ads new file mode 100644 index 000000000..5844cea77 --- /dev/null +++ b/src/vhdl/simulate/simul-file_operation.ads @@ -0,0 +1,89 @@ +-- File operations for interpreter +-- 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 Iirs; use Iirs; +with Simul.Environments; use Simul.Environments; +with Grt.Files; use Grt.Files; +with Grt.Types; use Grt.Types; + +package Simul.File_Operation is + Null_File : constant Natural := 0; + + -- Open a file. + procedure File_Open (File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir); + + procedure File_Open_Status (Status : Iir_Value_Literal_Acc; + File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir); + + -- Close a file. + -- If the file was not open, this has no effects. + procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir); + procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir); + + procedure File_Destroy_Text (File : Iir_Value_Literal_Acc); + procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc); + + -- Elaborate a file_declaration. + function Elaborate_File_Declaration + (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration) + return Iir_Value_Literal_Acc; + + -- Write VALUE to FILE. + -- STMT is the statement, to display error. + procedure Write_Text (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc); + procedure Write_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc); + + procedure Read_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc); + + procedure Read_Length_Text (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc); + + procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc); + + procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc; + Str : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc); + + procedure Flush (File : Iir_Value_Literal_Acc); + + -- Test end of FILE is reached. + function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) + return Boolean; + + -- Fp to string + procedure Textio_Write_Real (Str : Iir_Value_Literal_Acc; + Len : Iir_Value_Literal_Acc; + Val : Ghdl_F64; + Ndigits : Std_Integer); + + function Textio_Read_Real (Str : Iir_Value_Literal_Acc) return Ghdl_F64; +end Simul.File_Operation; diff --git a/src/vhdl/simulate/simul-grt_interface.adb b/src/vhdl/simulate/simul-grt_interface.adb new file mode 100644 index 000000000..a8ff0a056 --- /dev/null +++ b/src/vhdl/simulate/simul-grt_interface.adb @@ -0,0 +1,44 @@ +-- 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 Iirs; use Iirs; +with Types; use Types; + +package body Simul.Grt_Interface is + To_Dir : constant array (Iir_Direction) of Ghdl_Dir_Type := + (Iir_To => Dir_To, Iir_Downto => Dir_Downto); + + function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound + is + Rng : constant Iir_Value_Literal_Acc := Arr.Bounds.D (1); + begin + return (Dim_1 => (Left => Std_Integer (Rng.Left.I64), + Right => Std_Integer (Rng.Right.I64), + Dir => To_Dir (Rng.Dir), + Length => Ghdl_Index_Type (Rng.Length))); + end Build_Bound; + + procedure Set_Std_String_From_Iir_Value (Str : Std_String; + Val : Iir_Value_Literal_Acc) is + begin + for I in Val.Val_Array.V'Range loop + Str.Base (Ghdl_Index_Type (I - 1)) := + Character'Val (Val.Val_Array.V (I).E8); + end loop; + end Set_Std_String_From_Iir_Value; +end Simul.Grt_Interface; diff --git a/src/vhdl/simulate/simul-grt_interface.ads b/src/vhdl/simulate/simul-grt_interface.ads new file mode 100644 index 000000000..6ce89fe7f --- /dev/null +++ b/src/vhdl/simulate/simul-grt_interface.ads @@ -0,0 +1,27 @@ +-- 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 Grt.Types; use Grt.Types; +with Simul.Environments; use Simul.Environments; + +package Simul.Grt_Interface is + procedure Set_Std_String_From_Iir_Value (Str : Std_String; + Val : Iir_Value_Literal_Acc); + + function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound; +end Simul.Grt_Interface; diff --git a/src/vhdl/simulate/simul-simulation-main.adb b/src/vhdl/simulate/simul-simulation-main.adb new file mode 100644 index 000000000..4614b2746 --- /dev/null +++ b/src/vhdl/simulate/simul-simulation-main.adb @@ -0,0 +1,1145 @@ +-- Interpreted simulation +-- Copyright (C) 2014-2017 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 Types; use Types; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with PSL.Nodes; +with PSL.NFAs; +with Std_Package; +with Trans_Analyzes; +with Simul.Elaboration; use Simul.Elaboration; +with Simul.Execution; use Simul.Execution; +with Ieee.Std_Logic_1164; +with Grt.Main; +with Simul.Debugger; use Simul.Debugger; +with Simul.Debugger.AMS; +with Grt.Errors; +with Grt.Rtis; +with Grt.Processes; +with Grt.Signals; +with Areapools; use Areapools; + +package body Simul.Simulation.Main is + -- Configuration for the whole design + Top_Config : Iir_Design_Unit; + + -- Elaborate the design + procedure Ghdl_Elaborate; + pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); + + function To_Instance_Acc is new Ada.Unchecked_Conversion + (System.Address, Grt.Processes.Instance_Acc); + + procedure Process_Executer (Self : Grt.Processes.Instance_Acc); + pragma Convention (C, Process_Executer); + + procedure Process_Executer (Self : Grt.Processes.Instance_Acc) + is + function To_Process_State_Acc is new Ada.Unchecked_Conversion + (Grt.Processes.Instance_Acc, Process_State_Acc); + + Process : Process_State_Acc renames + To_Process_State_Acc (Self); + begin + -- For debugger + Current_Process := Process; + + Instance_Pool := Process.Pool'Access; + + if Trace_Simulation then + Put (" run process: "); + Disp_Instance_Name (Process.Top_Instance); + Put_Line (" (" & Disp_Location (Process.Proc) & ")"); + end if; + + Execute_Sequential_Statements (Process); + + -- Sanity checks. + if not Is_Empty (Expr_Pool) then + raise Internal_Error; + end if; + + case Get_Kind (Process.Proc) is + when Iir_Kind_Sensitized_Process_Statement => + if Process.Instance.In_Wait_Flag then + raise Internal_Error; + end if; + if Process.Instance.Stmt = Null_Iir then + Process.Instance.Stmt := + Get_Sequential_Statement_Chain (Process.Proc); + end if; + when Iir_Kind_Process_Statement => + if not Process.Instance.In_Wait_Flag then + raise Internal_Error; + end if; + when others => + raise Internal_Error; + end case; + + Instance_Pool := null; + Current_Process := null; + end Process_Executer; + + type Convert_Mode is (Convert_In, Convert_Out); + + type Convert_Instance_Type is record + Mode : Convert_Mode; + Instance : Block_Instance_Acc; + Func : Iir; + Src : Iir_Value_Literal_Acc; + Dst : Iir_Value_Literal_Acc; + end record; + + type Convert_Instance_Acc is access Convert_Instance_Type; + + procedure Conversion_Proc (Data : System.Address) is + Conv : Convert_Instance_Type; + pragma Import (Ada, Conv); + for Conv'Address use Data; + + Src : Iir_Value_Literal_Acc; + Dst : Iir_Value_Literal_Acc; + + Expr_Mark : Mark_Type; + begin + pragma Assert (Instance_Pool = null); + Instance_Pool := Global_Pool'Access; + Mark (Expr_Mark, Expr_Pool); + Current_Process := No_Process; + + case Conv.Mode is + when Convert_In => + Src := Execute_Read_Signal_Value + (Conv.Src, Read_Signal_Effective_Value); + when Convert_Out => + Src := Execute_Read_Signal_Value + (Conv.Src, Read_Signal_Driving_Value); + end case; + + Dst := Execute_Assoc_Conversion (Conv.Instance, Conv.Func, Src); + + Check_Bounds (Conv.Dst, Dst, Conv.Func); + + case Conv.Mode is + when Convert_In => + Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Effective_Value); + when Convert_Out => + Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Driving_Value); + end case; + + Release (Expr_Mark, Expr_Pool); + Instance_Pool := null; + end Conversion_Proc; + + -- Add a driver for signal designed by VAL (via index field) for instance + -- INSTANCE of process PROC. + -- FIXME: default value. + procedure Add_Source + (Instance: Block_Instance_Acc; Val: Iir_Value_Literal_Acc; Proc: Iir) + is + begin + case Val.Kind is + when Iir_Value_Signal => + if Proc = Null_Iir then + -- Can this happen ? + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Process_Add_Driver (Val.Sig); + when Iir_Value_Array => + for I in Val.Val_Array.V'Range loop + Add_Source (Instance, Val.Val_Array.V (I), Proc); + end loop; + when Iir_Value_Record => + for I in Val.Val_Record.V'Range loop + Add_Source (Instance, Val.Val_Record.V (I), Proc); + end loop; + when others => + raise Internal_Error; + end case; + end Add_Source; + + -- Add drivers for process PROC. + -- Note: this is done recursively on the callees of PROC. + procedure Elaborate_Drivers (Instance: Block_Instance_Acc; Proc: Iir) + is + Driver_List: Iir_List; + It : List_Iterator; + El: Iir; + Val: Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + if Trace_Drivers then + Ada.Text_IO.Put ("Drivers for "); + Disp_Instance_Name (Instance); + Ada.Text_IO.Put_Line (": " & Disp_Node (Proc)); + end if; + + Driver_List := Trans_Analyzes.Extract_Drivers (Proc); + + -- Some processes have no driver list (assertion). + It := List_Iterate_Safe (Driver_List); + while Is_Valid (It) loop + El := Get_Element (It); + if Trace_Drivers then + Put_Line (' ' & Disp_Node (El)); + end if; + + Mark (Marker, Expr_Pool); + Val := Execute_Name (Instance, El, True); + Add_Source (Instance, Val, Proc); + Release (Marker, Expr_Pool); + + Next (It); + end loop; + end Elaborate_Drivers; + + -- Call Ghdl_Process_Add_Sensitivity for each scalar subelement of + -- SIG. + procedure Process_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) is + begin + case Sig.Kind is + when Iir_Value_Signal => + Grt.Processes.Ghdl_Process_Add_Sensitivity (Sig.Sig); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Process_Add_Sensitivity (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Record.V'Range loop + Process_Add_Sensitivity (Sig.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Process_Add_Sensitivity; + + procedure Register_Sensitivity + (Instance : Block_Instance_Acc; List : Iir_List) + is + It : List_Iterator; + Sig : Iir; + Marker : Mark_Type; + begin + It := List_Iterate (List); + while Is_Valid (It) loop + Sig := Get_Element (It); + Mark (Marker, Expr_Pool); + Process_Add_Sensitivity (Execute_Name (Instance, Sig, True)); + Release (Marker, Expr_Pool); + Next (It); + end loop; + end Register_Sensitivity; + + procedure Create_Processes + is + use Grt.Processes; + El : Iir; + Instance : Block_Instance_Acc; + Instance_Grt : Grt.Processes.Instance_Acc; + begin + Processes_State := new Process_State_Array (1 .. Processes_Table.Last); + + for I in Processes_Table.First .. Processes_Table.Last loop + Instance := Processes_Table.Table (I); + El := Instance.Label; + + Instance_Pool := Processes_State (I).Pool'Access; + Instance.Stmt := Get_Sequential_Statement_Chain (El); + + Processes_State (I).Top_Instance := Instance; + Processes_State (I).Proc := El; + Processes_State (I).Instance := Instance; + + Current_Process := Processes_State (I)'Access; + Instance_Grt := To_Instance_Acc (Processes_State (I)'Address); + case Get_Kind (El) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Postponed_Flag (El) then + Ghdl_Postponed_Sensitized_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + else + Ghdl_Sensitized_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + end if; + + -- Register sensitivity. + Register_Sensitivity (Instance, Get_Sensitivity_List (El)); + + when Iir_Kind_Process_Statement => + if Get_Postponed_Flag (El) then + Ghdl_Postponed_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + else + Ghdl_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + end if; + + when others => + raise Internal_Error; + end case; + + -- LRM93 §12.4.4 Other Concurrent Statements + -- All other concurrent statements are either process + -- statements or are statements for which there is an + -- equivalent process statement. + -- Elaboration of a process statement proceeds as follows: + -- 1. The process declarative part is elaborated. + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (El)); + + -- 2. The drivers required by the process statement + -- are created. + -- 3. The initial transaction defined by the default value + -- associated with each scalar signal driven by the + -- process statement is inserted into the corresponding + -- driver. + -- FIXME: do it for drivers in called subprograms too. + Elaborate_Drivers (Instance, El); + + if not Is_Empty (Expr_Pool) then + raise Internal_Error; + end if; + + -- Elaboration of all concurrent signal assignment + -- statements and concurrent assertion statements consists + -- of the construction of the equivalent process statement + -- followed by the elaboration of the equivalent process + -- statement. + -- [GHDL: this is done by canonicalize. ] + + -- FIXME: check passive statements, + -- check no wait statement in sensitized processes. + + Instance_Pool := null; + end loop; + + if Trace_Simulation then + Disp_Signals_Value; + end if; + end Create_Processes; + + procedure PSL_Process_Executer (Self : Grt.Processes.Instance_Acc); + pragma Convention (C, PSL_Process_Executer); + + function Execute_Psl_Expr (Instance : Block_Instance_Acc; + Expr : PSL_Node; + Eos : Boolean) + return Boolean + is + use PSL.Nodes; + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + declare + E : constant Iir := Get_HDL_Node (Expr); + Rtype : constant Iir := Get_Base_Type (Get_Type (E)); + Res : Iir_Value_Literal_Acc; + begin + Res := Execute_Expression (Instance, E); + if Rtype = Std_Package.Boolean_Type_Definition then + return Res.B1 = True; + elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then + return Res.E8 = 3 or Res.E8 = 7; -- 1 or H + else + Error_Kind ("execute_psl_expr", Expr); + end if; + end; + when N_True => + return True; + when N_EOS => + return Eos; + when N_Not_Bool => + return not Execute_Psl_Expr (Instance, Get_Boolean (Expr), Eos); + when N_And_Bool => + return Execute_Psl_Expr (Instance, Get_Left (Expr), Eos) + and Execute_Psl_Expr (Instance, Get_Right (Expr), Eos); + when N_Or_Bool => + return Execute_Psl_Expr (Instance, Get_Left (Expr), Eos) + or Execute_Psl_Expr (Instance, Get_Right (Expr), Eos); + when others => + Error_Kind ("execute_psl_expr", Expr); + end case; + end Execute_Psl_Expr; + + procedure PSL_Process_Executer (Self : Grt.Processes.Instance_Acc) + is + type PSL_Entry_Acc is access all PSL_Entry; + function To_PSL_Entry_Acc is new Ada.Unchecked_Conversion + (Grt.Processes.Instance_Acc, PSL_Entry_Acc); + + use PSL.NFAs; + + E : constant PSL_Entry_Acc := To_PSL_Entry_Acc (Self); + Nvec : Boolean_Vector (E.States.all'Range); + Marker : Mark_Type; + V : Boolean; + + NFA : PSL_NFA; + S : NFA_State; + S_Num : Nat32; + Ed : NFA_Edge; + Sd : NFA_State; + Sd_Num : Nat32; + begin + -- Exit now if already covered (never set for assertion). + if E.Done then + return; + end if; + + Instance_Pool := Global_Pool'Access; + Current_Process := No_Process; + + Mark (Marker, Expr_Pool); + V := Execute_Psl_Expr (E.Instance, Get_PSL_Clock (E.Stmt), False); + Release (Marker, Expr_Pool); + if V then + Nvec := (others => False); + if Get_Kind (E.Stmt) = Iir_Kind_Psl_Cover_Statement then + Nvec (0) := True; + end if; + + -- For each state: if set, evaluate all outgoing edges. + NFA := Get_PSL_NFA (E.Stmt); + S := Get_First_State (NFA); + while S /= No_State loop + S_Num := Get_State_Label (S); + + if E.States (S_Num) then + Ed := Get_First_Src_Edge (S); + while Ed /= No_Edge loop + Sd := Get_Edge_Dest (Ed); + Sd_Num := Get_State_Label (Sd); + + if not Nvec (Sd_Num) then + Mark (Marker, Expr_Pool); + V := Execute_Psl_Expr + (E.Instance, Get_Edge_Expr (Ed), False); + Release (Marker, Expr_Pool); + if V then + Nvec (Sd_Num) := True; + end if; + end if; + + Ed := Get_Next_Src_Edge (Ed); + end loop; + end if; + + S := Get_Next_State (S); + end loop; + + -- Check fail state. + S := Get_Final_State (NFA); + S_Num := Get_State_Label (S); + pragma Assert (S_Num = Get_PSL_Nbr_States (E.Stmt) - 1); + if Nvec (S_Num) then + case Get_Kind (E.Stmt) is + when Iir_Kind_Psl_Assert_Statement => + Execute_Failed_Assertion + (E.Instance, "psl assertion", E.Stmt, + "assertion violation", 2); + when Iir_Kind_Psl_Cover_Statement => + Execute_Failed_Assertion + (E.Instance, "psl cover", E.Stmt, + "sequence covered", 0); + E.Done := True; + when others => + Error_Kind ("PSL_Process_Executer", E.Stmt); + end case; + end if; + + E.States.all := Nvec; + end if; + + Instance_Pool := null; + Current_Process := null; + end PSL_Process_Executer; + + procedure Create_PSL is + begin + for I in PSL_Table.First .. PSL_Table.Last loop + declare + E : PSL_Entry renames PSL_Table.Table (I); + begin + -- Create the vector. + E.States := new Boolean_Vector' + (0 .. Get_PSL_Nbr_States (E.Stmt) - 1 => False); + E.States (0) := True; + + Grt.Processes.Ghdl_Process_Register + (To_Instance_Acc (E'Address), PSL_Process_Executer'Access, + null, System.Null_Address); + + Register_Sensitivity + (E.Instance, Get_PSL_Clock_Sensitivity (E.Stmt)); + end; + end loop; + + -- Finalizer ? + end Create_PSL; + + function Create_Shadow_Signal (Sig : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Val : Ghdl_Value_Ptr; + begin + case Sig.Kind is + when Iir_Value_Signal => + Val := new Value_Union; + case Sig.Sig.Mode is + when Mode_I64 => + Val.I64 := 0; + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_I64 + (Val, null, System.Null_Address)); + when Mode_B1 => + Val.B1 := False; + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_B1 + (Val, null, System.Null_Address)); + when Mode_E8 => + Val.E8 := 0; + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_E8 + (Val, null, System.Null_Address)); + when Mode_E32 => + Val.E32 := 0; + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_E32 + (Val, null, System.Null_Address)); + when Mode_F64 => + Val.F64 := 0.0; + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_F64 + (Val, null, System.Null_Address)); + when Mode_I32 => + raise Internal_Error; + end case; + when Iir_Value_Array => + declare + Res : Iir_Value_Literal_Acc; + begin + Res := Unshare_Bounds (Sig, Instance_Pool); + for I in Res.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Create_Shadow_Signal (Sig.Val_Array.V (I)); + end loop; + return Res; + end; + when Iir_Value_Record => + declare + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Record_Value + (Sig.Val_Record.Len, Instance_Pool); + for I in Res.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Create_Shadow_Signal (Sig.Val_Record.V (I)); + end loop; + return Res; + end; + when Iir_Value_Scalars + | Iir_Value_Access + | Iir_Value_Range + | Iir_Value_Protected + | Iir_Value_Terminal + | Iir_Value_Quantity + | Iir_Value_File + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Create_Shadow_Signal; + + function Get_Leftest_Signal (Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + case Val.Kind is + when Iir_Value_Signal => + return Val; + when Iir_Value_Array => + return Get_Leftest_Signal (Val.Val_Array.V (1)); + when Iir_Value_Record => + return Get_Leftest_Signal (Val.Val_Record.V (1)); + when others => + raise Internal_Error; + end case; + end Get_Leftest_Signal; + + procedure Add_Conversion (Conv : Convert_Instance_Acc) + is + Src_Left : Grt.Signals.Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst_Left : Grt.Signals.Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type; + begin + Conv.Src := Unshare_Bounds (Conv.Src, Instance_Pool); + Conv.Dst := Unshare_Bounds (Conv.Dst, Instance_Pool); + + Src_Left := Get_Leftest_Signal (Conv.Src).Sig; + Src_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Src)); + + Dst_Left := Get_Leftest_Signal (Conv.Dst).Sig; + Dst_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Dst)); + + case Conv.Mode is + when Convert_In => + Grt.Signals.Ghdl_Signal_In_Conversion (Conversion_Proc'Address, + Conv.all'Address, + Src_Left, Src_Len, + Dst_Left, Dst_Len); + when Convert_Out => + Grt.Signals.Ghdl_Signal_Out_Conversion (Conversion_Proc'Address, + Conv.all'Address, + Src_Left, Src_Len, + Dst_Left, Dst_Len); + end case; + end Add_Conversion; + + type Connect_Mode is (Connect_Source, Connect_Effective); + + -- Add a driving value PORT to signal SIG, ie: PORT is a source for SIG. + -- As a side effect, this connect the signal SIG with the port PORT. + -- PORT is the formal, while SIG is the actual. + procedure Connect (Sig: Iir_Value_Literal_Acc; + Port: Iir_Value_Literal_Acc; + Mode : Connect_Mode) + is + begin + case Sig.Kind is + when Iir_Value_Array => + if Port.Kind /= Sig.Kind then + raise Internal_Error; + end if; + + if Sig.Val_Array.Len /= Port.Val_Array.Len then + raise Internal_Error; + end if; + for I in Sig.Val_Array.V'Range loop + Connect (Sig.Val_Array.V (I), Port.Val_Array.V (I), Mode); + end loop; + return; + when Iir_Value_Record => + if Port.Kind /= Sig.Kind then + raise Internal_Error; + end if; + if Sig.Val_Record.Len /= Port.Val_Record.Len then + raise Internal_Error; + end if; + for I in Sig.Val_Record.V'Range loop + Connect (Sig.Val_Record.V (I), Port.Val_Record.V (I), Mode); + end loop; + return; + when Iir_Value_Signal => + pragma Assert (Port.Kind = Iir_Value_Signal); + -- Here, SIG and PORT are simple signals (not composite). + -- PORT is a source for SIG. + case Mode is + when Connect_Source => + Grt.Signals.Ghdl_Signal_Add_Source + (Sig.Sig, Port.Sig); + when Connect_Effective => + Grt.Signals.Ghdl_Signal_Effective_Value + (Port.Sig, Sig.Sig); + end case; + when Iir_Value_E32 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_E32 (Port.Sig, Sig.E32); + when Iir_Value_I64 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_I64 (Port.Sig, Sig.I64); + when Iir_Value_B1 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_B1 (Port.Sig, Sig.B1); + when Iir_Value_E8 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_E8 (Port.Sig, Sig.E8); + when others => + raise Internal_Error; + end case; + end Connect; + + procedure Set_Connect + (Formal_Instance : Block_Instance_Acc; + Formal_Expr : Iir_Value_Literal_Acc; + Local_Instance : Block_Instance_Acc; + Local_Expr : Iir_Value_Literal_Acc; + Inter : Iir; + Assoc : Iir_Association_Element_By_Expression) + is + pragma Unreferenced (Formal_Instance); + Formal : constant Iir := Get_Formal (Assoc); + begin + if False and Trace_Elaboration then + Put ("connect formal "); + Put (Iir_Mode'Image (Get_Mode (Inter))); + Put (" "); + Disp_Iir_Value (Formal_Expr, Get_Type (Formal)); + Put (" with actual "); + Disp_Iir_Value (Local_Expr, Get_Type (Get_Actual (Assoc))); + New_Line; + end if; + + case Get_Mode (Inter) is + when Iir_Out_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + -- FORMAL_EXPR is a source for LOCAL_EXPR. + declare + Out_Conv : constant Iir := Get_Formal_Conversion (Assoc); + Src : Iir_Value_Literal_Acc; + begin + if Out_Conv /= Null_Iir then + Src := Create_Shadow_Signal (Local_Expr); + Add_Conversion + (new Convert_Instance_Type' + (Mode => Convert_Out, + Instance => Local_Instance, + Func => Out_Conv, + Src => Formal_Expr, + Dst => Src)); + else + Src := Formal_Expr; + end if; + -- LRM93 §12.6.2 + -- A signal is said to be active [...] if one of its source + -- is active. + Connect (Local_Expr, Src, Connect_Source); + end; + + when Iir_In_Mode => + null; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + + case Get_Mode (Inter) is + when Iir_In_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + declare + In_Conv : constant Iir := Get_Actual_Conversion (Assoc); + Src : Iir_Value_Literal_Acc; + begin + if In_Conv /= Null_Iir then + Src := Create_Shadow_Signal (Formal_Expr); + Add_Conversion + (new Convert_Instance_Type' + (Mode => Convert_In, + Instance => Local_Instance, + Func => Get_Implementation (In_Conv), + Src => Local_Expr, + Dst => Src)); + else + Src := Local_Expr; + end if; + Connect (Src, Formal_Expr, Connect_Effective); + end; + when Iir_Out_Mode => + null; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + end Set_Connect; + + procedure Create_Connects is + begin + -- New signals may be created (because of conversions). + Instance_Pool := Global_Pool'Access; + + for I in Connect_Table.First .. Connect_Table.Last loop + declare + E : Connect_Entry renames Connect_Table.Table (I); + begin + Set_Connect (E.Formal_Instance, E.Formal, + E.Actual_Instance, E.Actual, + E.Inter, E.Assoc); + end; + end loop; + + Instance_Pool := null; + end Create_Connects; + + procedure Set_Disconnection (Val : Iir_Value_Literal_Acc; + Time : Iir_Value_Time) + is + begin + case Val.Kind is + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Set_Disconnect (Val.Sig, Std_Time (Time)); + when Iir_Value_Record => + for I in Val.Val_Record.V'Range loop + Set_Disconnection (Val.Val_Record.V (I), Time); + end loop; + when Iir_Value_Array => + for I in Val.Val_Array.V'Range loop + Set_Disconnection (Val.Val_Array.V (I), Time); + end loop; + when others => + raise Internal_Error; + end case; + end Set_Disconnection; + + procedure Create_Disconnections is + begin + for I in Disconnection_Table.First .. Disconnection_Table.Last loop + declare + E : Disconnection_Entry renames Disconnection_Table.Table (I); + begin + Set_Disconnection (E.Sig, E.Time); + end; + end loop; + end Create_Disconnections; + + procedure Create_Guard_Signal (Instance : Block_Instance_Acc; + Sig_Guard : Iir_Value_Literal_Acc; + Val_Guard : Iir_Value_Literal_Acc; + Guard : Iir) + is + procedure Add_Guard_Sensitivity (Sig : Iir_Value_Literal_Acc) is + begin + case Sig.Kind is + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Guard_Dependence (Sig.Sig); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Add_Guard_Sensitivity (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Record.V'Range loop + Add_Guard_Sensitivity (Sig.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Add_Guard_Sensitivity; + + Dep_List : Iir_List; + Dep_It : List_Iterator; + Dep : Iir; + Data : Guard_Instance_Acc; + begin + Data := new Guard_Instance_Type'(Instance => Instance, + Guard => Guard); + Sig_Guard.Sig := Grt.Signals.Ghdl_Signal_Create_Guard + (To_Ghdl_Value_Ptr (Val_Guard.B1'Address), + Data.all'Address, Guard_Func'Access); + Dep_List := Get_Guard_Sensitivity_List (Guard); + Dep_It := List_Iterate (Dep_List); + while Is_Valid (Dep_It) loop + Dep := Get_Element (Dep_It); + Add_Guard_Sensitivity (Execute_Name (Instance, Dep, True)); + Next (Dep_It); + end loop; + + -- FIXME: free mem + end Create_Guard_Signal; + + procedure Create_Implicit_Signal (Sig : Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc; + Time : Std_Time; + Prefix : Iir_Value_Literal_Acc; + Kind : Mode_Signal_Type) + is + procedure Register_Prefix (Pfx : Iir_Value_Literal_Acc) is + begin + case Pfx.Kind is + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix (Pfx.Sig); + when Iir_Value_Array => + for I in Pfx.Val_Array.V'Range loop + Register_Prefix (Pfx.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Pfx.Val_Record.V'Range loop + Register_Prefix (Pfx.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Register_Prefix; + begin + case Kind is + when Mode_Stable => + Sig.Sig := Grt.Signals.Ghdl_Create_Stable_Signal + (To_Ghdl_Value_Ptr (Val.B1'Address), Time); + when Mode_Quiet => + Sig.Sig := Grt.Signals.Ghdl_Create_Quiet_Signal + (To_Ghdl_Value_Ptr (Val.B1'Address), Time); + when Mode_Transaction => + Sig.Sig := Grt.Signals.Ghdl_Create_Transaction_Signal + (To_Ghdl_Value_Ptr (Val.B1'Address)); + when others => + raise Internal_Error; + end case; + Register_Prefix (Prefix); + end Create_Implicit_Signal; + + procedure Create_Delayed_Signal (Sig : Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc; + Pfx : Iir_Value_Literal_Acc; + Time : Std_Time) + is + Val_Ptr : Ghdl_Value_Ptr; + begin + case Pfx.Kind is + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Create_Delayed_Signal + (Sig.Val_Array.V (I), Val.Val_Array.V (I), + Pfx.Val_Array.V (I), Time); + end loop; + when Iir_Value_Record => + for I in Pfx.Val_Record.V'Range loop + Create_Delayed_Signal + (Sig.Val_Record.V (I), Val.Val_Record.V (I), + Pfx.Val_Array.V (I), Time); + end loop; + when Iir_Value_Signal => + case Iir_Value_Scalars (Val.Kind) is + when Iir_Value_I64 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.I64'Address); + when Iir_Value_E32 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.E32'Address); + when Iir_Value_F64 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.F64'Address); + when Iir_Value_B1 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.B1'Address); + when Iir_Value_E8 => + Val_Ptr := To_Ghdl_Value_Ptr (Val.E8'Address); + end case; + Sig.Sig := Grt.Signals.Ghdl_Create_Delayed_Signal + (Pfx.Sig, Val_Ptr, Time); + when others => + raise Internal_Error; + end case; + end Create_Delayed_Signal; + + -- Create a new signal, using DEFAULT as initial value. + -- Set its number. + procedure Create_User_Signal (Block: Block_Instance_Acc; + Mode : Mode_Signal_Type; + Signal: Iir; + Sig : Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc) + is + use Grt.Rtis; + use Grt.Signals; + + procedure Create_Signal (Val : Iir_Value_Literal_Acc; + Sig : Iir_Value_Literal_Acc; + Sig_Type: Iir; + Already_Resolved : Boolean) + is + Sub_Resolved : Boolean := Already_Resolved; + Resolv_Func : Iir; + Resolv_Instance : Resolv_Instance_Acc; + begin + if not Already_Resolved + and then Get_Kind (Sig_Type) in Iir_Kinds_Subtype_Definition + then + Resolv_Func := Get_Resolution_Indication (Sig_Type); + else + Resolv_Func := Null_Iir; + end if; + if Resolv_Func /= Null_Iir then + Sub_Resolved := True; + Resolv_Instance := new Resolv_Instance_Type' + (Func => Get_Named_Entity (Resolv_Func), + Block => Block, + Sig => Sig); + Grt.Signals.Ghdl_Signal_Create_Resolution + (Resolution_Proc'Access, + Resolv_Instance.all'Address, + System.Null_Address, + Ghdl_Index_Type (Get_Nbr_Of_Scalars (Val))); + end if; + case Val.Kind is + when Iir_Value_Array => + declare + Sig_El_Type : constant Iir := + Get_Element_Subtype (Get_Base_Type (Sig_Type)); + begin + for I in Val.Val_Array.V'Range loop + Create_Signal (Val.Val_Array.V (I), Sig.Val_Array.V (I), + Sig_El_Type, Sub_Resolved); + end loop; + end; + when Iir_Value_Record => + declare + List : constant Iir_Flist := Get_Elements_Declaration_List + (Get_Base_Type (Sig_Type)); + El : Iir_Element_Declaration; + begin + for I in Val.Val_Record.V'Range loop + El := Get_Nth_Element (List, Natural (I - 1)); + Create_Signal (Val.Val_Record.V (I), Sig.Val_Record.V (I), + Get_Type (El), Sub_Resolved); + end loop; + end; + + when Iir_Value_I64 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_I64 + (To_Ghdl_Value_Ptr (Val.I64'Address), + null, System.Null_Address); + when Iir_Value_B1 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_B1 + (To_Ghdl_Value_Ptr (Val.B1'Address), + null, System.Null_Address); + when Iir_Value_E8 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_E8 + (To_Ghdl_Value_Ptr (Val.E8'Address), + null, System.Null_Address); + when Iir_Value_E32 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_E32 + (To_Ghdl_Value_Ptr (Val.E32'Address), + null, System.Null_Address); + when Iir_Value_F64 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_F64 + (To_Ghdl_Value_Ptr (Val.F64'Address), + null, System.Null_Address); + + when Iir_Value_Signal + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Create_Signal; + + Sig_Type: constant Iir := Get_Type (Signal); + Kind : Kind_Signal_Type; + + type Iir_Kind_To_Kind_Signal_Type is + array (Iir_Signal_Kind) of Kind_Signal_Type; + Iir_Kind_To_Kind_Signal : constant Iir_Kind_To_Kind_Signal_Type := + (Iir_Register_Kind => Kind_Signal_Register, + Iir_Bus_Kind => Kind_Signal_Bus); + begin + if Get_Guarded_Signal_Flag (Signal) then + Kind := Iir_Kind_To_Kind_Signal (Get_Signal_Kind (Signal)); + else + Kind := Kind_Signal_No; + end if; + + Grt.Signals.Ghdl_Signal_Set_Mode (Mode, Kind, True); + + Create_Signal (Val, Sig, Sig_Type, False); + end Create_User_Signal; + + procedure Create_Signals is + begin + for I in Signals_Table.First .. Signals_Table.Last loop + declare + E : Signal_Entry renames Signals_Table.Table (I); + begin + case E.Kind is + when Mode_Guard => + Create_Guard_Signal (E.Instance, E.Sig, E.Val, E.Decl); + when Mode_Stable | Mode_Quiet | Mode_Transaction => + Create_Implicit_Signal + (E.Sig, E.Val, E.Time, E.Prefix, E.Kind); + when Mode_Delayed => + Create_Delayed_Signal (E.Sig, E.Val, E.Prefix, E.Time); + when Mode_Signal_User => + Create_User_Signal + (E.Instance, E.Kind, E.Decl, E.Sig, E.Val); + when Mode_Conv_In | Mode_Conv_Out | Mode_End => + raise Internal_Error; + end case; + end; + end loop; + end Create_Signals; + + procedure Ghdl_Elaborate is + begin + Elaboration.Elaborate_Design (Top_Config); + + if Disp_Stats then + Disp_Design_Stats; + end if; + + if Disp_Ams then + Debugger.AMS.Disp_Characteristic_Expressions; + end if; + + -- There is no inputs. + -- All the simulation is done via time, so it must be displayed. + Disp_Time_Before_Values := True; + + -- Initialisation. + if Trace_Simulation then + Put_Line ("Initialisation:"); + end if; + + Create_Signals; + Create_Connects; + Create_Disconnections; + Create_Processes; + Create_PSL; + + if Disp_Tree then + Debugger.Disp_Instances_Tree; + end if; + + if Flag_Interractive then + Debug (Reason_Elab); + end if; + end Ghdl_Elaborate; + + procedure Simulation_Entity (Top_Conf : Iir_Design_Unit) is + begin + Top_Config := Top_Conf; + + Grt.Errors.Error_Hook := Debug_Error'Access; + + if Flag_Interractive then + Debug (Reason_Start); + end if; + + Grt.Main.Run; + exception + when Debugger_Quit => + null; + when Simulation_Finished => + null; + end Simulation_Entity; +end Simul.Simulation.Main; diff --git a/src/vhdl/simulate/simul-simulation-main.ads b/src/vhdl/simulate/simul-simulation-main.ads new file mode 100644 index 000000000..28ed8ca08 --- /dev/null +++ b/src/vhdl/simulate/simul-simulation-main.ads @@ -0,0 +1,4 @@ +package Simul.Simulation.Main is + -- The entry point of the simulator. + procedure Simulation_Entity (Top_Conf : Iir_Design_Unit); +end Simul.Simulation.Main; diff --git a/src/vhdl/simulate/simul-simulation.adb b/src/vhdl/simulate/simul-simulation.adb new file mode 100644 index 000000000..cc8c4aa51 --- /dev/null +++ b/src/vhdl/simulate/simul-simulation.adb @@ -0,0 +1,716 @@ +-- 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 Types; use Types; +with Simul.Execution; use Simul.Execution; +with Areapools; use Areapools; +with Grt.Signals; +with Grt.Processes; +with Grtlink; +pragma Unreferenced (Grtlink); + +package body Simul.Simulation is + + function Value_To_Iir_Value (Mode : Mode_Type; Val : Value_Union) + return Iir_Value_Literal_Acc is + begin + case Mode is + when Mode_B1 => + return Create_B1_Value (Val.B1); + when Mode_E8 => + return Create_E8_Value (Val.E8); + when Mode_E32 => + return Create_E32_Value (Val.E32); + when Mode_I64 => + return Create_I64_Value (Val.I64); + when Mode_F64 => + return Create_F64_Value (Val.F64); + when others => + raise Internal_Error; -- FIXME + end case; + end Value_To_Iir_Value; + + procedure Iir_Value_To_Value (Src : Iir_Value_Literal_Acc; + Dst : out Value_Union) is + begin + case Iir_Value_Scalars (Src.Kind) is + when Iir_Value_B1 => + Dst.B1 := Src.B1; + when Iir_Value_E8 => + Dst.E8 := Src.E8; + when Iir_Value_E32 => + Dst.E32 := Src.E32; + when Iir_Value_I64 => + Dst.I64 := Src.I64; + when Iir_Value_F64 => + Dst.F64 := Src.F64; + end case; + end Iir_Value_To_Value; + + type Read_Signal_Flag_Enum is + (Read_Signal_Event, + Read_Signal_Active, + -- In order to reuse the same code (that returns immediately if the + -- attribute is true), we use not driving. + Read_Signal_Not_Driving); + + function Read_Signal_Flag (Lit: Iir_Value_Literal_Acc; + Kind : Read_Signal_Flag_Enum) + return Boolean + is + begin + case Lit.Kind is + when Iir_Value_Array => + for I in Lit.Val_Array.V'Range loop + if Read_Signal_Flag (Lit.Val_Array.V (I), Kind) then + return True; + end if; + end loop; + return False; + when Iir_Value_Record => + for I in Lit.Val_Record.V'Range loop + if Read_Signal_Flag (Lit.Val_Record.V (I), Kind) then + return True; + end if; + end loop; + return False; + when Iir_Value_Signal => + case Kind is + when Read_Signal_Event => + return Lit.Sig.Event; + when Read_Signal_Active => + return Lit.Sig.Active; + when Read_Signal_Not_Driving => + if Grt.Signals.Ghdl_Signal_Driving (Lit.Sig) = True then + return False; + else + return True; + end if; + end case; + when others => + raise Internal_Error; + end case; + end Read_Signal_Flag; + + function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return Read_Signal_Flag (Lit, Read_Signal_Event); + end Execute_Event_Attribute; + + function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return Read_Signal_Flag (Lit, Read_Signal_Active); + end Execute_Active_Attribute; + + function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean is + begin + return not Read_Signal_Flag (Lit, Read_Signal_Not_Driving); + end Execute_Driving_Attribute; + + function Execute_Read_Signal_Value + (Sig: Iir_Value_Literal_Acc; Attr : Read_Signal_Value_Enum) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Sig.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Sig); + for I in Sig.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Read_Signal_Value (Sig.Val_Array.V (I), Attr); + end loop; + return Res; + when Iir_Value_Record => + Res := Create_Record_Value (Sig.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Execute_Read_Signal_Value (Sig.Val_Record.V (I), Attr); + end loop; + return Res; + when Iir_Value_Signal => + case Attr is + when Read_Signal_Last_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Last_Value); + when Read_Signal_Driver_Value => + case Sig.Sig.Mode is + when Mode_F64 => + return Create_F64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_F64 + (Sig.Sig)); + when Mode_I64 => + return Create_I64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_I64 + (Sig.Sig)); + when Mode_E32 => + return Create_E32_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_E32 + (Sig.Sig)); + when Mode_B1 => + return Create_B1_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_B1 + (Sig.Sig)); + when others => + raise Internal_Error; + end case; + when Read_Signal_Effective_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Value_Ptr.all); + when Read_Signal_Driving_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Driving_Value); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Read_Signal_Value; + + procedure Execute_Write_Signal (Sig: Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc; + Attr : Write_Signal_Enum) is + begin + case Sig.Kind is + when Iir_Value_Array => + pragma Assert (Val.Kind = Iir_Value_Array); + pragma Assert (Sig.Val_Array.Len = Val.Val_Array.Len); + for I in Sig.Val_Array.V'Range loop + Execute_Write_Signal + (Sig.Val_Array.V (I), Val.Val_Array.V (I), Attr); + end loop; + when Iir_Value_Record => + pragma Assert (Val.Kind = Iir_Value_Record); + pragma Assert (Sig.Val_Record.Len = Val.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Execute_Write_Signal + (Sig.Val_Record.V (I), Val.Val_Record.V (I), Attr); + end loop; + when Iir_Value_Signal => + pragma Assert (Val.Kind in Iir_Value_Scalars); + case Attr is + when Write_Signal_Driving_Value => + Iir_Value_To_Value (Val, Sig.Sig.Driving_Value); + when Write_Signal_Effective_Value => + Iir_Value_To_Value (Val, Sig.Sig.Value_Ptr.all); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Write_Signal; + + function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Execute_Read_Signal_Value (Indirect, Read_Signal_Last_Value); + end Execute_Last_Value_Attribute; + + function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Execute_Read_Signal_Value (Indirect, Read_Signal_Driver_Value); + end Execute_Driving_Value_Attribute; + + type Signal_Read_Last_Type is + (Read_Last_Event, + Read_Last_Active); + + -- Return the Last_Event absolute time. + function Execute_Read_Signal_Last (Indirect: Iir_Value_Literal_Acc; + Kind : Signal_Read_Last_Type) + return Ghdl_I64 + is + Res: Ghdl_I64; + begin + case Indirect.Kind is + when Iir_Value_Array => + Res := Ghdl_I64'First; + for I in Indirect.Val_Array.V'Range loop + Res := Ghdl_I64'Max + (Res, Execute_Read_Signal_Last (Indirect.Val_Array.V (I), + Kind)); + end loop; + return Res; + when Iir_Value_Record => + Res := Ghdl_I64'First; + for I in Indirect.Val_Record.V'Range loop + Res := Ghdl_I64'Max + (Res, Execute_Read_Signal_Last (Indirect.Val_Record.V (I), + Kind)); + end loop; + return Res; + when Iir_Value_Signal => + case Kind is + when Read_Last_Event => + return Ghdl_I64 (Indirect.Sig.Last_Event); + when Read_Last_Active => + return Ghdl_I64 (Indirect.Sig.Last_Active); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Read_Signal_Last; + + function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64 is + begin + return Execute_Read_Signal_Last (Indirect, Read_Last_Event); + end Execute_Last_Event_Attribute; + + function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64 is + begin + return Execute_Read_Signal_Last (Indirect, Read_Last_Active); + end Execute_Last_Active_Attribute; + + function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Indirect.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Indirect); + for I in Indirect.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Signal_Value (Indirect.Val_Array.V (I)); + end loop; + return Res; + when Iir_Value_Record => + Res := Create_Record_Value (Indirect.Val_Record.Len); + for I in Indirect.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Execute_Signal_Value (Indirect.Val_Record.V (I)); + end loop; + return Res; + when Iir_Value_Signal => + return Value_To_Iir_Value + (Indirect.Sig.Mode, Indirect.Sig.Value_Ptr.all); + when others => + raise Internal_Error; + end case; + end Execute_Signal_Value; + + procedure Assign_Value_To_Array_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + Sub_Trans : Transaction_Type (Transactions.Len); + begin + Sub_Trans.Stmt := Transactions.Stmt; + Sub_Trans.Reject := Transactions.Reject; + + for J in Target.Val_Array.V'Range loop + for K in Transactions.Els'Range loop + declare + T : Transaction_El_Type renames Transactions.Els (K); + S : Transaction_El_Type renames Sub_Trans.Els (K); + begin + S.After := T.After; + + if T.Value = null then + S.Value := null; + else + S.Value := T.Value.Val_Array.V (J); + end if; + end; + end loop; + + Assign_Value_To_Signal + (Instance, Target.Val_Array.V (J), Sub_Trans); + end loop; + end Assign_Value_To_Array_Signal; + + procedure Assign_Value_To_Record_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + Sub_Trans : Transaction_Type (Transactions.Len); + begin + Sub_Trans.Stmt := Transactions.Stmt; + Sub_Trans.Reject := Transactions.Reject; + + for J in Target.Val_Record.V'Range loop + for K in Transactions.Els'Range loop + declare + T : Transaction_El_Type renames Transactions.Els (K); + S : Transaction_El_Type renames Sub_Trans.Els (K); + begin + S.After := T.After; + + if T.Value = null then + S.Value := null; + else + S.Value := T.Value.Val_Record.V (J); + end if; + end; + end loop; + + Assign_Value_To_Signal + (Instance, Target.Val_Record.V (J), Sub_Trans); + end loop; + end Assign_Value_To_Record_Signal; + + procedure Assign_Value_To_Scalar_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transactions: Transaction_Type) + is + pragma Unreferenced (Instance); + use Grt.Signals; + begin + declare + El : Transaction_El_Type renames Transactions.Els (1); + begin + if El.Value = null then + Ghdl_Signal_Start_Assign_Null + (Target.Sig, Transactions.Reject, El.After); + if Transactions.Els'Last /= 1 then + raise Internal_Error; + end if; + return; + end if; + + -- FIXME: null transaction, check constraints. + case Iir_Value_Scalars (El.Value.Kind) is + when Iir_Value_B1 => + Ghdl_Signal_Start_Assign_B1 + (Target.Sig, Transactions.Reject, El.Value.B1, El.After); + when Iir_Value_E8 => + Ghdl_Signal_Start_Assign_E8 + (Target.Sig, Transactions.Reject, El.Value.E8, El.After); + when Iir_Value_E32 => + Ghdl_Signal_Start_Assign_E32 + (Target.Sig, Transactions.Reject, El.Value.E32, El.After); + when Iir_Value_I64 => + Ghdl_Signal_Start_Assign_I64 + (Target.Sig, Transactions.Reject, El.Value.I64, El.After); + when Iir_Value_F64 => + Ghdl_Signal_Start_Assign_F64 + (Target.Sig, Transactions.Reject, El.Value.F64, El.After); + end case; + end; + + for I in 2 .. Transactions.Els'Last loop + declare + El : Transaction_El_Type renames Transactions.Els (I); + begin + case Iir_Value_Scalars (El.Value.Kind) is + when Iir_Value_B1 => + Ghdl_Signal_Next_Assign_B1 + (Target.Sig, El.Value.B1, El.After); + when Iir_Value_E8 => + Ghdl_Signal_Next_Assign_E8 + (Target.Sig, El.Value.E8, El.After); + when Iir_Value_E32 => + Ghdl_Signal_Next_Assign_E32 + (Target.Sig, El.Value.E32, El.After); + when Iir_Value_I64 => + Ghdl_Signal_Next_Assign_I64 + (Target.Sig, El.Value.I64, El.After); + when Iir_Value_F64 => + Ghdl_Signal_Next_Assign_F64 + (Target.Sig, El.Value.F64, El.After); + end case; + end; + end loop; + end Assign_Value_To_Scalar_Signal; + + procedure Assign_Value_To_Signal + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transaction: Transaction_Type) + is + begin + case Target.Kind is + when Iir_Value_Array => + Assign_Value_To_Array_Signal + (Instance, Target, Transaction); + when Iir_Value_Record => + Assign_Value_To_Record_Signal + (Instance, Target, Transaction); + when Iir_Value_Signal => + Assign_Value_To_Scalar_Signal + (Instance, Target, Transaction); + when Iir_Value_Scalars + | Iir_Value_Range + | Iir_Value_File + | Iir_Value_Access + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal + | Iir_Value_Environment => + raise Internal_Error; + end case; + end Assign_Value_To_Signal; + + procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc) is + begin + case Sig.Kind is + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Disconnect_Signal (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Array.V'Range loop + Disconnect_Signal (Sig.Val_Record.V (I)); + end loop; + when Iir_Value_Signal => + Grt.Signals.Ghdl_Signal_Disconnect (Sig.Sig); + when others => + raise Internal_Error; + end case; + end Disconnect_Signal; + + -- Call Ghdl_Process_Wait_Add_Sensitivity for each scalar subelement of + -- SIG. + procedure Wait_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) + is + begin + case Sig.Kind is + when Iir_Value_Signal => + Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity (Sig.Sig); + when Iir_Value_Array => + for I in Sig.Val_Array.V'Range loop + Wait_Add_Sensitivity (Sig.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Sig.Val_Record.V'Range loop + Wait_Add_Sensitivity (Sig.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Wait_Add_Sensitivity; + + -- Return true if the process should be suspended. + function Execute_Wait_Statement (Instance : Block_Instance_Acc; + Stmt: Iir_Wait_Statement) + return Boolean + is + Expr: Iir; + El : Iir; + List: Iir_List; + It : List_Iterator; + Res: Iir_Value_Literal_Acc; + Status : Boolean; + Marker : Mark_Type; + begin + if not Instance.In_Wait_Flag then + Mark (Marker, Expr_Pool); + + -- LRM93 8.1 + -- The execution of a wait statement causes the time expression to + -- be evaluated to determine the timeout interval. + Expr := Get_Timeout_Clause (Stmt); + if Expr /= Null_Iir then + Res := Execute_Expression (Instance, Expr); + Grt.Processes.Ghdl_Process_Wait_Set_Timeout + (Std_Time (Res.I64), null, 0); + end if; + + -- LRM93 8.1 + -- The suspended process may also resume as a result of an event + -- occuring on any signal in the sensitivity set of the wait + -- statement. + List := Get_Sensitivity_List (Stmt); + It := List_Iterate_Safe (List); + while Is_Valid (It) loop + El := Get_Element (It); + Wait_Add_Sensitivity (Execute_Name (Instance, El, True)); + Next (It); + end loop; + + -- LRM93 8.1 + -- It also causes the execution of the corresponding process + -- statement to be suspended. + Grt.Processes.Ghdl_Process_Wait_Suspend; + Instance.In_Wait_Flag := True; + Release (Marker, Expr_Pool); + return True; + else + -- LRM93 8.1 + -- The suspended process will resume, at the latest, immediately + -- after the timeout interval has expired. + if not Grt.Processes.Ghdl_Process_Wait_Timed_Out then + -- Compute the condition clause only if the timeout has not + -- expired. + + -- LRM93 8.1 + -- If such an event occurs, the condition in the condition clause + -- is evaluated. + -- + -- if no condition clause appears, the condition clause until true + -- is assumed. + Status := + Execute_Condition (Instance, Get_Condition_Clause (Stmt)); + if not Status then + -- LRM93 8.1 + -- If the value of the condition is FALSE, the process will + -- re-suspend. + -- Such re-suspension does not involve the recalculation of + -- the timeout interval. + Grt.Processes.Ghdl_Process_Wait_Suspend; + return True; + end if; + end if; + + -- LRM93 8.1 + -- If the value of the condition is TRUE, the process will resume. + -- next statement. + Grt.Processes.Ghdl_Process_Wait_Close; + + Instance.In_Wait_Flag := False; + return False; + end if; + end Execute_Wait_Statement; + + type Resolver_Read_Mode is (Read_Port, Read_Driver); + + function Resolver_Read_Value (Sig : Iir_Value_Literal_Acc; + Mode : Resolver_Read_Mode; + Index : Ghdl_Index_Type) + return Iir_Value_Literal_Acc + is + use Grt.Signals; + Val : Ghdl_Value_Ptr; + Res : Iir_Value_Literal_Acc; + begin + case Sig.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Sig); + for I in Sig.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Resolver_Read_Value (Sig.Val_Array.V (I), Mode, Index); + end loop; + when Iir_Value_Record => + Res := Create_Record_Value (Sig.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Resolver_Read_Value (Sig.Val_Record.V (I), Mode, Index); + end loop; + when Iir_Value_Signal => + case Mode is + when Read_Port => + Val := Ghdl_Signal_Read_Port (Sig.Sig, Index); + when Read_Driver => + Val := Ghdl_Signal_Read_Driver (Sig.Sig, Index); + end case; + Res := Value_To_Iir_Value (Sig.Sig.Mode, Val.all); + when others => + raise Internal_Error; + end case; + return Res; + end Resolver_Read_Value; + + procedure Resolution_Proc (Instance_Addr : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type) + is + pragma Unreferenced (Val); + + Instance : Resolv_Instance_Type; + pragma Import (Ada, Instance); + for Instance'Address use Instance_Addr; + + type Bool_Array is array (1 .. Nbr_Drv) of Boolean; + Vec : Bool_Array; + pragma Import (Ada, Vec); + for Vec'Address use Bool_Vec; + Off : Iir_Index32; + + Arr : Iir_Value_Literal_Acc; + Arr_Type : constant Iir := + Get_Type (Get_Interface_Declaration_Chain (Instance.Func)); + + Res : Iir_Value_Literal_Acc; + + Len : constant Iir_Index32 := Iir_Index32 (Vec_Len + Nbr_Ports); + Instance_Mark, Expr_Mark : Mark_Type; + begin + pragma Assert (Instance_Pool = null); + Instance_Pool := Global_Pool'Access; + Mark (Instance_Mark, Instance_Pool.all); + Mark (Expr_Mark, Expr_Pool); + Current_Process := No_Process; + + Arr := Create_Array_Value (Len, 1); + Arr.Bounds.D (1) := Create_Bounds_From_Length + (Instance.Block, + Get_Nth_Element (Get_Index_Subtype_List (Arr_Type), 0), + Len); + + -- First ports + for I in 1 .. Nbr_Ports loop + Arr.Val_Array.V (Iir_Index32 (I)) := Resolver_Read_Value + (Instance.Sig, Read_Port, I - 1); + end loop; + + -- Then drivers. + Off := Iir_Index32 (Nbr_Ports) + 1; + for I in 1 .. Nbr_Drv loop + if Vec (I) then + Arr.Val_Array.V (Off) := Resolver_Read_Value + (Instance.Sig, Read_Driver, I - 1); + Off := Off + 1; + end if; + end loop; + + -- Call resolution function. + Res := Execute_Resolution_Function (Instance.Block, Instance.Func, Arr); + + -- Set driving value. + Execute_Write_Signal (Instance.Sig, Res, Write_Signal_Driving_Value); + + Release (Instance_Mark, Instance_Pool.all); + Release (Expr_Mark, Expr_Pool); + Instance_Pool := null; + end Resolution_Proc; + + function Guard_Func (Data : System.Address) return Ghdl_B1 + is + Guard : Guard_Instance_Type; + pragma Import (Ada, Guard); + for Guard'Address use Data; + + Val : Boolean; + + Prev_Instance_Pool : Areapool_Acc; + begin + pragma Assert (Instance_Pool = null + or else Instance_Pool = Global_Pool'Access); + Prev_Instance_Pool := Instance_Pool; + + Instance_Pool := Global_Pool'Access; + Current_Process := No_Process; + + Val := Execute_Condition + (Guard.Instance, Get_Guard_Expression (Guard.Guard)); + + Instance_Pool := Prev_Instance_Pool; + + return Ghdl_B1'Val (Boolean'Pos (Val)); + end Guard_Func; +end Simul.Simulation; diff --git a/src/vhdl/simulate/simul-simulation.ads b/src/vhdl/simulate/simul-simulation.ads new file mode 100644 index 000000000..5ab01a6ff --- /dev/null +++ b/src/vhdl/simulate/simul-simulation.ads @@ -0,0 +1,136 @@ +-- 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 System; +with Grt.Types; use Grt.Types; +with Iirs; use Iirs; +with Simul.Environments; use Simul.Environments; + +package Simul.Simulation is + Trace_Simulation : Boolean := False; + Disp_Tree : Boolean := False; + Disp_Stats : Boolean := False; + Disp_Ams : Boolean := False; + + type Resolv_Instance_Type is record + Func : Iir; + Block : Block_Instance_Acc; + Sig : Iir_Value_Literal_Acc; + end record; + type Resolv_Instance_Acc is access Resolv_Instance_Type; + + -- The resolution procedure for GRT. + procedure Resolution_Proc (Instance_Addr : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type); + pragma Convention (C, Resolution_Proc); + + type Guard_Instance_Type is record + Instance : Block_Instance_Acc; + Guard : Iir; + end record; + + type Guard_Instance_Acc is access Guard_Instance_Type; + + function Guard_Func (Data : System.Address) return Ghdl_B1; + pragma Convention (C, Guard_Func); + + function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean; + + function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean; + function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc) + return Boolean; + + function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc; + + -- Return the Last_Event absolute time. + function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64; + function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc) + return Ghdl_I64; + + -- Type for a transaction: it contains the value, the absolute time at which + -- the transaction should occur and a pointer to the next transaction. + -- This constitute a simple linked list, the elements must be ordered + -- according to time. + type Transaction_El_Type is record + -- The value of the waveform element. + -- Can't be an array. + -- Life must be target. + Value: Iir_Value_Literal_Acc; + + -- After time at which the transaction should occur. + After : Grt.Types.Std_Time; + end record; + + type Transaction_Array is array (Natural range <>) of Transaction_El_Type; + + type Transaction_Type (Len : Natural) is record + -- Statement that created this transaction. Used to disp location + -- in case of error (constraint error). + Stmt: Iir; + + Reject : Std_Time; + + Els : Transaction_Array (1 .. Len); + end record; + + procedure Assign_Value_To_Signal (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Transaction: Transaction_Type); + + procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc); + + -- Return true if the process should be suspended. + function Execute_Wait_Statement (Instance : Block_Instance_Acc; + Stmt: Iir_Wait_Statement) + return Boolean; +private + type Read_Signal_Value_Enum is + (Read_Signal_Last_Value, + + -- For conversion functions. + Read_Signal_Driving_Value, + Read_Signal_Effective_Value, + + -- 'Driving_Value + Read_Signal_Driver_Value); + + function Execute_Read_Signal_Value (Sig: Iir_Value_Literal_Acc; + Attr : Read_Signal_Value_Enum) + return Iir_Value_Literal_Acc; + + type Write_Signal_Enum is + (Write_Signal_Driving_Value, + Write_Signal_Effective_Value); + + procedure Execute_Write_Signal (Sig: Iir_Value_Literal_Acc; + Val : Iir_Value_Literal_Acc; + Attr : Write_Signal_Enum); +end Simul.Simulation; diff --git a/src/vhdl/simulate/simul.ads b/src/vhdl/simulate/simul.ads new file mode 100644 index 000000000..6685959c5 --- /dev/null +++ b/src/vhdl/simulate/simul.ads @@ -0,0 +1,21 @@ +-- Interpreted simulation base package. +-- Copyright (C) 2017 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. + +package Simul is + pragma Pure (Simul); +end Simul; diff --git a/src/vhdl/simulate/simulation-main.adb b/src/vhdl/simulate/simulation-main.adb deleted file mode 100644 index 7c68d0b68..000000000 --- a/src/vhdl/simulate/simulation-main.adb +++ /dev/null @@ -1,1145 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014-2017 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 Types; use Types; -with Iirs_Utils; use Iirs_Utils; -with Errorout; use Errorout; -with PSL.Nodes; -with PSL.NFAs; -with Std_Package; -with Trans_Analyzes; -with Elaboration; use Elaboration; -with Execution; use Execution; -with Ieee.Std_Logic_1164; -with Grt.Main; -with Debugger; use Debugger; -with Debugger.AMS; -with Grt.Errors; -with Grt.Rtis; -with Grt.Processes; -with Grt.Signals; -with Areapools; use Areapools; - -package body Simulation.Main is - -- Configuration for the whole design - Top_Config : Iir_Design_Unit; - - -- Elaborate the design - procedure Ghdl_Elaborate; - pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); - - function To_Instance_Acc is new Ada.Unchecked_Conversion - (System.Address, Grt.Processes.Instance_Acc); - - procedure Process_Executer (Self : Grt.Processes.Instance_Acc); - pragma Convention (C, Process_Executer); - - procedure Process_Executer (Self : Grt.Processes.Instance_Acc) - is - function To_Process_State_Acc is new Ada.Unchecked_Conversion - (Grt.Processes.Instance_Acc, Process_State_Acc); - - Process : Process_State_Acc renames - To_Process_State_Acc (Self); - begin - -- For debugger - Current_Process := Process; - - Instance_Pool := Process.Pool'Access; - - if Trace_Simulation then - Put (" run process: "); - Disp_Instance_Name (Process.Top_Instance); - Put_Line (" (" & Disp_Location (Process.Proc) & ")"); - end if; - - Execute_Sequential_Statements (Process); - - -- Sanity checks. - if not Is_Empty (Expr_Pool) then - raise Internal_Error; - end if; - - case Get_Kind (Process.Proc) is - when Iir_Kind_Sensitized_Process_Statement => - if Process.Instance.In_Wait_Flag then - raise Internal_Error; - end if; - if Process.Instance.Stmt = Null_Iir then - Process.Instance.Stmt := - Get_Sequential_Statement_Chain (Process.Proc); - end if; - when Iir_Kind_Process_Statement => - if not Process.Instance.In_Wait_Flag then - raise Internal_Error; - end if; - when others => - raise Internal_Error; - end case; - - Instance_Pool := null; - Current_Process := null; - end Process_Executer; - - type Convert_Mode is (Convert_In, Convert_Out); - - type Convert_Instance_Type is record - Mode : Convert_Mode; - Instance : Block_Instance_Acc; - Func : Iir; - Src : Iir_Value_Literal_Acc; - Dst : Iir_Value_Literal_Acc; - end record; - - type Convert_Instance_Acc is access Convert_Instance_Type; - - procedure Conversion_Proc (Data : System.Address) is - Conv : Convert_Instance_Type; - pragma Import (Ada, Conv); - for Conv'Address use Data; - - Src : Iir_Value_Literal_Acc; - Dst : Iir_Value_Literal_Acc; - - Expr_Mark : Mark_Type; - begin - pragma Assert (Instance_Pool = null); - Instance_Pool := Global_Pool'Access; - Mark (Expr_Mark, Expr_Pool); - Current_Process := No_Process; - - case Conv.Mode is - when Convert_In => - Src := Execute_Read_Signal_Value - (Conv.Src, Read_Signal_Effective_Value); - when Convert_Out => - Src := Execute_Read_Signal_Value - (Conv.Src, Read_Signal_Driving_Value); - end case; - - Dst := Execute_Assoc_Conversion (Conv.Instance, Conv.Func, Src); - - Check_Bounds (Conv.Dst, Dst, Conv.Func); - - case Conv.Mode is - when Convert_In => - Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Effective_Value); - when Convert_Out => - Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Driving_Value); - end case; - - Release (Expr_Mark, Expr_Pool); - Instance_Pool := null; - end Conversion_Proc; - - -- Add a driver for signal designed by VAL (via index field) for instance - -- INSTANCE of process PROC. - -- FIXME: default value. - procedure Add_Source - (Instance: Block_Instance_Acc; Val: Iir_Value_Literal_Acc; Proc: Iir) - is - begin - case Val.Kind is - when Iir_Value_Signal => - if Proc = Null_Iir then - -- Can this happen ? - raise Internal_Error; - end if; - Grt.Signals.Ghdl_Process_Add_Driver (Val.Sig); - when Iir_Value_Array => - for I in Val.Val_Array.V'Range loop - Add_Source (Instance, Val.Val_Array.V (I), Proc); - end loop; - when Iir_Value_Record => - for I in Val.Val_Record.V'Range loop - Add_Source (Instance, Val.Val_Record.V (I), Proc); - end loop; - when others => - raise Internal_Error; - end case; - end Add_Source; - - -- Add drivers for process PROC. - -- Note: this is done recursively on the callees of PROC. - procedure Elaborate_Drivers (Instance: Block_Instance_Acc; Proc: Iir) - is - Driver_List: Iir_List; - It : List_Iterator; - El: Iir; - Val: Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - if Trace_Drivers then - Ada.Text_IO.Put ("Drivers for "); - Disp_Instance_Name (Instance); - Ada.Text_IO.Put_Line (": " & Disp_Node (Proc)); - end if; - - Driver_List := Trans_Analyzes.Extract_Drivers (Proc); - - -- Some processes have no driver list (assertion). - It := List_Iterate_Safe (Driver_List); - while Is_Valid (It) loop - El := Get_Element (It); - if Trace_Drivers then - Put_Line (' ' & Disp_Node (El)); - end if; - - Mark (Marker, Expr_Pool); - Val := Execute_Name (Instance, El, True); - Add_Source (Instance, Val, Proc); - Release (Marker, Expr_Pool); - - Next (It); - end loop; - end Elaborate_Drivers; - - -- Call Ghdl_Process_Add_Sensitivity for each scalar subelement of - -- SIG. - procedure Process_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) is - begin - case Sig.Kind is - when Iir_Value_Signal => - Grt.Processes.Ghdl_Process_Add_Sensitivity (Sig.Sig); - when Iir_Value_Array => - for I in Sig.Val_Array.V'Range loop - Process_Add_Sensitivity (Sig.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - for I in Sig.Val_Record.V'Range loop - Process_Add_Sensitivity (Sig.Val_Record.V (I)); - end loop; - when others => - raise Internal_Error; - end case; - end Process_Add_Sensitivity; - - procedure Register_Sensitivity - (Instance : Block_Instance_Acc; List : Iir_List) - is - It : List_Iterator; - Sig : Iir; - Marker : Mark_Type; - begin - It := List_Iterate (List); - while Is_Valid (It) loop - Sig := Get_Element (It); - Mark (Marker, Expr_Pool); - Process_Add_Sensitivity (Execute_Name (Instance, Sig, True)); - Release (Marker, Expr_Pool); - Next (It); - end loop; - end Register_Sensitivity; - - procedure Create_Processes - is - use Grt.Processes; - El : Iir; - Instance : Block_Instance_Acc; - Instance_Grt : Grt.Processes.Instance_Acc; - begin - Processes_State := new Process_State_Array (1 .. Processes_Table.Last); - - for I in Processes_Table.First .. Processes_Table.Last loop - Instance := Processes_Table.Table (I); - El := Instance.Label; - - Instance_Pool := Processes_State (I).Pool'Access; - Instance.Stmt := Get_Sequential_Statement_Chain (El); - - Processes_State (I).Top_Instance := Instance; - Processes_State (I).Proc := El; - Processes_State (I).Instance := Instance; - - Current_Process := Processes_State (I)'Access; - Instance_Grt := To_Instance_Acc (Processes_State (I)'Address); - case Get_Kind (El) is - when Iir_Kind_Sensitized_Process_Statement => - if Get_Postponed_Flag (El) then - Ghdl_Postponed_Sensitized_Process_Register - (Instance_Grt, - Process_Executer'Access, - null, System.Null_Address); - else - Ghdl_Sensitized_Process_Register - (Instance_Grt, - Process_Executer'Access, - null, System.Null_Address); - end if; - - -- Register sensitivity. - Register_Sensitivity (Instance, Get_Sensitivity_List (El)); - - when Iir_Kind_Process_Statement => - if Get_Postponed_Flag (El) then - Ghdl_Postponed_Process_Register - (Instance_Grt, - Process_Executer'Access, - null, System.Null_Address); - else - Ghdl_Process_Register - (Instance_Grt, - Process_Executer'Access, - null, System.Null_Address); - end if; - - when others => - raise Internal_Error; - end case; - - -- LRM93 §12.4.4 Other Concurrent Statements - -- All other concurrent statements are either process - -- statements or are statements for which there is an - -- equivalent process statement. - -- Elaboration of a process statement proceeds as follows: - -- 1. The process declarative part is elaborated. - Elaborate_Declarative_Part - (Instance, Get_Declaration_Chain (El)); - - -- 2. The drivers required by the process statement - -- are created. - -- 3. The initial transaction defined by the default value - -- associated with each scalar signal driven by the - -- process statement is inserted into the corresponding - -- driver. - -- FIXME: do it for drivers in called subprograms too. - Elaborate_Drivers (Instance, El); - - if not Is_Empty (Expr_Pool) then - raise Internal_Error; - end if; - - -- Elaboration of all concurrent signal assignment - -- statements and concurrent assertion statements consists - -- of the construction of the equivalent process statement - -- followed by the elaboration of the equivalent process - -- statement. - -- [GHDL: this is done by canonicalize. ] - - -- FIXME: check passive statements, - -- check no wait statement in sensitized processes. - - Instance_Pool := null; - end loop; - - if Trace_Simulation then - Disp_Signals_Value; - end if; - end Create_Processes; - - procedure PSL_Process_Executer (Self : Grt.Processes.Instance_Acc); - pragma Convention (C, PSL_Process_Executer); - - function Execute_Psl_Expr (Instance : Block_Instance_Acc; - Expr : PSL_Node; - Eos : Boolean) - return Boolean - is - use PSL.Nodes; - begin - case Get_Kind (Expr) is - when N_HDL_Expr => - declare - E : constant Iir := Get_HDL_Node (Expr); - Rtype : constant Iir := Get_Base_Type (Get_Type (E)); - Res : Iir_Value_Literal_Acc; - begin - Res := Execute_Expression (Instance, E); - if Rtype = Std_Package.Boolean_Type_Definition then - return Res.B1 = True; - elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then - return Res.E8 = 3 or Res.E8 = 7; -- 1 or H - else - Error_Kind ("execute_psl_expr", Expr); - end if; - end; - when N_True => - return True; - when N_EOS => - return Eos; - when N_Not_Bool => - return not Execute_Psl_Expr (Instance, Get_Boolean (Expr), Eos); - when N_And_Bool => - return Execute_Psl_Expr (Instance, Get_Left (Expr), Eos) - and Execute_Psl_Expr (Instance, Get_Right (Expr), Eos); - when N_Or_Bool => - return Execute_Psl_Expr (Instance, Get_Left (Expr), Eos) - or Execute_Psl_Expr (Instance, Get_Right (Expr), Eos); - when others => - Error_Kind ("execute_psl_expr", Expr); - end case; - end Execute_Psl_Expr; - - procedure PSL_Process_Executer (Self : Grt.Processes.Instance_Acc) - is - type PSL_Entry_Acc is access all PSL_Entry; - function To_PSL_Entry_Acc is new Ada.Unchecked_Conversion - (Grt.Processes.Instance_Acc, PSL_Entry_Acc); - - use PSL.NFAs; - - E : constant PSL_Entry_Acc := To_PSL_Entry_Acc (Self); - Nvec : Boolean_Vector (E.States.all'Range); - Marker : Mark_Type; - V : Boolean; - - NFA : PSL_NFA; - S : NFA_State; - S_Num : Nat32; - Ed : NFA_Edge; - Sd : NFA_State; - Sd_Num : Nat32; - begin - -- Exit now if already covered (never set for assertion). - if E.Done then - return; - end if; - - Instance_Pool := Global_Pool'Access; - Current_Process := No_Process; - - Mark (Marker, Expr_Pool); - V := Execute_Psl_Expr (E.Instance, Get_PSL_Clock (E.Stmt), False); - Release (Marker, Expr_Pool); - if V then - Nvec := (others => False); - if Get_Kind (E.Stmt) = Iir_Kind_Psl_Cover_Statement then - Nvec (0) := True; - end if; - - -- For each state: if set, evaluate all outgoing edges. - NFA := Get_PSL_NFA (E.Stmt); - S := Get_First_State (NFA); - while S /= No_State loop - S_Num := Get_State_Label (S); - - if E.States (S_Num) then - Ed := Get_First_Src_Edge (S); - while Ed /= No_Edge loop - Sd := Get_Edge_Dest (Ed); - Sd_Num := Get_State_Label (Sd); - - if not Nvec (Sd_Num) then - Mark (Marker, Expr_Pool); - V := Execute_Psl_Expr - (E.Instance, Get_Edge_Expr (Ed), False); - Release (Marker, Expr_Pool); - if V then - Nvec (Sd_Num) := True; - end if; - end if; - - Ed := Get_Next_Src_Edge (Ed); - end loop; - end if; - - S := Get_Next_State (S); - end loop; - - -- Check fail state. - S := Get_Final_State (NFA); - S_Num := Get_State_Label (S); - pragma Assert (S_Num = Get_PSL_Nbr_States (E.Stmt) - 1); - if Nvec (S_Num) then - case Get_Kind (E.Stmt) is - when Iir_Kind_Psl_Assert_Statement => - Execute_Failed_Assertion - (E.Instance, "psl assertion", E.Stmt, - "assertion violation", 2); - when Iir_Kind_Psl_Cover_Statement => - Execute_Failed_Assertion - (E.Instance, "psl cover", E.Stmt, - "sequence covered", 0); - E.Done := True; - when others => - Error_Kind ("PSL_Process_Executer", E.Stmt); - end case; - end if; - - E.States.all := Nvec; - end if; - - Instance_Pool := null; - Current_Process := null; - end PSL_Process_Executer; - - procedure Create_PSL is - begin - for I in PSL_Table.First .. PSL_Table.Last loop - declare - E : PSL_Entry renames PSL_Table.Table (I); - begin - -- Create the vector. - E.States := new Boolean_Vector' - (0 .. Get_PSL_Nbr_States (E.Stmt) - 1 => False); - E.States (0) := True; - - Grt.Processes.Ghdl_Process_Register - (To_Instance_Acc (E'Address), PSL_Process_Executer'Access, - null, System.Null_Address); - - Register_Sensitivity - (E.Instance, Get_PSL_Clock_Sensitivity (E.Stmt)); - end; - end loop; - - -- Finalizer ? - end Create_PSL; - - function Create_Shadow_Signal (Sig : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Val : Ghdl_Value_Ptr; - begin - case Sig.Kind is - when Iir_Value_Signal => - Val := new Value_Union; - case Sig.Sig.Mode is - when Mode_I64 => - Val.I64 := 0; - return Create_Signal_Value - (Grt.Signals.Ghdl_Create_Signal_I64 - (Val, null, System.Null_Address)); - when Mode_B1 => - Val.B1 := False; - return Create_Signal_Value - (Grt.Signals.Ghdl_Create_Signal_B1 - (Val, null, System.Null_Address)); - when Mode_E8 => - Val.E8 := 0; - return Create_Signal_Value - (Grt.Signals.Ghdl_Create_Signal_E8 - (Val, null, System.Null_Address)); - when Mode_E32 => - Val.E32 := 0; - return Create_Signal_Value - (Grt.Signals.Ghdl_Create_Signal_E32 - (Val, null, System.Null_Address)); - when Mode_F64 => - Val.F64 := 0.0; - return Create_Signal_Value - (Grt.Signals.Ghdl_Create_Signal_F64 - (Val, null, System.Null_Address)); - when Mode_I32 => - raise Internal_Error; - end case; - when Iir_Value_Array => - declare - Res : Iir_Value_Literal_Acc; - begin - Res := Unshare_Bounds (Sig, Instance_Pool); - for I in Res.Val_Array.V'Range loop - Res.Val_Array.V (I) := - Create_Shadow_Signal (Sig.Val_Array.V (I)); - end loop; - return Res; - end; - when Iir_Value_Record => - declare - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Record_Value - (Sig.Val_Record.Len, Instance_Pool); - for I in Res.Val_Record.V'Range loop - Res.Val_Record.V (I) := - Create_Shadow_Signal (Sig.Val_Record.V (I)); - end loop; - return Res; - end; - when Iir_Value_Scalars - | Iir_Value_Access - | Iir_Value_Range - | Iir_Value_Protected - | Iir_Value_Terminal - | Iir_Value_Quantity - | Iir_Value_File - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Create_Shadow_Signal; - - function Get_Leftest_Signal (Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - case Val.Kind is - when Iir_Value_Signal => - return Val; - when Iir_Value_Array => - return Get_Leftest_Signal (Val.Val_Array.V (1)); - when Iir_Value_Record => - return Get_Leftest_Signal (Val.Val_Record.V (1)); - when others => - raise Internal_Error; - end case; - end Get_Leftest_Signal; - - procedure Add_Conversion (Conv : Convert_Instance_Acc) - is - Src_Left : Grt.Signals.Ghdl_Signal_Ptr; - Src_Len : Ghdl_Index_Type; - Dst_Left : Grt.Signals.Ghdl_Signal_Ptr; - Dst_Len : Ghdl_Index_Type; - begin - Conv.Src := Unshare_Bounds (Conv.Src, Instance_Pool); - Conv.Dst := Unshare_Bounds (Conv.Dst, Instance_Pool); - - Src_Left := Get_Leftest_Signal (Conv.Src).Sig; - Src_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Src)); - - Dst_Left := Get_Leftest_Signal (Conv.Dst).Sig; - Dst_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Dst)); - - case Conv.Mode is - when Convert_In => - Grt.Signals.Ghdl_Signal_In_Conversion (Conversion_Proc'Address, - Conv.all'Address, - Src_Left, Src_Len, - Dst_Left, Dst_Len); - when Convert_Out => - Grt.Signals.Ghdl_Signal_Out_Conversion (Conversion_Proc'Address, - Conv.all'Address, - Src_Left, Src_Len, - Dst_Left, Dst_Len); - end case; - end Add_Conversion; - - type Connect_Mode is (Connect_Source, Connect_Effective); - - -- Add a driving value PORT to signal SIG, ie: PORT is a source for SIG. - -- As a side effect, this connect the signal SIG with the port PORT. - -- PORT is the formal, while SIG is the actual. - procedure Connect (Sig: Iir_Value_Literal_Acc; - Port: Iir_Value_Literal_Acc; - Mode : Connect_Mode) - is - begin - case Sig.Kind is - when Iir_Value_Array => - if Port.Kind /= Sig.Kind then - raise Internal_Error; - end if; - - if Sig.Val_Array.Len /= Port.Val_Array.Len then - raise Internal_Error; - end if; - for I in Sig.Val_Array.V'Range loop - Connect (Sig.Val_Array.V (I), Port.Val_Array.V (I), Mode); - end loop; - return; - when Iir_Value_Record => - if Port.Kind /= Sig.Kind then - raise Internal_Error; - end if; - if Sig.Val_Record.Len /= Port.Val_Record.Len then - raise Internal_Error; - end if; - for I in Sig.Val_Record.V'Range loop - Connect (Sig.Val_Record.V (I), Port.Val_Record.V (I), Mode); - end loop; - return; - when Iir_Value_Signal => - pragma Assert (Port.Kind = Iir_Value_Signal); - -- Here, SIG and PORT are simple signals (not composite). - -- PORT is a source for SIG. - case Mode is - when Connect_Source => - Grt.Signals.Ghdl_Signal_Add_Source - (Sig.Sig, Port.Sig); - when Connect_Effective => - Grt.Signals.Ghdl_Signal_Effective_Value - (Port.Sig, Sig.Sig); - end case; - when Iir_Value_E32 => - if Mode = Connect_Source then - raise Internal_Error; - end if; - Grt.Signals.Ghdl_Signal_Associate_E32 (Port.Sig, Sig.E32); - when Iir_Value_I64 => - if Mode = Connect_Source then - raise Internal_Error; - end if; - Grt.Signals.Ghdl_Signal_Associate_I64 (Port.Sig, Sig.I64); - when Iir_Value_B1 => - if Mode = Connect_Source then - raise Internal_Error; - end if; - Grt.Signals.Ghdl_Signal_Associate_B1 (Port.Sig, Sig.B1); - when Iir_Value_E8 => - if Mode = Connect_Source then - raise Internal_Error; - end if; - Grt.Signals.Ghdl_Signal_Associate_E8 (Port.Sig, Sig.E8); - when others => - raise Internal_Error; - end case; - end Connect; - - procedure Set_Connect - (Formal_Instance : Block_Instance_Acc; - Formal_Expr : Iir_Value_Literal_Acc; - Local_Instance : Block_Instance_Acc; - Local_Expr : Iir_Value_Literal_Acc; - Inter : Iir; - Assoc : Iir_Association_Element_By_Expression) - is - pragma Unreferenced (Formal_Instance); - Formal : constant Iir := Get_Formal (Assoc); - begin - if False and Trace_Elaboration then - Put ("connect formal "); - Put (Iir_Mode'Image (Get_Mode (Inter))); - Put (" "); - Disp_Iir_Value (Formal_Expr, Get_Type (Formal)); - Put (" with actual "); - Disp_Iir_Value (Local_Expr, Get_Type (Get_Actual (Assoc))); - New_Line; - end if; - - case Get_Mode (Inter) is - when Iir_Out_Mode - | Iir_Inout_Mode - | Iir_Buffer_Mode - | Iir_Linkage_Mode => - -- FORMAL_EXPR is a source for LOCAL_EXPR. - declare - Out_Conv : constant Iir := Get_Formal_Conversion (Assoc); - Src : Iir_Value_Literal_Acc; - begin - if Out_Conv /= Null_Iir then - Src := Create_Shadow_Signal (Local_Expr); - Add_Conversion - (new Convert_Instance_Type' - (Mode => Convert_Out, - Instance => Local_Instance, - Func => Out_Conv, - Src => Formal_Expr, - Dst => Src)); - else - Src := Formal_Expr; - end if; - -- LRM93 §12.6.2 - -- A signal is said to be active [...] if one of its source - -- is active. - Connect (Local_Expr, Src, Connect_Source); - end; - - when Iir_In_Mode => - null; - when Iir_Unknown_Mode => - raise Internal_Error; - end case; - - case Get_Mode (Inter) is - when Iir_In_Mode - | Iir_Inout_Mode - | Iir_Buffer_Mode - | Iir_Linkage_Mode => - declare - In_Conv : constant Iir := Get_Actual_Conversion (Assoc); - Src : Iir_Value_Literal_Acc; - begin - if In_Conv /= Null_Iir then - Src := Create_Shadow_Signal (Formal_Expr); - Add_Conversion - (new Convert_Instance_Type' - (Mode => Convert_In, - Instance => Local_Instance, - Func => Get_Implementation (In_Conv), - Src => Local_Expr, - Dst => Src)); - else - Src := Local_Expr; - end if; - Connect (Src, Formal_Expr, Connect_Effective); - end; - when Iir_Out_Mode => - null; - when Iir_Unknown_Mode => - raise Internal_Error; - end case; - end Set_Connect; - - procedure Create_Connects is - begin - -- New signals may be created (because of conversions). - Instance_Pool := Global_Pool'Access; - - for I in Connect_Table.First .. Connect_Table.Last loop - declare - E : Connect_Entry renames Connect_Table.Table (I); - begin - Set_Connect (E.Formal_Instance, E.Formal, - E.Actual_Instance, E.Actual, - E.Inter, E.Assoc); - end; - end loop; - - Instance_Pool := null; - end Create_Connects; - - procedure Set_Disconnection (Val : Iir_Value_Literal_Acc; - Time : Iir_Value_Time) - is - begin - case Val.Kind is - when Iir_Value_Signal => - Grt.Signals.Ghdl_Signal_Set_Disconnect (Val.Sig, Std_Time (Time)); - when Iir_Value_Record => - for I in Val.Val_Record.V'Range loop - Set_Disconnection (Val.Val_Record.V (I), Time); - end loop; - when Iir_Value_Array => - for I in Val.Val_Array.V'Range loop - Set_Disconnection (Val.Val_Array.V (I), Time); - end loop; - when others => - raise Internal_Error; - end case; - end Set_Disconnection; - - procedure Create_Disconnections is - begin - for I in Disconnection_Table.First .. Disconnection_Table.Last loop - declare - E : Disconnection_Entry renames Disconnection_Table.Table (I); - begin - Set_Disconnection (E.Sig, E.Time); - end; - end loop; - end Create_Disconnections; - - procedure Create_Guard_Signal (Instance : Block_Instance_Acc; - Sig_Guard : Iir_Value_Literal_Acc; - Val_Guard : Iir_Value_Literal_Acc; - Guard : Iir) - is - procedure Add_Guard_Sensitivity (Sig : Iir_Value_Literal_Acc) is - begin - case Sig.Kind is - when Iir_Value_Signal => - Grt.Signals.Ghdl_Signal_Guard_Dependence (Sig.Sig); - when Iir_Value_Array => - for I in Sig.Val_Array.V'Range loop - Add_Guard_Sensitivity (Sig.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - for I in Sig.Val_Record.V'Range loop - Add_Guard_Sensitivity (Sig.Val_Record.V (I)); - end loop; - when others => - raise Internal_Error; - end case; - end Add_Guard_Sensitivity; - - Dep_List : Iir_List; - Dep_It : List_Iterator; - Dep : Iir; - Data : Guard_Instance_Acc; - begin - Data := new Guard_Instance_Type'(Instance => Instance, - Guard => Guard); - Sig_Guard.Sig := Grt.Signals.Ghdl_Signal_Create_Guard - (To_Ghdl_Value_Ptr (Val_Guard.B1'Address), - Data.all'Address, Guard_Func'Access); - Dep_List := Get_Guard_Sensitivity_List (Guard); - Dep_It := List_Iterate (Dep_List); - while Is_Valid (Dep_It) loop - Dep := Get_Element (Dep_It); - Add_Guard_Sensitivity (Execute_Name (Instance, Dep, True)); - Next (Dep_It); - end loop; - - -- FIXME: free mem - end Create_Guard_Signal; - - procedure Create_Implicit_Signal (Sig : Iir_Value_Literal_Acc; - Val : Iir_Value_Literal_Acc; - Time : Std_Time; - Prefix : Iir_Value_Literal_Acc; - Kind : Mode_Signal_Type) - is - procedure Register_Prefix (Pfx : Iir_Value_Literal_Acc) is - begin - case Pfx.Kind is - when Iir_Value_Signal => - Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix (Pfx.Sig); - when Iir_Value_Array => - for I in Pfx.Val_Array.V'Range loop - Register_Prefix (Pfx.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - for I in Pfx.Val_Record.V'Range loop - Register_Prefix (Pfx.Val_Record.V (I)); - end loop; - when others => - raise Internal_Error; - end case; - end Register_Prefix; - begin - case Kind is - when Mode_Stable => - Sig.Sig := Grt.Signals.Ghdl_Create_Stable_Signal - (To_Ghdl_Value_Ptr (Val.B1'Address), Time); - when Mode_Quiet => - Sig.Sig := Grt.Signals.Ghdl_Create_Quiet_Signal - (To_Ghdl_Value_Ptr (Val.B1'Address), Time); - when Mode_Transaction => - Sig.Sig := Grt.Signals.Ghdl_Create_Transaction_Signal - (To_Ghdl_Value_Ptr (Val.B1'Address)); - when others => - raise Internal_Error; - end case; - Register_Prefix (Prefix); - end Create_Implicit_Signal; - - procedure Create_Delayed_Signal (Sig : Iir_Value_Literal_Acc; - Val : Iir_Value_Literal_Acc; - Pfx : Iir_Value_Literal_Acc; - Time : Std_Time) - is - Val_Ptr : Ghdl_Value_Ptr; - begin - case Pfx.Kind is - when Iir_Value_Array => - for I in Sig.Val_Array.V'Range loop - Create_Delayed_Signal - (Sig.Val_Array.V (I), Val.Val_Array.V (I), - Pfx.Val_Array.V (I), Time); - end loop; - when Iir_Value_Record => - for I in Pfx.Val_Record.V'Range loop - Create_Delayed_Signal - (Sig.Val_Record.V (I), Val.Val_Record.V (I), - Pfx.Val_Array.V (I), Time); - end loop; - when Iir_Value_Signal => - case Iir_Value_Scalars (Val.Kind) is - when Iir_Value_I64 => - Val_Ptr := To_Ghdl_Value_Ptr (Val.I64'Address); - when Iir_Value_E32 => - Val_Ptr := To_Ghdl_Value_Ptr (Val.E32'Address); - when Iir_Value_F64 => - Val_Ptr := To_Ghdl_Value_Ptr (Val.F64'Address); - when Iir_Value_B1 => - Val_Ptr := To_Ghdl_Value_Ptr (Val.B1'Address); - when Iir_Value_E8 => - Val_Ptr := To_Ghdl_Value_Ptr (Val.E8'Address); - end case; - Sig.Sig := Grt.Signals.Ghdl_Create_Delayed_Signal - (Pfx.Sig, Val_Ptr, Time); - when others => - raise Internal_Error; - end case; - end Create_Delayed_Signal; - - -- Create a new signal, using DEFAULT as initial value. - -- Set its number. - procedure Create_User_Signal (Block: Block_Instance_Acc; - Mode : Mode_Signal_Type; - Signal: Iir; - Sig : Iir_Value_Literal_Acc; - Val : Iir_Value_Literal_Acc) - is - use Grt.Rtis; - use Grt.Signals; - - procedure Create_Signal (Val : Iir_Value_Literal_Acc; - Sig : Iir_Value_Literal_Acc; - Sig_Type: Iir; - Already_Resolved : Boolean) - is - Sub_Resolved : Boolean := Already_Resolved; - Resolv_Func : Iir; - Resolv_Instance : Resolv_Instance_Acc; - begin - if not Already_Resolved - and then Get_Kind (Sig_Type) in Iir_Kinds_Subtype_Definition - then - Resolv_Func := Get_Resolution_Indication (Sig_Type); - else - Resolv_Func := Null_Iir; - end if; - if Resolv_Func /= Null_Iir then - Sub_Resolved := True; - Resolv_Instance := new Resolv_Instance_Type' - (Func => Get_Named_Entity (Resolv_Func), - Block => Block, - Sig => Sig); - Grt.Signals.Ghdl_Signal_Create_Resolution - (Resolution_Proc'Access, - Resolv_Instance.all'Address, - System.Null_Address, - Ghdl_Index_Type (Get_Nbr_Of_Scalars (Val))); - end if; - case Val.Kind is - when Iir_Value_Array => - declare - Sig_El_Type : constant Iir := - Get_Element_Subtype (Get_Base_Type (Sig_Type)); - begin - for I in Val.Val_Array.V'Range loop - Create_Signal (Val.Val_Array.V (I), Sig.Val_Array.V (I), - Sig_El_Type, Sub_Resolved); - end loop; - end; - when Iir_Value_Record => - declare - List : constant Iir_Flist := Get_Elements_Declaration_List - (Get_Base_Type (Sig_Type)); - El : Iir_Element_Declaration; - begin - for I in Val.Val_Record.V'Range loop - El := Get_Nth_Element (List, Natural (I - 1)); - Create_Signal (Val.Val_Record.V (I), Sig.Val_Record.V (I), - Get_Type (El), Sub_Resolved); - end loop; - end; - - when Iir_Value_I64 => - Sig.Sig := Grt.Signals.Ghdl_Create_Signal_I64 - (To_Ghdl_Value_Ptr (Val.I64'Address), - null, System.Null_Address); - when Iir_Value_B1 => - Sig.Sig := Grt.Signals.Ghdl_Create_Signal_B1 - (To_Ghdl_Value_Ptr (Val.B1'Address), - null, System.Null_Address); - when Iir_Value_E8 => - Sig.Sig := Grt.Signals.Ghdl_Create_Signal_E8 - (To_Ghdl_Value_Ptr (Val.E8'Address), - null, System.Null_Address); - when Iir_Value_E32 => - Sig.Sig := Grt.Signals.Ghdl_Create_Signal_E32 - (To_Ghdl_Value_Ptr (Val.E32'Address), - null, System.Null_Address); - when Iir_Value_F64 => - Sig.Sig := Grt.Signals.Ghdl_Create_Signal_F64 - (To_Ghdl_Value_Ptr (Val.F64'Address), - null, System.Null_Address); - - when Iir_Value_Signal - | Iir_Value_Range - | Iir_Value_File - | Iir_Value_Access - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Create_Signal; - - Sig_Type: constant Iir := Get_Type (Signal); - Kind : Kind_Signal_Type; - - type Iir_Kind_To_Kind_Signal_Type is - array (Iir_Signal_Kind) of Kind_Signal_Type; - Iir_Kind_To_Kind_Signal : constant Iir_Kind_To_Kind_Signal_Type := - (Iir_Register_Kind => Kind_Signal_Register, - Iir_Bus_Kind => Kind_Signal_Bus); - begin - if Get_Guarded_Signal_Flag (Signal) then - Kind := Iir_Kind_To_Kind_Signal (Get_Signal_Kind (Signal)); - else - Kind := Kind_Signal_No; - end if; - - Grt.Signals.Ghdl_Signal_Set_Mode (Mode, Kind, True); - - Create_Signal (Val, Sig, Sig_Type, False); - end Create_User_Signal; - - procedure Create_Signals is - begin - for I in Signals_Table.First .. Signals_Table.Last loop - declare - E : Signal_Entry renames Signals_Table.Table (I); - begin - case E.Kind is - when Mode_Guard => - Create_Guard_Signal (E.Instance, E.Sig, E.Val, E.Decl); - when Mode_Stable | Mode_Quiet | Mode_Transaction => - Create_Implicit_Signal - (E.Sig, E.Val, E.Time, E.Prefix, E.Kind); - when Mode_Delayed => - Create_Delayed_Signal (E.Sig, E.Val, E.Prefix, E.Time); - when Mode_Signal_User => - Create_User_Signal - (E.Instance, E.Kind, E.Decl, E.Sig, E.Val); - when Mode_Conv_In | Mode_Conv_Out | Mode_End => - raise Internal_Error; - end case; - end; - end loop; - end Create_Signals; - - procedure Ghdl_Elaborate is - begin - Elaboration.Elaborate_Design (Top_Config); - - if Disp_Stats then - Disp_Design_Stats; - end if; - - if Disp_Ams then - Debugger.AMS.Disp_Characteristic_Expressions; - end if; - - -- There is no inputs. - -- All the simulation is done via time, so it must be displayed. - Disp_Time_Before_Values := True; - - -- Initialisation. - if Trace_Simulation then - Put_Line ("Initialisation:"); - end if; - - Create_Signals; - Create_Connects; - Create_Disconnections; - Create_Processes; - Create_PSL; - - if Disp_Tree then - Debugger.Disp_Instances_Tree; - end if; - - if Flag_Interractive then - Debug (Reason_Elab); - end if; - end Ghdl_Elaborate; - - procedure Simulation_Entity (Top_Conf : Iir_Design_Unit) is - begin - Top_Config := Top_Conf; - - Grt.Errors.Error_Hook := Debug_Error'Access; - - if Flag_Interractive then - Debug (Reason_Start); - end if; - - Grt.Main.Run; - exception - when Debugger_Quit => - null; - when Simulation_Finished => - null; - end Simulation_Entity; -end Simulation.Main; diff --git a/src/vhdl/simulate/simulation-main.ads b/src/vhdl/simulate/simulation-main.ads deleted file mode 100644 index ed8fe5d69..000000000 --- a/src/vhdl/simulate/simulation-main.ads +++ /dev/null @@ -1,4 +0,0 @@ -package Simulation.Main is - -- The entry point of the simulator. - procedure Simulation_Entity (Top_Conf : Iir_Design_Unit); -end Simulation.Main; diff --git a/src/vhdl/simulate/simulation.adb b/src/vhdl/simulate/simulation.adb deleted file mode 100644 index 0d23a20f8..000000000 --- a/src/vhdl/simulate/simulation.adb +++ /dev/null @@ -1,716 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Types; use Types; -with Execution; use Execution; -with Areapools; use Areapools; -with Grt.Signals; -with Grt.Processes; -with Grtlink; -pragma Unreferenced (Grtlink); - -package body Simulation is - - function Value_To_Iir_Value (Mode : Mode_Type; Val : Value_Union) - return Iir_Value_Literal_Acc is - begin - case Mode is - when Mode_B1 => - return Create_B1_Value (Val.B1); - when Mode_E8 => - return Create_E8_Value (Val.E8); - when Mode_E32 => - return Create_E32_Value (Val.E32); - when Mode_I64 => - return Create_I64_Value (Val.I64); - when Mode_F64 => - return Create_F64_Value (Val.F64); - when others => - raise Internal_Error; -- FIXME - end case; - end Value_To_Iir_Value; - - procedure Iir_Value_To_Value (Src : Iir_Value_Literal_Acc; - Dst : out Value_Union) is - begin - case Iir_Value_Scalars (Src.Kind) is - when Iir_Value_B1 => - Dst.B1 := Src.B1; - when Iir_Value_E8 => - Dst.E8 := Src.E8; - when Iir_Value_E32 => - Dst.E32 := Src.E32; - when Iir_Value_I64 => - Dst.I64 := Src.I64; - when Iir_Value_F64 => - Dst.F64 := Src.F64; - end case; - end Iir_Value_To_Value; - - type Read_Signal_Flag_Enum is - (Read_Signal_Event, - Read_Signal_Active, - -- In order to reuse the same code (that returns immediately if the - -- attribute is true), we use not driving. - Read_Signal_Not_Driving); - - function Read_Signal_Flag (Lit: Iir_Value_Literal_Acc; - Kind : Read_Signal_Flag_Enum) - return Boolean - is - begin - case Lit.Kind is - when Iir_Value_Array => - for I in Lit.Val_Array.V'Range loop - if Read_Signal_Flag (Lit.Val_Array.V (I), Kind) then - return True; - end if; - end loop; - return False; - when Iir_Value_Record => - for I in Lit.Val_Record.V'Range loop - if Read_Signal_Flag (Lit.Val_Record.V (I), Kind) then - return True; - end if; - end loop; - return False; - when Iir_Value_Signal => - case Kind is - when Read_Signal_Event => - return Lit.Sig.Event; - when Read_Signal_Active => - return Lit.Sig.Active; - when Read_Signal_Not_Driving => - if Grt.Signals.Ghdl_Signal_Driving (Lit.Sig) = True then - return False; - else - return True; - end if; - end case; - when others => - raise Internal_Error; - end case; - end Read_Signal_Flag; - - function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc) - return Boolean is - begin - return Read_Signal_Flag (Lit, Read_Signal_Event); - end Execute_Event_Attribute; - - function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc) - return Boolean is - begin - return Read_Signal_Flag (Lit, Read_Signal_Active); - end Execute_Active_Attribute; - - function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc) - return Boolean is - begin - return not Read_Signal_Flag (Lit, Read_Signal_Not_Driving); - end Execute_Driving_Attribute; - - function Execute_Read_Signal_Value - (Sig: Iir_Value_Literal_Acc; Attr : Read_Signal_Value_Enum) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - case Sig.Kind is - when Iir_Value_Array => - Res := Copy_Array_Bound (Sig); - for I in Sig.Val_Array.V'Range loop - Res.Val_Array.V (I) := - Execute_Read_Signal_Value (Sig.Val_Array.V (I), Attr); - end loop; - return Res; - when Iir_Value_Record => - Res := Create_Record_Value (Sig.Val_Record.Len); - for I in Sig.Val_Record.V'Range loop - Res.Val_Record.V (I) := - Execute_Read_Signal_Value (Sig.Val_Record.V (I), Attr); - end loop; - return Res; - when Iir_Value_Signal => - case Attr is - when Read_Signal_Last_Value => - return Value_To_Iir_Value - (Sig.Sig.Mode, Sig.Sig.Last_Value); - when Read_Signal_Driver_Value => - case Sig.Sig.Mode is - when Mode_F64 => - return Create_F64_Value - (Grt.Signals.Ghdl_Signal_Driving_Value_F64 - (Sig.Sig)); - when Mode_I64 => - return Create_I64_Value - (Grt.Signals.Ghdl_Signal_Driving_Value_I64 - (Sig.Sig)); - when Mode_E32 => - return Create_E32_Value - (Grt.Signals.Ghdl_Signal_Driving_Value_E32 - (Sig.Sig)); - when Mode_B1 => - return Create_B1_Value - (Grt.Signals.Ghdl_Signal_Driving_Value_B1 - (Sig.Sig)); - when others => - raise Internal_Error; - end case; - when Read_Signal_Effective_Value => - return Value_To_Iir_Value - (Sig.Sig.Mode, Sig.Sig.Value_Ptr.all); - when Read_Signal_Driving_Value => - return Value_To_Iir_Value - (Sig.Sig.Mode, Sig.Sig.Driving_Value); - end case; - when others => - raise Internal_Error; - end case; - end Execute_Read_Signal_Value; - - procedure Execute_Write_Signal (Sig: Iir_Value_Literal_Acc; - Val : Iir_Value_Literal_Acc; - Attr : Write_Signal_Enum) is - begin - case Sig.Kind is - when Iir_Value_Array => - pragma Assert (Val.Kind = Iir_Value_Array); - pragma Assert (Sig.Val_Array.Len = Val.Val_Array.Len); - for I in Sig.Val_Array.V'Range loop - Execute_Write_Signal - (Sig.Val_Array.V (I), Val.Val_Array.V (I), Attr); - end loop; - when Iir_Value_Record => - pragma Assert (Val.Kind = Iir_Value_Record); - pragma Assert (Sig.Val_Record.Len = Val.Val_Record.Len); - for I in Sig.Val_Record.V'Range loop - Execute_Write_Signal - (Sig.Val_Record.V (I), Val.Val_Record.V (I), Attr); - end loop; - when Iir_Value_Signal => - pragma Assert (Val.Kind in Iir_Value_Scalars); - case Attr is - when Write_Signal_Driving_Value => - Iir_Value_To_Value (Val, Sig.Sig.Driving_Value); - when Write_Signal_Effective_Value => - Iir_Value_To_Value (Val, Sig.Sig.Value_Ptr.all); - end case; - when others => - raise Internal_Error; - end case; - end Execute_Write_Signal; - - function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Execute_Read_Signal_Value (Indirect, Read_Signal_Last_Value); - end Execute_Last_Value_Attribute; - - function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Execute_Read_Signal_Value (Indirect, Read_Signal_Driver_Value); - end Execute_Driving_Value_Attribute; - - type Signal_Read_Last_Type is - (Read_Last_Event, - Read_Last_Active); - - -- Return the Last_Event absolute time. - function Execute_Read_Signal_Last (Indirect: Iir_Value_Literal_Acc; - Kind : Signal_Read_Last_Type) - return Ghdl_I64 - is - Res: Ghdl_I64; - begin - case Indirect.Kind is - when Iir_Value_Array => - Res := Ghdl_I64'First; - for I in Indirect.Val_Array.V'Range loop - Res := Ghdl_I64'Max - (Res, Execute_Read_Signal_Last (Indirect.Val_Array.V (I), - Kind)); - end loop; - return Res; - when Iir_Value_Record => - Res := Ghdl_I64'First; - for I in Indirect.Val_Record.V'Range loop - Res := Ghdl_I64'Max - (Res, Execute_Read_Signal_Last (Indirect.Val_Record.V (I), - Kind)); - end loop; - return Res; - when Iir_Value_Signal => - case Kind is - when Read_Last_Event => - return Ghdl_I64 (Indirect.Sig.Last_Event); - when Read_Last_Active => - return Ghdl_I64 (Indirect.Sig.Last_Active); - end case; - when others => - raise Internal_Error; - end case; - end Execute_Read_Signal_Last; - - function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc) - return Ghdl_I64 is - begin - return Execute_Read_Signal_Last (Indirect, Read_Last_Event); - end Execute_Last_Event_Attribute; - - function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc) - return Ghdl_I64 is - begin - return Execute_Read_Signal_Last (Indirect, Read_Last_Active); - end Execute_Last_Active_Attribute; - - function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - case Indirect.Kind is - when Iir_Value_Array => - Res := Copy_Array_Bound (Indirect); - for I in Indirect.Val_Array.V'Range loop - Res.Val_Array.V (I) := - Execute_Signal_Value (Indirect.Val_Array.V (I)); - end loop; - return Res; - when Iir_Value_Record => - Res := Create_Record_Value (Indirect.Val_Record.Len); - for I in Indirect.Val_Record.V'Range loop - Res.Val_Record.V (I) := - Execute_Signal_Value (Indirect.Val_Record.V (I)); - end loop; - return Res; - when Iir_Value_Signal => - return Value_To_Iir_Value - (Indirect.Sig.Mode, Indirect.Sig.Value_Ptr.all); - when others => - raise Internal_Error; - end case; - end Execute_Signal_Value; - - procedure Assign_Value_To_Array_Signal - (Instance: Block_Instance_Acc; - Target: Iir_Value_Literal_Acc; - Transactions: Transaction_Type) - is - Sub_Trans : Transaction_Type (Transactions.Len); - begin - Sub_Trans.Stmt := Transactions.Stmt; - Sub_Trans.Reject := Transactions.Reject; - - for J in Target.Val_Array.V'Range loop - for K in Transactions.Els'Range loop - declare - T : Transaction_El_Type renames Transactions.Els (K); - S : Transaction_El_Type renames Sub_Trans.Els (K); - begin - S.After := T.After; - - if T.Value = null then - S.Value := null; - else - S.Value := T.Value.Val_Array.V (J); - end if; - end; - end loop; - - Assign_Value_To_Signal - (Instance, Target.Val_Array.V (J), Sub_Trans); - end loop; - end Assign_Value_To_Array_Signal; - - procedure Assign_Value_To_Record_Signal - (Instance: Block_Instance_Acc; - Target: Iir_Value_Literal_Acc; - Transactions: Transaction_Type) - is - Sub_Trans : Transaction_Type (Transactions.Len); - begin - Sub_Trans.Stmt := Transactions.Stmt; - Sub_Trans.Reject := Transactions.Reject; - - for J in Target.Val_Record.V'Range loop - for K in Transactions.Els'Range loop - declare - T : Transaction_El_Type renames Transactions.Els (K); - S : Transaction_El_Type renames Sub_Trans.Els (K); - begin - S.After := T.After; - - if T.Value = null then - S.Value := null; - else - S.Value := T.Value.Val_Record.V (J); - end if; - end; - end loop; - - Assign_Value_To_Signal - (Instance, Target.Val_Record.V (J), Sub_Trans); - end loop; - end Assign_Value_To_Record_Signal; - - procedure Assign_Value_To_Scalar_Signal - (Instance: Block_Instance_Acc; - Target: Iir_Value_Literal_Acc; - Transactions: Transaction_Type) - is - pragma Unreferenced (Instance); - use Grt.Signals; - begin - declare - El : Transaction_El_Type renames Transactions.Els (1); - begin - if El.Value = null then - Ghdl_Signal_Start_Assign_Null - (Target.Sig, Transactions.Reject, El.After); - if Transactions.Els'Last /= 1 then - raise Internal_Error; - end if; - return; - end if; - - -- FIXME: null transaction, check constraints. - case Iir_Value_Scalars (El.Value.Kind) is - when Iir_Value_B1 => - Ghdl_Signal_Start_Assign_B1 - (Target.Sig, Transactions.Reject, El.Value.B1, El.After); - when Iir_Value_E8 => - Ghdl_Signal_Start_Assign_E8 - (Target.Sig, Transactions.Reject, El.Value.E8, El.After); - when Iir_Value_E32 => - Ghdl_Signal_Start_Assign_E32 - (Target.Sig, Transactions.Reject, El.Value.E32, El.After); - when Iir_Value_I64 => - Ghdl_Signal_Start_Assign_I64 - (Target.Sig, Transactions.Reject, El.Value.I64, El.After); - when Iir_Value_F64 => - Ghdl_Signal_Start_Assign_F64 - (Target.Sig, Transactions.Reject, El.Value.F64, El.After); - end case; - end; - - for I in 2 .. Transactions.Els'Last loop - declare - El : Transaction_El_Type renames Transactions.Els (I); - begin - case Iir_Value_Scalars (El.Value.Kind) is - when Iir_Value_B1 => - Ghdl_Signal_Next_Assign_B1 - (Target.Sig, El.Value.B1, El.After); - when Iir_Value_E8 => - Ghdl_Signal_Next_Assign_E8 - (Target.Sig, El.Value.E8, El.After); - when Iir_Value_E32 => - Ghdl_Signal_Next_Assign_E32 - (Target.Sig, El.Value.E32, El.After); - when Iir_Value_I64 => - Ghdl_Signal_Next_Assign_I64 - (Target.Sig, El.Value.I64, El.After); - when Iir_Value_F64 => - Ghdl_Signal_Next_Assign_F64 - (Target.Sig, El.Value.F64, El.After); - end case; - end; - end loop; - end Assign_Value_To_Scalar_Signal; - - procedure Assign_Value_To_Signal - (Instance: Block_Instance_Acc; - Target: Iir_Value_Literal_Acc; - Transaction: Transaction_Type) - is - begin - case Target.Kind is - when Iir_Value_Array => - Assign_Value_To_Array_Signal - (Instance, Target, Transaction); - when Iir_Value_Record => - Assign_Value_To_Record_Signal - (Instance, Target, Transaction); - when Iir_Value_Signal => - Assign_Value_To_Scalar_Signal - (Instance, Target, Transaction); - when Iir_Value_Scalars - | Iir_Value_Range - | Iir_Value_File - | Iir_Value_Access - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal - | Iir_Value_Environment => - raise Internal_Error; - end case; - end Assign_Value_To_Signal; - - procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc) is - begin - case Sig.Kind is - when Iir_Value_Array => - for I in Sig.Val_Array.V'Range loop - Disconnect_Signal (Sig.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - for I in Sig.Val_Array.V'Range loop - Disconnect_Signal (Sig.Val_Record.V (I)); - end loop; - when Iir_Value_Signal => - Grt.Signals.Ghdl_Signal_Disconnect (Sig.Sig); - when others => - raise Internal_Error; - end case; - end Disconnect_Signal; - - -- Call Ghdl_Process_Wait_Add_Sensitivity for each scalar subelement of - -- SIG. - procedure Wait_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) - is - begin - case Sig.Kind is - when Iir_Value_Signal => - Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity (Sig.Sig); - when Iir_Value_Array => - for I in Sig.Val_Array.V'Range loop - Wait_Add_Sensitivity (Sig.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - for I in Sig.Val_Record.V'Range loop - Wait_Add_Sensitivity (Sig.Val_Record.V (I)); - end loop; - when others => - raise Internal_Error; - end case; - end Wait_Add_Sensitivity; - - -- Return true if the process should be suspended. - function Execute_Wait_Statement (Instance : Block_Instance_Acc; - Stmt: Iir_Wait_Statement) - return Boolean - is - Expr: Iir; - El : Iir; - List: Iir_List; - It : List_Iterator; - Res: Iir_Value_Literal_Acc; - Status : Boolean; - Marker : Mark_Type; - begin - if not Instance.In_Wait_Flag then - Mark (Marker, Expr_Pool); - - -- LRM93 8.1 - -- The execution of a wait statement causes the time expression to - -- be evaluated to determine the timeout interval. - Expr := Get_Timeout_Clause (Stmt); - if Expr /= Null_Iir then - Res := Execute_Expression (Instance, Expr); - Grt.Processes.Ghdl_Process_Wait_Set_Timeout - (Std_Time (Res.I64), null, 0); - end if; - - -- LRM93 8.1 - -- The suspended process may also resume as a result of an event - -- occuring on any signal in the sensitivity set of the wait - -- statement. - List := Get_Sensitivity_List (Stmt); - It := List_Iterate_Safe (List); - while Is_Valid (It) loop - El := Get_Element (It); - Wait_Add_Sensitivity (Execute_Name (Instance, El, True)); - Next (It); - end loop; - - -- LRM93 8.1 - -- It also causes the execution of the corresponding process - -- statement to be suspended. - Grt.Processes.Ghdl_Process_Wait_Suspend; - Instance.In_Wait_Flag := True; - Release (Marker, Expr_Pool); - return True; - else - -- LRM93 8.1 - -- The suspended process will resume, at the latest, immediately - -- after the timeout interval has expired. - if not Grt.Processes.Ghdl_Process_Wait_Timed_Out then - -- Compute the condition clause only if the timeout has not - -- expired. - - -- LRM93 8.1 - -- If such an event occurs, the condition in the condition clause - -- is evaluated. - -- - -- if no condition clause appears, the condition clause until true - -- is assumed. - Status := - Execute_Condition (Instance, Get_Condition_Clause (Stmt)); - if not Status then - -- LRM93 8.1 - -- If the value of the condition is FALSE, the process will - -- re-suspend. - -- Such re-suspension does not involve the recalculation of - -- the timeout interval. - Grt.Processes.Ghdl_Process_Wait_Suspend; - return True; - end if; - end if; - - -- LRM93 8.1 - -- If the value of the condition is TRUE, the process will resume. - -- next statement. - Grt.Processes.Ghdl_Process_Wait_Close; - - Instance.In_Wait_Flag := False; - return False; - end if; - end Execute_Wait_Statement; - - type Resolver_Read_Mode is (Read_Port, Read_Driver); - - function Resolver_Read_Value (Sig : Iir_Value_Literal_Acc; - Mode : Resolver_Read_Mode; - Index : Ghdl_Index_Type) - return Iir_Value_Literal_Acc - is - use Grt.Signals; - Val : Ghdl_Value_Ptr; - Res : Iir_Value_Literal_Acc; - begin - case Sig.Kind is - when Iir_Value_Array => - Res := Copy_Array_Bound (Sig); - for I in Sig.Val_Array.V'Range loop - Res.Val_Array.V (I) := - Resolver_Read_Value (Sig.Val_Array.V (I), Mode, Index); - end loop; - when Iir_Value_Record => - Res := Create_Record_Value (Sig.Val_Record.Len); - for I in Sig.Val_Record.V'Range loop - Res.Val_Record.V (I) := - Resolver_Read_Value (Sig.Val_Record.V (I), Mode, Index); - end loop; - when Iir_Value_Signal => - case Mode is - when Read_Port => - Val := Ghdl_Signal_Read_Port (Sig.Sig, Index); - when Read_Driver => - Val := Ghdl_Signal_Read_Driver (Sig.Sig, Index); - end case; - Res := Value_To_Iir_Value (Sig.Sig.Mode, Val.all); - when others => - raise Internal_Error; - end case; - return Res; - end Resolver_Read_Value; - - procedure Resolution_Proc (Instance_Addr : System.Address; - Val : System.Address; - Bool_Vec : System.Address; - Vec_Len : Ghdl_Index_Type; - Nbr_Drv : Ghdl_Index_Type; - Nbr_Ports : Ghdl_Index_Type) - is - pragma Unreferenced (Val); - - Instance : Resolv_Instance_Type; - pragma Import (Ada, Instance); - for Instance'Address use Instance_Addr; - - type Bool_Array is array (1 .. Nbr_Drv) of Boolean; - Vec : Bool_Array; - pragma Import (Ada, Vec); - for Vec'Address use Bool_Vec; - Off : Iir_Index32; - - Arr : Iir_Value_Literal_Acc; - Arr_Type : constant Iir := - Get_Type (Get_Interface_Declaration_Chain (Instance.Func)); - - Res : Iir_Value_Literal_Acc; - - Len : constant Iir_Index32 := Iir_Index32 (Vec_Len + Nbr_Ports); - Instance_Mark, Expr_Mark : Mark_Type; - begin - pragma Assert (Instance_Pool = null); - Instance_Pool := Global_Pool'Access; - Mark (Instance_Mark, Instance_Pool.all); - Mark (Expr_Mark, Expr_Pool); - Current_Process := No_Process; - - Arr := Create_Array_Value (Len, 1); - Arr.Bounds.D (1) := Create_Bounds_From_Length - (Instance.Block, - Get_Nth_Element (Get_Index_Subtype_List (Arr_Type), 0), - Len); - - -- First ports - for I in 1 .. Nbr_Ports loop - Arr.Val_Array.V (Iir_Index32 (I)) := Resolver_Read_Value - (Instance.Sig, Read_Port, I - 1); - end loop; - - -- Then drivers. - Off := Iir_Index32 (Nbr_Ports) + 1; - for I in 1 .. Nbr_Drv loop - if Vec (I) then - Arr.Val_Array.V (Off) := Resolver_Read_Value - (Instance.Sig, Read_Driver, I - 1); - Off := Off + 1; - end if; - end loop; - - -- Call resolution function. - Res := Execute_Resolution_Function (Instance.Block, Instance.Func, Arr); - - -- Set driving value. - Execute_Write_Signal (Instance.Sig, Res, Write_Signal_Driving_Value); - - Release (Instance_Mark, Instance_Pool.all); - Release (Expr_Mark, Expr_Pool); - Instance_Pool := null; - end Resolution_Proc; - - function Guard_Func (Data : System.Address) return Ghdl_B1 - is - Guard : Guard_Instance_Type; - pragma Import (Ada, Guard); - for Guard'Address use Data; - - Val : Boolean; - - Prev_Instance_Pool : Areapool_Acc; - begin - pragma Assert (Instance_Pool = null - or else Instance_Pool = Global_Pool'Access); - Prev_Instance_Pool := Instance_Pool; - - Instance_Pool := Global_Pool'Access; - Current_Process := No_Process; - - Val := Execute_Condition - (Guard.Instance, Get_Guard_Expression (Guard.Guard)); - - Instance_Pool := Prev_Instance_Pool; - - return Ghdl_B1'Val (Boolean'Pos (Val)); - end Guard_Func; -end Simulation; diff --git a/src/vhdl/simulate/simulation.ads b/src/vhdl/simulate/simulation.ads deleted file mode 100644 index fa3a54982..000000000 --- a/src/vhdl/simulate/simulation.ads +++ /dev/null @@ -1,136 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with System; -with Grt.Types; use Grt.Types; -with Iirs; use Iirs; -with Iir_Values; use Iir_Values; - -package Simulation is - Trace_Simulation : Boolean := False; - Disp_Tree : Boolean := False; - Disp_Stats : Boolean := False; - Disp_Ams : Boolean := False; - - type Resolv_Instance_Type is record - Func : Iir; - Block : Block_Instance_Acc; - Sig : Iir_Value_Literal_Acc; - end record; - type Resolv_Instance_Acc is access Resolv_Instance_Type; - - -- The resolution procedure for GRT. - procedure Resolution_Proc (Instance_Addr : System.Address; - Val : System.Address; - Bool_Vec : System.Address; - Vec_Len : Ghdl_Index_Type; - Nbr_Drv : Ghdl_Index_Type; - Nbr_Ports : Ghdl_Index_Type); - pragma Convention (C, Resolution_Proc); - - type Guard_Instance_Type is record - Instance : Block_Instance_Acc; - Guard : Iir; - end record; - - type Guard_Instance_Acc is access Guard_Instance_Type; - - function Guard_Func (Data : System.Address) return Ghdl_B1; - pragma Convention (C, Guard_Func); - - function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc) - return Boolean; - - function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc) - return Boolean; - function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc) - return Boolean; - - function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc; - - -- Return the Last_Event absolute time. - function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc) - return Ghdl_I64; - function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc) - return Ghdl_I64; - - -- Type for a transaction: it contains the value, the absolute time at which - -- the transaction should occur and a pointer to the next transaction. - -- This constitute a simple linked list, the elements must be ordered - -- according to time. - type Transaction_El_Type is record - -- The value of the waveform element. - -- Can't be an array. - -- Life must be target. - Value: Iir_Value_Literal_Acc; - - -- After time at which the transaction should occur. - After : Grt.Types.Std_Time; - end record; - - type Transaction_Array is array (Natural range <>) of Transaction_El_Type; - - type Transaction_Type (Len : Natural) is record - -- Statement that created this transaction. Used to disp location - -- in case of error (constraint error). - Stmt: Iir; - - Reject : Std_Time; - - Els : Transaction_Array (1 .. Len); - end record; - - procedure Assign_Value_To_Signal (Instance: Block_Instance_Acc; - Target: Iir_Value_Literal_Acc; - Transaction: Transaction_Type); - - procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc); - - -- Return true if the process should be suspended. - function Execute_Wait_Statement (Instance : Block_Instance_Acc; - Stmt: Iir_Wait_Statement) - return Boolean; -private - type Read_Signal_Value_Enum is - (Read_Signal_Last_Value, - - -- For conversion functions. - Read_Signal_Driving_Value, - Read_Signal_Effective_Value, - - -- 'Driving_Value - Read_Signal_Driver_Value); - - function Execute_Read_Signal_Value (Sig: Iir_Value_Literal_Acc; - Attr : Read_Signal_Value_Enum) - return Iir_Value_Literal_Acc; - - type Write_Signal_Enum is - (Write_Signal_Driving_Value, - Write_Signal_Effective_Value); - - procedure Execute_Write_Signal (Sig: Iir_Value_Literal_Acc; - Val : Iir_Value_Literal_Acc; - Attr : Write_Signal_Enum); -end Simulation; -- cgit v1.2.3