summaryrefslogtreecommitdiff
path: root/simulate
diff options
context:
space:
mode:
Diffstat (limited to 'simulate')
-rw-r--r--simulate/annotations.adb1224
-rw-r--r--simulate/annotations.ads116
-rw-r--r--simulate/areapools.adb147
-rw-r--r--simulate/areapools.ads87
-rw-r--r--simulate/debugger.adb1632
-rw-r--r--simulate/debugger.ads89
-rw-r--r--simulate/elaboration.adb2513
-rw-r--r--simulate/elaboration.ads207
-rw-r--r--simulate/execution.adb4285
-rw-r--r--simulate/execution.ads180
-rw-r--r--simulate/file_operation.adb336
-rw-r--r--simulate/file_operation.ads79
-rw-r--r--simulate/grt_interface.adb44
-rw-r--r--simulate/grt_interface.ads34
-rw-r--r--simulate/iir_values.adb1038
-rw-r--r--simulate/iir_values.ads352
-rw-r--r--simulate/sim_be.adb117
-rw-r--r--simulate/sim_be.ads25
-rw-r--r--simulate/simulation-ams-debugger.adb87
-rw-r--r--simulate/simulation-ams-debugger.ads27
-rw-r--r--simulate/simulation-ams.adb201
-rw-r--r--simulate/simulation-ams.ads165
-rw-r--r--simulate/simulation.adb1704
-rw-r--r--simulate/simulation.ads128
24 files changed, 14817 insertions, 0 deletions
diff --git a/simulate/annotations.adb b/simulate/annotations.adb
new file mode 100644
index 0000000..66435d7
--- /dev/null
+++ b/simulate/annotations.adb
@@ -0,0 +1,1224 @@
+-- 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 GNAT.Table;
+with Ada.Text_IO;
+with Std_Package;
+with Errorout; use Errorout;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Annotations is
+ -- Current scope level.
+ Current_Scope_Level: Scope_Level_Type := Scope_Level_Global;
+
+ 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_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);
+
+ -- Be sure the node contains no informations.
+ procedure Assert_No_Info (Node: in Iir) is
+ begin
+ if Get_Info (Node) /= null then
+ raise Internal_Error;
+ end if;
+ end Assert_No_Info;
+
+ procedure Increment_Current_Scope_Level is
+ begin
+ if Current_Scope_Level < Scope_Level_Global then
+ -- For a subprogram in a package
+ Current_Scope_Level := Scope_Level_Global + 1;
+ else
+ Current_Scope_Level := Current_Scope_Level + 1;
+ end if;
+ end Increment_Current_Scope_Level;
+
+ -- 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,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when Kind_File =>
+ Info := new Sim_Info_Type'(Kind => Kind_File,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when Kind_Signal =>
+ Info := new Sim_Info_Type'(Kind => Kind_Signal,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ -- Reserve one more slot for default value.
+ Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1;
+ when Kind_Terminal =>
+ Info := new Sim_Info_Type'(Kind => Kind_Terminal,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when Kind_Quantity =>
+ Info := new Sim_Info_Type'(Kind => Kind_Quantity,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Set_Info (Obj, Info);
+ end Create_Object_Info;
+
+ -- Add an annotation to SIGNAL.
+ procedure Add_Signal_Info (Block_Info: Sim_Info_Acc; Signal: Iir) is
+ begin
+ Create_Object_Info (Block_Info, Signal, Kind_Signal);
+ end Add_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;
+ Assert_No_Info (Expr);
+-- 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_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
+ El : Iir;
+ Res : Natural;
+ List : Iir_List;
+ begin
+ Res := 2;
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ 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 := "bEIF";
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kinds_Scalar_Type_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
+ El : Iir;
+ List : Iir_List;
+ begin
+ Res (Off) := '<';
+ Off := Off + 1;
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ 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_Level : constant Scope_Level_Type := Current_Scope_Level;
+ Decl : Iir;
+ 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_Level;
+
+ 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_Level := Prev_Scope_Level;
+ 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_Level : constant Scope_Level_Type := Current_Scope_Level;
+ begin
+ Increment_Current_Scope_Level;
+
+ Assert_No_Info (Prot);
+
+ Prot_Info := new Sim_Info_Type'
+ (Kind => Kind_Frame,
+ Inst_Slot => 0,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+ Set_Info (Prot, Prot_Info);
+
+ Annotate_Declaration_List
+ (Prot_Info, Get_Declaration_Chain (Prot));
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Protected_Type_Body;
+
+ procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir)
+ is
+ El: Iir;
+ List: Iir_List;
+ 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 =>
+ List := Get_Enumeration_Literal_List (Def);
+ if Def = Std_Package.Boolean_Type_Definition
+ or else Def = Std_Package.Bit_Type_Definition
+ then
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_Scalar_Type,
+ Scalar_Mode => Iir_Value_B2));
+ else
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_Scalar_Type,
+ Scalar_Mode => Iir_Value_E32));
+ end if;
+ Annotate_Range_Expression (Block_Info, Get_Range_Constraint (Def));
+
+ 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 =>
+ List := Get_Index_Subtype_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Annotate_Anonymous_Type_Definition (Block_Info, El);
+ end loop;
+
+ when Iir_Kind_Record_Type_Definition =>
+ List := Get_Elements_Declaration_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El));
+ end loop;
+
+ 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_Mark (Def);
+ Res : String_Acc;
+ begin
+ if Get_Text_File_Flag (Def)
+ or else
+ Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_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_Signal_Interface_Declaration =>
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El));
+ when Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_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_Create_Interface_List
+ (Block_Info: Sim_Info_Acc; Decl_Chain: Iir; With_Types : Boolean)
+ is
+ Decl : Iir;
+ N : Iir_Index32;
+ begin
+ Decl := Decl_Chain;
+ while Decl /= Null_Iir loop
+ if With_Types then
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ end if;
+ Assert_No_Info (Decl);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Add_Signal_Info (Block_Info, Decl);
+ when Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ Create_Object_Info (Block_Info, Decl);
+ when others =>
+ Error_Kind ("annotate_create_interface_list", Decl);
+ end case;
+ N := Block_Info.Nbr_Objects;
+ -- Annotation of the default value must not create objects.
+ -- FIXME: Is it true ???
+ if Block_Info.Nbr_Objects /= N then
+ raise Internal_Error;
+ end if;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Annotate_Create_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) in Iir_Kinds_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_Level : constant Scope_Level_Type := Current_Scope_Level;
+ begin
+ Increment_Current_Scope_Level;
+
+ Assert_No_Info (Subprg);
+
+ Subprg_Info := new Sim_Info_Type'
+ (Kind => Kind_Frame,
+ Inst_Slot => 0,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+ Set_Info (Subprg, Subprg_Info);
+
+ Annotate_Create_Interface_List (Subprg_Info, Interfaces, False);
+
+ Current_Scope_Level := Prev_Scope_Level;
+ 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_Level : constant Scope_Level_Type := Current_Scope_Level;
+ begin
+ -- Do not annotate body of foreign subprograms.
+ if Get_Foreign_Flag (Spec) then
+ return;
+ end if;
+
+ Current_Scope_Level := Subprg_Info.Frame_Scope_Level;
+
+ Annotate_Declaration_List
+ (Subprg_Info, Get_Declaration_Chain (Subprg));
+
+ Annotate_Sequential_Statement_Chain
+ (Subprg_Info, Get_Sequential_Statement_Chain (Subprg));
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Subprogram_Body;
+
+ procedure Annotate_Component_Declaration
+ (Comp: Iir_Component_Declaration)
+ is
+ Info: Sim_Info_Acc;
+ Prev_Scope_Level : Scope_Level_Type;
+ begin
+ Prev_Scope_Level := Current_Scope_Level;
+ Current_Scope_Level := Scope_Level_Component;
+
+ Assert_No_Info (Comp);
+
+ Info := new Sim_Info_Type'
+ (Kind => Kind_Frame,
+ Inst_Slot => Invalid_Slot,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 1, -- For the instance.
+ Elaborated => False);
+ Set_Info (Comp, Info);
+
+ Annotate_Create_Interface_List (Info, Get_Generic_Chain (Comp), True);
+ Annotate_Create_Interface_List (Info, Get_Port_Chain (Comp), True);
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Component_Declaration;
+
+ procedure Annotate_Declaration (Block_Info: Sim_Info_Acc; Decl: Iir) is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Signal_Declaration =>
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Add_Signal_Info (Block_Info, Decl);
+
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Iterator_Declaration =>
+ Assert_No_Info (Decl);
+ 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.
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition
+ (Block_Info, Get_Type (Decl));
+ Create_Object_Info (Block_Info, Decl);
+ else
+ Set_Info (Decl, Get_Info (Get_Deferred_Declaration (Decl)));
+ end if;
+
+ when Iir_Kind_File_Declaration =>
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Create_Object_Info (Block_Info, Decl, Kind_File);
+
+ when Iir_Kind_Terminal_Declaration =>
+ Assert_No_Info (Decl);
+ Add_Terminal_Info (Block_Info, Decl);
+ when Iir_Kinds_Branch_Quantity_Declaration =>
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Add_Quantity_Info (Block_Info, Decl);
+
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Anonymous_Type_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 =>
+ Annotate_Subprogram_Interfaces_Type (Block_Info, Decl);
+ Annotate_Subprogram_Specification (Block_Info, Decl);
+ 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
+ Create_Object_Info (Block_Info, Value);
+ Value := Get_Spec_Chain (Value);
+ end loop;
+ end;
+ when Iir_Kind_Disconnection_Specification =>
+ null;
+
+ when Iir_Kind_Implicit_Procedure_Declaration =>
+ 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_Implicit_Function_Declaration =>
+ null;
+
+ 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 : Iir_Index32;
+ Current_Nbr_Objects : Iir_Index32;
+ begin
+ Current_Nbr_Objects := Block_Info.Nbr_Objects;
+ Max_Nbr_Objects := Block_Info.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_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
+ while Clause /= Null_Iir loop
+ Annotate_Sequential_Statement_Chain
+ (Block_Info, Get_Sequential_Statement_Chain (Clause));
+ Clause := Get_Else_Clause (Clause);
+ end loop;
+ end;
+
+ when Iir_Kind_For_Loop_Statement =>
+ Annotate_Declaration
+ (Block_Info, Get_Iterator_Scheme (El));
+ Annotate_Sequential_Statement_Chain
+ (Block_Info, Get_Sequential_Statement_Chain (El));
+
+ when Iir_Kind_Case_Statement =>
+ declare
+ Assoc: Iir;
+ begin
+ Assoc := Get_Case_Statement_Alternative_Chain (El);
+ while Assoc /= Null_Iir loop
+ Annotate_Sequential_Statement_Chain
+ (Block_Info, Get_Associated (Assoc));
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end;
+
+ 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;
+ -- 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 := Iir_Index32'Max
+ (Block_Info.Nbr_Objects, Max_Nbr_Objects);
+ Block_Info.Nbr_Objects := Current_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;
+ begin
+ Assert_No_Info (Block);
+
+ Increment_Current_Scope_Level;
+
+ Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Block_Info.Nbr_Instances,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+ Set_Info (Block, Info);
+
+ Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1;
+
+ Guard := Get_Guard_Decl (Block);
+ if Guard /= Null_Iir then
+ Add_Signal_Info (Info, Guard);
+ end if;
+ Header := Get_Block_Header (Block);
+ if Header /= Null_Iir then
+ Annotate_Create_Interface_List
+ (Info, Get_Generic_Chain (Header), True);
+ Annotate_Create_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_Level := Current_Scope_Level - 1;
+ end Annotate_Block_Statement;
+
+ procedure Annotate_Generate_Statement
+ (Block_Info : Sim_Info_Acc; Stmt : Iir)
+ is
+ Info : Sim_Info_Acc;
+ Scheme : constant Iir := Get_Generation_Scheme (Stmt);
+ Is_Iterative : constant Boolean :=
+ Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration;
+ begin
+ Assert_No_Info (Stmt);
+
+ Increment_Current_Scope_Level;
+
+ Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Block_Info.Nbr_Instances,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+ Set_Info (Stmt, Info);
+
+ Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1;
+
+ if Is_Iterative then
+ Annotate_Declaration (Info, Scheme);
+ end if;
+ Annotate_Declaration_List (Info, Get_Declaration_Chain (Stmt));
+ Annotate_Concurrent_Statements_List
+ (Info, Get_Concurrent_Statement_Chain (Stmt));
+
+ Current_Scope_Level := Current_Scope_Level - 1;
+ end Annotate_Generate_Statement;
+
+ procedure Annotate_Component_Instantiation_Statement
+ (Block_Info : Sim_Info_Acc; Stmt : Iir)
+ is
+ Info: Sim_Info_Acc;
+ begin
+ -- Add a slot just to put the instance.
+ Assert_No_Info (Stmt);
+ Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Block_Info.Nbr_Instances,
+ Frame_Scope_Level => Current_Scope_Level + 1,
+ Nbr_Objects => 0,
+ Nbr_Instances => 1,
+ Elaborated => False);
+ Set_Info (Stmt, Info);
+ Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1;
+ end Annotate_Component_Instantiation_Statement;
+
+ procedure Annotate_Process_Statement
+ (Block_Info : Sim_Info_Acc; Stmt : Iir)
+ is
+ Info: Sim_Info_Acc;
+ begin
+ Increment_Current_Scope_Level;
+
+ -- Add a slot just to put the instance.
+ Assert_No_Info (Stmt);
+
+ Info := new Sim_Info_Type'
+ (Kind => Kind_Process,
+ Inst_Slot => Block_Info.Nbr_Instances,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+ Set_Info (Stmt, Info);
+
+ Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1;
+
+ Annotate_Declaration_List
+ (Info, Get_Declaration_Chain (Stmt));
+ Annotate_Sequential_Statement_Chain
+ (Info, Get_Sequential_Statement_Chain (Stmt));
+
+ Current_Scope_Level := Current_Scope_Level - 1;
+ 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_Generate_Statement =>
+ Annotate_Generate_Statement (Block_Info, El);
+
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ 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
+ Assert_No_Info (Decl);
+
+ Current_Scope_Level := Scope_Level_Entity;
+
+ Entity_Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Invalid_Slot,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+ Set_Info (Decl, Entity_Info);
+
+ -- generic list.
+ Annotate_Create_Interface_List
+ (Entity_Info, Get_Generic_Chain (Decl), True);
+
+ -- Port list.
+ Annotate_Create_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));
+ end Annotate_Entity;
+
+ procedure Annotate_Architecture (Decl: Iir_Architecture_Declaration) is
+ Entity_Info: Sim_Info_Acc;
+ Arch_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ Current_Scope_Level := Scope_Level_Entity;
+
+ Entity_Info := Get_Info (Get_Entity (Decl));
+
+ Arch_Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => 0, -- Slot for a component
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => Entity_Info.Nbr_Objects,
+ Nbr_Instances => Entity_Info.Nbr_Instances, -- Should be 0.
+ Elaborated => False);
+ 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));
+ end Annotate_Architecture;
+
+ procedure Annotate_Package (Decl: Iir_Package_Declaration) is
+ Package_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ Nbr_Packages := Nbr_Packages + 1;
+ Current_Scope_Level := Scope_Level_Type (-Nbr_Packages);
+
+ Package_Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Nbr_Packages,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+
+ Set_Info (Decl, Package_Info);
+
+ -- declarations
+ Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl));
+
+ Current_Scope_Level := Scope_Level_Global;
+ end Annotate_Package;
+
+ procedure Annotate_Package_Body (Decl: Iir)
+ is
+ Package_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ -- Set info field of package body declaration.
+ Package_Info := Get_Info (Get_Package (Decl));
+ Set_Info (Decl, Package_Info);
+
+ Current_Scope_Level := Package_Info.Frame_Scope_Level;
+
+ -- declarations
+ Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl));
+ 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;
+ Assert_No_Info (Block);
+
+ -- 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
+ Assert_No_Info (Decl);
+
+ Config_Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Invalid_Slot,
+ Frame_Scope_Level => Scope_Level_Global,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0,
+ Elaborated => False);
+
+ Current_Scope_Level := Scope_Level_Global;
+
+ Annotate_Declaration_List (Config_Info, Get_Declaration_Chain (Decl));
+ Annotate_Block_Configuration (Get_Block_Configuration (Decl));
+ end Annotate_Configuration_Declaration;
+
+ package Info_Node is new GNAT.Table
+ (Table_Component_Type => Sim_Info_Acc,
+ Table_Index_Type => Iir,
+ Table_Low_Bound => 2,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ -- Decorate the tree in order to be usable with the internal simulator.
+ procedure Annotate (Tree: Iir_Design_Unit)
+ is
+ El: Iir;
+ begin
+ -- Expand info table.
+ 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;
+
+ El := Get_Library_Unit (Tree);
+ if Trace_Annotation then
+ Ada.Text_IO.Put_Line ("annotating " & Disp_Node (El));
+ end if;
+ case Get_Kind (El) is
+ when Iir_Kind_Entity_Declaration =>
+ Annotate_Entity (El);
+ when Iir_Kind_Architecture_Declaration =>
+ 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 others =>
+ Error_Kind ("annotate2", El);
+ end case;
+ end Annotate;
+
+ -- Disp annotations for an iir node.
+ procedure Disp_Vhdl_Info (Node: Iir) is
+ use Ada.Text_IO;
+ Indent: Count;
+ Info: Sim_Info_Acc;
+ begin
+ Info := Get_Info (Node);
+ Indent := Col;
+ case Info.Kind is
+ when Kind_Block =>
+ Put_Line
+ ("-- nbr objects:" & Iir_Index32'Image (Info.Nbr_Objects));
+
+ when Kind_Frame | Kind_Process =>
+ Put_Line ("-- scope level:" &
+ Scope_Level_Type'Image (Info.Frame_Scope_Level));
+ Set_Col (Indent);
+ Put_Line
+ ("-- nbr objects:" & Iir_Index32'Image (Info.Nbr_Objects));
+
+ when Kind_Object | Kind_Signal | Kind_File
+ | Kind_Terminal | Kind_Quantity =>
+ Put_Line ("-- slot:" & Iir_Index32'Image (Info.Slot)
+ & ", scope:"
+ & Scope_Level_Type'Image (Info.Scope_Level));
+ when Kind_Scalar_Type
+ | Kind_File_Type =>
+ null;
+ when Kind_Range =>
+ Put ("${");
+ Put (Iir_Index32'Image (Info.Slot));
+ Put ("}");
+ 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 level:" &
+ Scope_Level_Type'Image (Info.Frame_Scope_Level));
+ Set_Col (Indent);
+ Put_Line ("inst_slot:" & Iir_Index32'Image (Info.Inst_Slot));
+ Set_Col (Indent);
+ Put_Line ("nbr objects:" & Iir_Index32'Image (Info.Nbr_Objects));
+ Set_Col (Indent);
+ Put_Line ("nbr instance:"
+ & Iir_Index32'Image (Info.Nbr_Instances));
+ when Kind_Object | Kind_Signal | Kind_File
+ | Kind_Terminal | Kind_Quantity =>
+ Put_Line ("slot:" & Iir_Index32'Image (Info.Slot)
+ & ", scope:"
+ & Scope_Level_Type'Image (Info.Scope_Level));
+ when Kind_Range =>
+ Put_Line ("range slot:" & Iir_Index32'Image (Info.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
+ 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/simulate/annotations.ads b/simulate/annotations.ads
new file mode 100644
index 0000000..cf650c9
--- /dev/null
+++ b/simulate/annotations.ads
@@ -0,0 +1,116 @@
+-- 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
+ Trace_Annotation : Boolean := False;
+
+ -- Decorate the tree in order to be usable with the internal simulator.
+ procedure Annotate (Tree: Iir_Design_Unit);
+
+ -- Disp annotations for an iir node.
+ procedure Disp_Vhdl_Info (Node: Iir);
+ procedure Disp_Tree_Info (Node: Iir);
+
+ -- Annotations are used to collect informations for elaboration and to
+ -- locate iir_value_literal for signals, variables or constants.
+
+ -- Scope corresponding to an object.
+ -- Scope_level_global is for objects that can be instancied only one
+ -- time, ie shared signals or constants declared in a package.
+ --
+ -- Scope_Level_Process is for objects declared in an entity, architecture,
+ -- process, bloc (but not generated bloc). These are static objects, that
+ -- can be instancied several times.
+ --
+ -- Scope_Level_First_Function and above are for dynamic objects declared
+ -- in a subprogram. The level is also the nest level.
+ --
+ -- Scope_Level_Component is set to a maximum, since there is at
+ -- most one scope after it (the next one is an entity).
+ type Scope_Level_Type is new Integer;
+ Scope_Level_Global: constant Scope_Level_Type := 0;
+ Scope_Level_Entity: constant Scope_Level_Type := 1;
+ Scope_Level_Component : constant Scope_Level_Type :=
+ Scope_Level_Type'Last - 1;
+
+ Invalid_Slot : constant Iir_Index32 := Iir_Index32'Last;
+
+ -- 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_Range,
+ Kind_File,
+ Kind_Terminal, Kind_Quantity);
+
+ type Sim_Info_Type (Kind: Sim_Info_Kind);
+ type Sim_Info_Acc is access all Sim_Info_Type;
+
+ -- 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 =>
+ -- Only for packages: true if elaborated.
+ Elaborated: Boolean;
+
+ -- Slot number.
+ Inst_Slot : Iir_Index32;
+
+ -- scope level for this frame.
+ Frame_Scope_Level: Scope_Level_Type;
+
+ -- Number of objects/signals.
+ Nbr_Objects: Iir_Index32;
+
+ Nbr_Instances : Iir_Index32;
+
+ when Kind_Object
+ | Kind_Signal
+ | Kind_Range
+ | Kind_File
+ | Kind_Terminal
+ | Kind_Quantity =>
+ -- block considered (hierarchy).
+ Scope_Level: Scope_Level_Type;
+
+ -- Variable index.
+ Slot: Iir_Index32;
+
+ when Kind_Scalar_Type =>
+ Scalar_Mode : Iir_Value_Kind;
+
+ when Kind_File_Type =>
+ File_Signature : String_Acc;
+ end case;
+ end record;
+
+ Nbr_Packages : Iir_Index32 := 0;
+ -- Packages_Last_Info: Sim_Info_Acc := null;
+
+ -- 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);
+end Annotations;
diff --git a/simulate/areapools.adb b/simulate/areapools.adb
new file mode 100644
index 0000000..341b142
--- /dev/null
+++ b/simulate/areapools.adb
@@ -0,0 +1,147 @@
+-- Area based memory manager
+-- 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_Deallocation;
+
+package body Areapools is
+ procedure Deallocate is new Ada.Unchecked_Deallocation
+ (Chunk_Type, Chunk_Acc);
+
+ Free_Chunks : Chunk_Acc;
+
+ function Get_Chunk return Chunk_Acc is
+ Res : Chunk_Acc;
+ begin
+ if Free_Chunks /= null then
+ Res := Free_Chunks;
+ Free_Chunks := Res.Prev;
+ return Res;
+ else
+ return new Chunk_Type (Default_Chunk_Size - 1);
+ end if;
+ end Get_Chunk;
+
+ procedure Free_Chunk (Chunk : Chunk_Acc) is
+ begin
+ Chunk.Prev := Free_Chunks;
+ Free_Chunks := Chunk;
+ end Free_Chunk;
+
+ procedure Allocate (Pool : in out Areapool;
+ Res : out Address;
+ Size : Size_Type;
+ Align : Size_Type)
+ is
+ Align_M1 : constant Size_Type := Align - 1;
+
+ function Do_Align (X : Size_Type) return Size_Type is
+ begin
+ return (X + Align_M1) and not Align_M1;
+ end Do_Align;
+
+ Chunk : Chunk_Acc;
+ begin
+ -- Need to allocate a new chunk if there is no current chunk, or not
+ -- enough room in the current chunk.
+ if Pool.Last = null
+ or else Do_Align (Pool.Next_Use) + Size > Pool.Last.Last
+ then
+ if Size > Default_Chunk_Size then
+ Chunk := new Chunk_Type (Size - 1);
+ else
+ Chunk := Get_Chunk;
+ end if;
+ Chunk.Prev := Pool.Last;
+ Pool.Next_Use := 0;
+ if Pool.First = null then
+ Pool.First := Chunk;
+ end if;
+ Pool.Last := Chunk;
+ else
+ Chunk := Pool.Last;
+ Pool.Next_Use := Do_Align (Pool.Next_Use);
+ end if;
+ Res := Chunk.Data (Pool.Next_Use)'Address;
+ Pool.Next_Use := Pool.Next_Use + Size;
+ end Allocate;
+
+ procedure Mark (M : out Mark_Type; Pool : Areapool) is
+ begin
+ M := (Last => Pool.Last, Next_Use => Pool.Next_Use);
+ end Mark;
+
+ procedure Release (M : Mark_Type; Pool : in out Areapool)
+ is
+ Chunk : Chunk_Acc;
+ Prev : Chunk_Acc;
+ begin
+ Chunk := Pool.Last;
+ while Chunk /= M.Last loop
+ if Erase_When_Released then
+ Chunk.Data := (others => 16#DE#);
+ end if;
+
+ Prev := Chunk.Prev;
+ if Chunk.Last = Default_Chunk_Size - 1 then
+ Free_Chunk (Chunk);
+ else
+ Deallocate (Chunk);
+ end if;
+ Chunk := Prev;
+ end loop;
+
+ if Erase_When_Released
+ and then M.Last /= null
+ then
+ declare
+ Last : Size_Type;
+ begin
+ if Pool.Last = M.Last then
+ Last := Pool.Next_Use - 1;
+ else
+ Last := Chunk.Data'Last;
+ end if;
+ Chunk.Data (M.Next_Use .. Last) := (others => 16#DE#);
+ end;
+ end if;
+
+ Pool.Last := M.Last;
+ Pool.Next_Use := M.Next_Use;
+ end Release;
+
+ function Is_Empty (Pool : Areapool) return Boolean is
+ begin
+ return Pool.Last = null;
+ end Is_Empty;
+
+ function Alloc_On_Pool_Addr (Pool : Areapool_Acc; Val : T)
+ return System.Address
+ is
+ Res : Address;
+ begin
+ Allocate (Pool.all, Res, T'Size / Storage_Unit, T'Alignment);
+ declare
+ Addr1 : constant Address := Res;
+ Init : T := Val;
+ for Init'Address use Addr1;
+ begin
+ null;
+ end;
+ return Res;
+ end Alloc_On_Pool_Addr;
+end Areapools;
diff --git a/simulate/areapools.ads b/simulate/areapools.ads
new file mode 100644
index 0000000..186f297
--- /dev/null
+++ b/simulate/areapools.ads
@@ -0,0 +1,87 @@
+-- Area based memory manager
+-- 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; use System;
+with System.Storage_Elements; use System.Storage_Elements;
+
+package Areapools is
+ type Areapool is limited private;
+ type Mark_Type is private;
+
+ type Areapool_Acc is access all Areapool;
+
+ -- Modular type for the size. We don't use Storage_Offset in order to
+ -- make alignment computation efficient (knowing that alignment is a
+ -- power of two).
+ type Size_Type is mod System.Memory_Size;
+
+ -- Allocate SIZE bytes (aligned on ALIGN bytes) in memory pool POOL and
+ -- return the address in RES.
+ procedure Allocate (Pool : in out Areapool;
+ Res : out Address;
+ Size : Size_Type;
+ Align : Size_Type);
+
+ -- Return TRUE iff no memory is allocated in POOL.
+ function Is_Empty (Pool : Areapool) return Boolean;
+
+ -- Higher level abstraction for Allocate.
+ generic
+ type T is private;
+ function Alloc_On_Pool_Addr (Pool : Areapool_Acc; Val : T)
+ return System.Address;
+
+ -- Get a mark of POOL.
+ procedure Mark (M : out Mark_Type;
+ Pool : Areapool);
+
+ -- Release memory allocated in POOL after mark M.
+ procedure Release (M : Mark_Type;
+ Pool : in out Areapool);
+
+ Empty_Marker : constant Mark_Type;
+private
+ -- Minimal size of allocation.
+ Default_Chunk_Size : constant Size_Type := 16 * 1024;
+
+ type Chunk_Type;
+ type Chunk_Acc is access all Chunk_Type;
+
+ type Data_Array is array (Size_Type range <>) of Storage_Element;
+ for Data_Array'Alignment use Standard'Maximum_Alignment;
+
+ type Chunk_Type (Last : Size_Type) is record
+ Prev : Chunk_Acc;
+ Data : Data_Array (0 .. Last);
+ end record;
+ for Chunk_Type'Alignment use Standard'Maximum_Alignment;
+
+ type Areapool is limited record
+ First, Last : Chunk_Acc := null;
+ Next_Use : Size_Type;
+ end record;
+
+ type Mark_Type is record
+ Last : Chunk_Acc := null;
+ Next_Use : Size_Type;
+ end record;
+
+ Empty_Marker : constant Mark_Type := (Last => null, Next_Use => 0);
+
+ Erase_When_Released : constant Boolean := True;
+end Areapools;
diff --git a/simulate/debugger.adb b/simulate/debugger.adb
new file mode 100644
index 0000000..f669b09
--- /dev/null
+++ b/simulate/debugger.adb
@@ -0,0 +1,1632 @@
+-- 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 GNAT.Table;
+with Types; use Types;
+with Iir_Values; use Iir_Values;
+with Name_Table;
+with Files_Map;
+with Parse;
+with Scanner;
+with Tokens;
+with Sem_Expr;
+with Sem_Scopes;
+with Std_Names;
+with Libraries;
+with Std_Package;
+with Annotations; use Annotations;
+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.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;
+
+ 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 GNAT.Table
+ (Table_Index_Type => Natural,
+ Table_Component_Type => Breakpoint_Entry,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ -- 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 statement in the same frame.
+ Exec_Next);
+
+ Exec_State : Exec_State_Type := Exec_Run;
+
+ Exec_Instance : Block_Instance_Acc;
+
+ -- Disp a message during execution.
+ procedure Error_Msg_Exec (Msg: String; Loc: in Iir) is
+ begin
+ Disp_Iir_Location (Loc);
+ Put (Standard_Error, ' ');
+ 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_Signal_Interface_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
+ begin
+ if Instance.Name = Null_Iir then
+ return "<anon>";
+ end if;
+
+ case Get_Kind (Instance.Name) is
+ when Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kinds_Process_Statement =>
+ return Image_Identifier (Instance.Name);
+ when Iir_Kind_Architecture_Declaration =>
+ if Short then
+ return Image_Identifier (Get_Entity (Instance.Name));
+ else
+ return Image_Identifier (Get_Entity (Instance.Name))
+ & '(' & Image_Identifier (Instance.Name) & ')';
+ end if;
+ when others =>
+ Error_Kind ("disp_instance_local_name", Instance.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_All_Instances1 (Inst : Block_Instance_Acc) is
+ begin
+ if Inst = null then
+ return;
+ end if;
+ Put (Get_Instance_Local_Name (Inst));
+ New_Line;
+
+ if Inst.Instances /= null then
+ for I in Inst.Instances'Range loop
+ Disp_All_Instances1 (Inst.Instances (I));
+ end loop;
+ end if;
+ end Disp_All_Instances1;
+
+ procedure Disp_All_Instances is
+ begin
+ Disp_All_Instances1 (Top_Instance);
+ end Disp_All_Instances;
+
+ procedure Disp_Instances_Tree1 (Inst : Block_Instance_Acc; Pfx : String) is
+ begin
+ Put (Pfx);
+ if Inst = null then
+ Put ("*null*");
+ New_Line;
+ return;
+ end if;
+ Put (Get_Instance_Local_Name (Inst));
+
+ Put (" ");
+ case Get_Kind (Inst.Name) is
+ when Iir_Kind_Block_Statement =>
+ Put ("[block]");
+ when Iir_Kind_Generate_Statement =>
+ 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_Declaration =>
+ Put ("[entity]");
+ when others =>
+ Error_Kind ("disp_instances_tree1", Inst.Name);
+ end case;
+ New_Line;
+
+ if Inst.Instances /= null then
+ for I in Inst.Instances'Range loop
+ Disp_Instances_Tree1
+ (Inst.Instances (I), Pfx & Iir_Index32'Image (I) & ": ");
+ end loop;
+ end if;
+ end Disp_Instances_Tree1;
+
+ procedure Disp_Instances_Tree is
+ begin
+ 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 level:"
+ & Scope_Level_Type'Image (Instance.Scope_Level));
+ Put_Line ("Objects:");
+ for I in Instance.Objects'Range loop
+ Put (Iir_Index32'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
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Get_Base_Type (A_Type));
+ 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_I64
+ | Iir_Value_F64
+ | Iir_Value_E32
+ | Iir_Value_B2
+ | Iir_Value_Access =>
+ Disp_Iir_Value (Value, A_Type);
+ --Disp_Signal_Status (Signals.Table (Indirect.Index), Status);
+ 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 =>
+ 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 (Name_Table.Image (Get_Identifier (Decl)));
+ Put (" = ");
+ Disp_Signal (Instance.Objects (Info.Slot), Get_Type (Decl));
+ New_Line;
+ end Disp_Instance_Signal;
+
+ procedure Disp_Instance_Signals (Instance: Block_Instance_Acc)
+ is
+ Blk : constant Iir := Instance.Name;
+ Child: Block_Instance_Acc;
+ begin
+ case Get_Kind (Blk) is
+ when Iir_Kind_Architecture_Declaration =>
+ declare
+ Ent : constant Iir := Get_Entity (Blk);
+ El : Iir;
+ begin
+ El := Get_Port_Chain (Ent);
+ while El /= Null_Iir loop
+ Disp_Instance_Signal (Instance, El);
+ El := Get_Chain (El);
+ end loop;
+
+ El := Get_Declaration_Chain (Blk);
+ while El /= Null_Iir loop
+ if Get_Kind (El) = Iir_Kind_Signal_Declaration then
+ Disp_Instance_Signal (Instance, El);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end;
+ when others =>
+ Error_Kind ("disp_instance_signals", Instance.Name);
+ end case;
+
+ if Trace_All_Signals then
+ Child := Instance.Children;
+ while Child /= null loop
+ Disp_Instance_Signals (Child);
+ Child := Child.Brother;
+ end loop;
+ end if;
+ 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_Objects_Value is
+ begin
+ null;
+-- -- Disp the results.
+-- for I in 0 .. Variables.Last loop
+-- Put (Get_String (Variables.Table (I).Name.all));
+-- Put (" = ");
+-- Put (Get_Str_Value
+-- (Get_Literal (variables.Table (I).Value.all),
+-- Get_Type (variables.Table (I).Value.all)));
+-- if I = variables.Last then
+-- Put_Line (";");
+-- else
+-- Put (", ");
+-- end if;
+-- end loop;
+ end Disp_Objects_Value;
+
+ procedure Disp_Label (Process : Iir)
+ is
+ Label : Name_Id;
+ begin
+ Label := Get_Label (Process);
+ if Label = Null_Identifier then
+ Put ("<unlabeled>");
+ else
+ Put (Name_Table.Image (Label));
+ end if;
+ end Disp_Label;
+
+ procedure Disp_Declaration_Objects
+ (Instance : Block_Instance_Acc; Decl_Chain : Iir)
+ is
+ El : Iir;
+ begin
+ El := Decl_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration
+ | Iir_Kind_Object_Alias_Declaration =>
+ Put (Disp_Node (El));
+ Put (" = ");
+ Disp_Value_Tab (Instance.Objects (Get_Info (El).Slot), 3);
+ when Iir_Kind_Signal_Interface_Declaration =>
+ declare
+ Sig : Iir_Value_Literal_Acc;
+ begin
+ Sig := Instance.Objects (Get_Info (El).Slot);
+ Put (Disp_Node (El));
+ Put (" = ");
+ Disp_Signal (Sig, Get_Type (El));
+ New_Line;
+ end;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ -- FIXME: disp ranges
+ null;
+ when Iir_Kind_Implicit_Function_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("disp_declaration_objects", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Disp_Declaration_Objects;
+
+ procedure Disp_Objects (Instance : Block_Instance_Acc)
+ is
+ Decl : constant Iir := Instance.Name;
+ 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_Declaration =>
+ 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);
+
+ 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
+ is
+ Stmt : Iir := Chain;
+ begin
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Process_Statement =>
+ if Walk_Decl_Chain (Get_Declaration_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_Declaration =>
+ 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 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;
+
+ 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;
+ end Get_Word;
+
+ procedure Disp_A_Frame (Instance: Block_Instance_Acc) is
+ begin
+ Put (Disp_Node (Instance.Name));
+ if Instance.Cur_Stmt /= Null_Iir then
+ Put (" at ");
+ Put (Get_Location_Str (Get_Location (Instance.Cur_Stmt)));
+ end if;
+ New_Line;
+ end Disp_A_Frame;
+
+ 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_Procedure is access procedure (Line : 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 (" (" & Get_Location_Str (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 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: " & Get_Location_Str (Get_Location (Stmt)));
+ Breakpoints.Append (Breakpoint_Entry'(Stmt => Stmt));
+ Flag_Need_Debug := True;
+ end Set_Breakpoint;
+
+ 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;
+ 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;
+ 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 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);
+ Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last));
+ 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_All_Instances;
+ end if;
+ end Info_Tree_Proc;
+
+ procedure Info_Params_Proc (Line : String)
+ is
+ pragma Unreferenced (Line);
+ Decl : Iir;
+ Params : Iir;
+ begin
+ Check_Current_Process;
+ Decl := Dbg_Cur_Frame.Name;
+ 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_Declaration =>
+ Put ("architecture ");
+ Put (Name_Table.Image (Get_Identifier (El)));
+ Put (" of ");
+ Put_Line (Name_Table.Image (Get_Identifier (Get_Entity (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_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_Signal_Interface_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_Declaration =>
+ 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_Declaration =>
+ 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
+ Check_Current_Process;
+ Disp_Declared_Signals
+ (Current_Process.Proc, Current_Process.Top_Instance);
+ 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_Declaration =>
+ Foreach_Scopes (Get_Entity (N), Handler);
+ Handler.all (N);
+
+ when Iir_Kind_Entity_Declaration =>
+ -- Top of scopes.
+ null;
+
+ 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_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 =>
+ Foreach_Scopes (Get_Parent (N), Handler);
+
+ when Iir_Kind_For_Loop_Statement =>
+ 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_Declaration =>
+ 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 =>
+ Open_Declarative_Region;
+ Add_Name (Get_Iterator_Scheme (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.Std_Standard_Unit);
+
+ 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_Declaration =>
+ 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 =>
+ Close_Declarative_Region;
+ when others =>
+ Error_Kind ("Leave_scope(2)", 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;
+ 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;
+ 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.Cur_Stmt);
+ Expr := Sem_Expr.Sem_Expression_Universal (Expr);
+ Leave_Scope (Dbg_Cur_Frame.Cur_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;
+
+ Mark (Marker, Expr_Pool);
+
+ Res := Execute_Expression (Dbg_Cur_Frame, Expr);
+ if Opt_Value then
+ Disp_Value (Res);
+ else
+ Disp_Signal (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_Tree : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("tree"),
+ Next => null,
+ 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_Down : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("down"),
+ Next => null,
+ 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_Next : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("n*ext"),
+ Next => Menu_Up'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 - 1));
+ if Menu = null then
+ Put_Line ("command '" & Line (P .. E - 1) & "' not found");
+ end if;
+ P := E;
+ 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;
+
+ 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;
+
+ function Breakpoint_Hit return Natural
+ is
+ Stmt : constant Iir := Current_Process.Instance.Cur_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.
+ if Reason /= Reason_Internal_Debug then
+ if not Flag_Interractive then
+ return;
+ end if;
+ end if;
+
+ 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 =>
+ -- Default state.
+ Exec_State := Exec_Run;
+ when Exec_Next =>
+ if Current_Process.Instance /= Exec_Instance then
+ return;
+ end if;
+ -- Default state.
+ Exec_State := Exec_Run;
+ end case;
+ Set_Top_Frame (Current_Process.Instance);
+ declare
+ Stmt : constant Iir := Dbg_Cur_Frame.Cur_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;
+
+ Command_Status := Status_Default;
+
+ loop
+ loop
+ Raw_Line := Readline (Prompt);
+ -- Skip empty lines
+ exit when Raw_Line /= null and then Raw_Line (1) /= ASCII.NUL;
+ 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/simulate/debugger.ads b/simulate/debugger.ads
new file mode 100644
index 0000000..86a77c2
--- /dev/null
+++ b/simulate/debugger.ads
@@ -0,0 +1,89 @@
+-- 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 Elaboration; use Elaboration;
+with Iirs; use Iirs;
+
+package Debugger is
+ 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);
+
+ Trace_All_Signals : Boolean := False;
+
+ -- 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 <unlabeled> if PROCESS has no label.
+ procedure Disp_Label (Process : Iir);
+
+ -- Disp all signals name and values.
+ procedure Disp_Signals_Value;
+
+ procedure Disp_Objects_Value;
+
+ -- 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/simulate/elaboration.adb b/simulate/elaboration.adb
new file mode 100644
index 0000000..86941d7
--- /dev/null
+++ b/simulate/elaboration.adb
@@ -0,0 +1,2513 @@
+-- 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 Errorout; use Errorout;
+with Execution; use Execution;
+with Simulation; use Simulation;
+with Iirs_Utils; use Iirs_Utils;
+with Libraries;
+with Name_Table;
+with File_Operation;
+with Debugger; use Debugger;
+with Iir_Chains; use Iir_Chains;
+with Sem_Names;
+with Grt.Types; use Grt.Types;
+with Simulation.AMS; use Simulation.AMS;
+with Areapools; use Areapools;
+with Grt.Errors;
+
+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;
+
+ -- CONF is the block_configuration for components of ARCH.
+ function Elaborate_Architecture (Arch : Iir_Architecture_Declaration;
+ Conf : Iir_Block_Configuration;
+ Parent_Instance : Block_Instance_Acc;
+ Stmt : Iir;
+ Generic_Map : Iir;
+ Port_Map : Iir)
+ return Block_Instance_Acc;
+
+ -- 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_I64
+ | Iir_Value_F64
+ | Iir_Value_B2
+ | Iir_Value_E32 =>
+ 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 =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Create_Signal;
+
+ Sig : Iir_Value_Literal_Acc;
+ Def : Iir_Value_Literal_Acc;
+ Slot : constant Iir_Index32 := Get_Info (Signal).Slot;
+ begin
+ Sig := Create_Signal (Default);
+ Def := Unshare (Default, Global_Pool'Access);
+ Block.Objects (Slot) := Sig;
+ Block.Objects (Slot + 1) := Def;
+
+ Signals_Table.Append ((Kind => User_Signal,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Block,
+ Init => Def));
+ 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 : Signal_Type_Kind)
+ 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 = Implicit_Transaction then
+ T := 0;
+ Init := Create_B2_Value (False);
+ else
+ T := Execute_Time_Attribute (Instance, Signal);
+ Init := Create_B2_Value (False);
+ end if;
+ Sig := Create_Signal_Value (null);
+ Instance.Objects (Info.Slot) := Sig;
+ Instance.Objects (Info.Slot + 1) := Unshare (Init, Global_Pool'Access);
+
+ Prefix := Execute_Name (Instance, Get_Prefix (Signal), True);
+ Prefix := Unshare_Bounds (Prefix, Global_Pool'Access);
+ case Kind is
+ when Implicit_Stable =>
+ Signals_Table.Append ((Kind => Implicit_Stable,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Instance,
+ Time => T,
+ Prefix => Prefix));
+ when Implicit_Quiet =>
+ Signals_Table.Append ((Kind => Implicit_Quiet,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Instance,
+ Time => T,
+ Prefix => Prefix));
+ when Implicit_Transaction =>
+ Signals_Table.Append ((Kind => Implicit_Transaction,
+ Decl => Signal,
+ Sig => Sig,
+ 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);
+ Instance.Objects (Info.Slot) := Sig;
+
+ Init := Execute_Signal_Init_Value (Instance, Get_Prefix (Signal));
+ Init := Unshare_Bounds (Init, Global_Pool'Access);
+ Instance.Objects (Info.Slot + 1) := Init;
+
+ Signals_Table.Append ((Kind => Implicit_Delayed,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Instance,
+ Time => T,
+ Prefix => Prefix));
+ end Elaborate_Delayed_Signal;
+
+ procedure Elaborate_Package (Decl: Iir)
+ is
+ Package_Info : constant Sim_Info_Acc := Get_Info (Decl);
+ Instance : Block_Instance_Acc;
+ begin
+ if Package_Info.Elaborated then
+ return;
+ end if;
+
+ -- Create packages_instance only if it was not already created.
+ Instance := new Block_Instance_Type'
+ (Max_Objs => Package_Info.Nbr_Objects,
+ Scope_Level => Package_Info.Frame_Scope_Level,
+ Up_Block => null,
+ Name => Decl,
+ Parent => null,
+ Children => null,
+ Brother => null,
+ Configuration => Null_Iir,
+ Marker => Empty_Marker,
+ Objects => (others => null),
+ Elab_Objects => 0,
+ Instances => null,
+ In_Wait_Flag => False,
+ Cur_Stmt => Null_Iir,
+ Actuals_Ref => null,
+ Result => null);
+
+ Package_Instances (Package_Info.Inst_Slot) := Instance;
+
+ if Trace_Elaboration then
+ Ada.Text_IO.Put_Line ("elaborating " & Disp_Node (Decl));
+ end if;
+
+ -- Elaborate objects declarations.
+ Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl));
+ Package_Info.Elaborated := True;
+ 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 (Iir_Index32 (-Package_Info.Frame_Scope_Level));
+
+ if Trace_Elaboration then
+ Ada.Text_IO.Put_Line ("elaborating " & Disp_Node (Decl));
+ end if;
+
+ -- Elaborate objects declarations.
+ Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl));
+ end Elaborate_Package_Body;
+
+ -- 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: Iir_Design_Unit_List;
+ Design: Iir;
+ Library_Unit: Iir;
+ Body_Design: Iir_Design_Unit;
+ Need_A_Body: Boolean;
+ begin
+ Depend_List := Get_Dependence_List (Design_Unit);
+
+ for I in Natural loop
+ Design := Get_Nth_Element (Depend_List, I);
+ exit when Design = Null_Iir;
+ 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 := Get_Architecture (Design);
+ Design := Get_Design_Unit (Library_Unit);
+ 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 =>
+ if not Get_Info (Library_Unit).Elaborated then
+ Body_Design := Libraries.Load_Secondary_Unit
+ (Design, Null_Identifier, Design_Unit);
+ -- First the packages on which DESIGN depends.
+ Elaborate_Dependence (Design);
+ -- Then the declaration.
+ Elaborate_Package (Library_Unit);
+ Need_A_Body := Get_Need_Body (Library_Unit);
+ if Body_Design = Null_Iir then
+ if Need_A_Body then
+ Error_Msg_Elab ("no package body for `" &
+ Image_Identifier (Library_Unit) & ''');
+ end if;
+ else
+ -- Then the body (this can elaborate some packages).
+ Elaborate_Package_Body (Get_Library_Unit (Body_Design));
+ end if;
+ end if;
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Architecture_Declaration =>
+ Elaborate_Dependence (Design);
+ when others =>
+ Error_Kind ("elaborate_dependence", Library_Unit);
+ end case;
+ end loop;
+ end Elaborate_Dependence;
+
+ -- 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
+ Res := new Block_Instance_Type'
+ (Max_Objs => Obj_Info.Nbr_Objects,
+ Scope_Level => Obj_Info.Frame_Scope_Level,
+ Up_Block => Father,
+ Name => Stmt,
+ Parent => Father,
+ Children => null,
+ Brother => null,
+ Configuration => Null_Iir,
+ Marker => Empty_Marker,
+ Objects => (others => null),
+ Elab_Objects => 0,
+ Instances => null,
+ In_Wait_Flag => False,
+ Cur_Stmt => Null_Iir,
+ Actuals_Ref => null,
+ Result => null);
+ Res.Instances :=
+ new Block_Instance_Acc_Array (0 .. Obj_Info.Nbr_Instances - 1);
+
+ if Father /= null then
+ Res.Brother := Father.Children;
+ Father.Children := Res;
+ Father.Instances (Get_Info (Stmt).Inst_Slot) := Res;
+ end if;
+
+ return Res;
+ end Create_Block_Instance;
+
+ 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, Bod);
+ Protected_Table.Table (Res.Prot) := Inst;
+ Elaborate_Declarative_Part (Inst, Get_Declaration_Chain (Bod));
+
+ 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; Default : Boolean)
+ 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 =>
+ if Default then
+ Bounds := Execute_Bounds (Block, Decl);
+ Res := Bounds.Left;
+ else
+ case Get_Info (Get_Base_Type (Decl)).Scalar_Mode is
+ when Iir_Value_B2 =>
+ Res := Create_B2_Value (False);
+ 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);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ Res := Create_Array_Bounds_From_Type (Block, Decl, True);
+ declare
+ El : Iir_Value_Literal_Acc;
+ begin
+ if Res.Val_Array.Len > 0 then
+ El := Create_Value_For_Type
+ (Block, Get_Element_Subtype (Decl), Default);
+ Res.Val_Array.V (1) := El;
+ for I in 2 .. Res.Val_Array.Len loop
+ Res.Val_Array.V (I) := El;
+ end loop;
+ end if;
+ end;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El : Iir_Element_Declaration;
+ List : constant Iir_List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Decl));
+ begin
+ Res := Create_Record_Value
+ (Iir_Index32 (Get_Nbr_Elements (List)));
+
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Res.Val_Record.V (1 + Get_Element_Position (El)) :=
+ Create_Value_For_Type (Block, Get_Type (El), Default);
+ 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 Create_Object (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Slot : constant Iir_Index32 := Get_Info (Decl).Slot;
+ 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;
+ end Create_Object;
+
+ procedure Destroy_Object (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Info : constant Sim_Info_Acc := Get_Info (Decl);
+ Slot : constant Iir_Index32 := Info.Slot;
+ begin
+ if Slot /= Instance.Elab_Objects
+ or else Info.Scope_Level /= Instance.Scope_Level
+ 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 Iir_Index32 := Get_Info (Decl).Slot;
+ begin
+ if Slot /= Instance.Elab_Objects + 1
+ or else Instance.Objects (Slot) /= null
+ then
+ Error_Msg_Elab ("bad elaboration order");
+ raise Internal_Error;
+ end if;
+ -- One slot is reserved for default value
+ Instance.Elab_Objects := Slot + 1;
+ end Create_Signal;
+
+ 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 : Iir_Index32;
+ begin
+ Slot := Get_Info (Decl).Slot;
+ 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 : Iir_Index32;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Slot := Get_Info (Decl).Slot;
+ 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;
+
+ function Elaborate_Bound_Constraint
+ (Instance : Block_Instance_Acc; Bound: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Value : Iir_Value_Literal_Acc;
+ Ref : Iir;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Ref := Get_Type (Bound);
+ Res := Create_Value_For_Type (Instance, Ref, False);
+ Res := Unshare (Res, Instance_Pool);
+ Value := Execute_Expression (Instance, Bound);
+ Assign_Value_To_Object (Instance, Res, Ref, Value, Bound);
+ return Res;
+ end Elaborate_Bound_Constraint;
+
+ procedure Elaborate_Range_Expression
+ (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);
+ if Range_Info.Scope_Level /= Instance.Scope_Level
+ 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.Scope_Level /= Instance.Scope_Level
+ 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
+ (Elaborate_Bound_Constraint (Instance, Get_Left_Limit (Rc)),
+ Elaborate_Bound_Constraint (Instance, Get_Right_Limit (Rc)),
+ Get_Direction (Rc));
+ 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 : Iir_List;
+ St_El : Iir;
+ begin
+ St_Indexes := Get_Index_Subtype_List (Ind);
+ for I in Natural loop
+ St_El := Get_Nth_Element (St_Indexes, I);
+ exit when St_El = Null_Iir;
+ 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
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ -- 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 (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
+ procedure Elaborate_Generic_Clause
+ (Instance : Block_Instance_Acc; Generic_Chain : Iir)
+ is
+ Decl : Iir_Constant_Interface_Declaration;
+ begin
+ -- 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
+ -- 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.
+ 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_Signal_Interface_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;
+ Map : Iir)
+ is
+ Assoc : Iir;
+ Inter : Iir_Constant_Interface_Declaration;
+ Value : Iir;
+ Val : Iir_Value_Literal_Acc;
+ Last_Individual : Iir_Value_Literal_Acc;
+ 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;
+ 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_Formal (Assoc);
+ 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
+ Error_Msg_Exec ("no default value", Inter);
+ return;
+ end if;
+ Val := Execute_Expression (Target_Instance, Value);
+ 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), False);
+
+ Last_Individual := Unshare (Val, Instance_Pool);
+ Target_Instance.Objects (Get_Info (Inter).Slot) :=
+ Last_Individual;
+ 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;
+
+ <<Continue>> null;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Elaborate_Generic_Map_Aspect;
+
+ -- Return TRUE if EXPR is a signal name.
+ function Is_Signal (Expr : Iir) return Boolean
+ is
+ Obj : Iir;
+ begin
+ Obj := Sem_Names.Name_To_Object (Expr);
+ if Obj /= Null_Iir then
+ return Is_Signal_Object (Obj);
+ else
+ return False;
+ end if;
+ end Is_Signal;
+
+ -- LRM93 12.2.3 The Port Clause
+ procedure Elaborate_Port_Declaration
+ (Instance : Block_Instance_Acc;
+ Decl : Iir_Signal_Interface_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)
+ is
+ Inter : Iir;
+ Actual : Iir;
+ Local_Expr : Iir_Value_Literal_Acc;
+ Formal_Expr : Iir_Value_Literal_Acc;
+ begin
+ Inter := Get_Formal (Assoc);
+ Actual := Get_Actual (Assoc);
+ Formal_Expr := Execute_Name (Formal_Instance, Inter, 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,
+ 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;
+ Inter : Iir_Signal_Interface_Declaration;
+ Actual_Expr : Iir_Value_Literal_Acc;
+ Init_Expr : Iir_Value_Literal_Acc;
+ Actual : Iir;
+ begin
+ 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;
+
+ Current_Component := Formal_Instance;
+
+ Assoc := Map;
+ 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_Formal (Assoc);
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ if Get_In_Conversion (Assoc) = Null_Iir
+ and then Get_Out_Conversion (Assoc) = Null_Iir
+ then
+ Actual := Get_Actual (Assoc);
+ if Is_Signal (Actual) then
+ -- Association with a signal
+ Init_Expr := Execute_Signal_Init_Value
+ (Actual_Instance, Actual);
+ Implicit_Array_Conversion
+ (Formal_Instance, Init_Expr, Get_Type (Inter), 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 (Inter), 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) 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);
+
+ 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), False);
+ Elaborate_Signal (Formal_Instance, Inter, Init_Expr);
+
+ when others =>
+ Error_Kind ("elaborate_port_map_aspect", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+
+ Current_Component := null;
+ 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_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 : Iir_Value_Literal_Acc;
+ Info : constant Sim_Info_Acc := Get_Info (Guard);
+ begin
+ Create_Signal (Instance, Guard);
+
+ Sig := Create_Signal_Value (null);
+ Instance.Objects (Info.Slot) := Sig;
+ Instance.Objects (Info.Slot + 1) :=
+ Unshare (Create_B2_Value (False), Instance_Pool);
+
+ Signals_Table.Append ((Kind => Guard_Signal,
+ Decl => Guard,
+ Sig => Sig,
+ 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 ("cannot create default map aspect", Node);
+ 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
+ ("cannot associate local " & Disp_Node (Local), Node);
+ 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
+ Component : constant Iir := Get_Instantiated_Unit (Stmt);
+ Frame : Block_Instance_Acc;
+ begin
+ if Get_Kind (Component) = Iir_Kind_Component_Declaration then
+
+ -- 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);
+
+ Elaborate_Generic_Clause (Frame, Get_Generic_Chain (Component));
+ Elaborate_Generic_Map_Aspect
+ (Frame, Instance, 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));
+ else
+ -- Direct instantiation
+ declare
+ Aspect : constant Iir := Component;
+ Entity_Unit : Iir;
+ Arch : Iir;
+ Config : Iir;
+ begin
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Entity_Unit := Get_Entity (Aspect);
+ Arch := Get_Architecture (Aspect);
+ if Arch = Null_Iir then
+ Arch := Libraries.Get_Latest_Architecture
+ (Get_Library_Unit (Entity_Unit));
+ end if;
+ Config := Get_Default_Configuration_Declaration (Arch);
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ Config := Get_Configuration (Aspect);
+ Entity_Unit := Get_Entity (Config);
+ 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 (Get_Library_Unit (Config));
+
+ Frame := Elaborate_Architecture
+ (Arch, Config, Instance, Stmt,
+ Get_Generic_Map_Aspect_Chain (Stmt),
+ Get_Port_Map_Aspect_Chain (Stmt));
+
+ -- FIXME Create_Block_Instance.
+ -- Make the difference between the father in the hierachy and
+ -- the father in instances. Be sure that architecture is
+ -- elaborated.
+ Frame.Up_Block := null; -- Packages_Instance;
+ Frame.Name := Arch;
+ end;
+ end if;
+ end Elaborate_Component_Instantiation;
+
+ -- LRM93 12.4.2 Generate Statements
+ procedure Elaborate_Conditional_Generate_Statement
+ (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement)
+ is
+ Scheme : 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.
+ Scheme := Get_Generation_Scheme (Generate);
+ Lit := Execute_Expression (Instance, Scheme);
+ if Lit.B2 /= True then
+ return;
+ end if;
+
+ -- 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.
+ Ninstance := Create_Block_Instance (Instance, Generate, Generate);
+ Elaborate_Declarative_Part (Ninstance, Get_Declaration_Chain (Generate));
+ Elaborate_Statement_Part
+ (Ninstance, Get_Concurrent_Statement_Chain (Generate));
+ end Elaborate_Conditional_Generate_Statement;
+
+ -- LRM93 12.4.2 Generate Statements
+ procedure Elaborate_Iterative_Generate_Statement
+ (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement)
+ is
+ Info : constant Sim_Info_Acc := Get_Info (Generate);
+ Scheme : constant Iir_Iterator_Declaration :=
+ Get_Generation_Scheme (Generate);
+ Ninstance : Block_Instance_Acc;
+ Bound, Index : Iir_Value_Literal_Acc;
+ Shadow : Block_Instance_Acc;
+ Idx : Iir_Index32;
+ begin
+ -- LRM93 12.4.2
+ -- For a generate statement with a for generation scheme, elaboration
+ -- consists of the elaboration of the discrete range
+
+ Shadow := new Block_Instance_Type'
+ (Max_Objs => 1,
+ Scope_Level => Info.Frame_Scope_Level,
+ Up_Block => Instance,
+ Name => Scheme,
+ Parent => Instance,
+ Children => null,
+ Brother => Instance.Children,
+ Configuration => Null_Iir,
+ Marker => Empty_Marker,
+ Objects => (others => null),
+ Elab_Objects => 0,
+ Instances => null,
+ In_Wait_Flag => False,
+ Cur_Stmt => Null_Iir,
+ Actuals_Ref => null,
+ Result => null);
+ Instance.Children := Shadow;
+ Instance.Instances (Info.Inst_Slot) := Shadow;
+
+ Ninstance := Create_Block_Instance (null, Generate, Generate);
+ Ninstance.Parent := Shadow;
+ Ninstance.Up_Block := Instance;
+
+ Elaborate_Declaration (Ninstance, Scheme);
+ Bound := Execute_Bounds (Ninstance, Get_Type (Scheme));
+ Shadow.Objects (1) := Bound; -- FIXME: should be in the instance pool.
+
+ -- Index is the iterator value.
+ Index := Unshare (Ninstance.Objects (Get_Info (Scheme).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 ??
+ raise Internal_Error;
+ return;
+ end if;
+ Idx := 0;
+ Shadow.Instances := new Block_Instance_Acc_Array (0 .. Bound.Length - 1);
+ loop
+ Shadow.Instances (Idx) := Ninstance;
+ Ninstance.Brother := Shadow.Children;
+ Shadow.Children := Ninstance;
+
+ -- Store index.
+ Store (Ninstance.Objects (Get_Info (Scheme).Slot), Index);
+ Elaborate_Declarative_Part
+ (Ninstance, Get_Declaration_Chain (Generate));
+ Elaborate_Statement_Part
+ (Ninstance, Get_Concurrent_Statement_Chain (Generate));
+ Update_Loop_Index (Index, Bound);
+ exit when not Is_In_Range (Index, Bound);
+
+ -- Next instance.
+ Ninstance := Create_Block_Instance (null, Generate, Generate);
+ Ninstance.Parent := Shadow;
+ Ninstance.Up_Block := Instance;
+
+ Elaborate_Declaration (Ninstance, Scheme);
+ Idx := Idx + 1;
+ end loop;
+ -- FIXME: destroy index ?
+ end Elaborate_Iterative_Generate_Statement;
+
+ procedure Elaborate_Generate_Statement
+ (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement)
+ is
+ Scheme : Iir;
+ begin
+ Scheme := Get_Generation_Scheme (Generate);
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Elaborate_Iterative_Generate_Statement (Instance, Generate);
+ else
+ Elaborate_Conditional_Generate_Statement (Instance, Generate);
+ end if;
+ end Elaborate_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;
+
+ -- 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_Generate_Statement =>
+ Elaborate_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 others =>
+ Error_Kind ("elaborate_statement_part", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ 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), True);
+ 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_Signal_Interface_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_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;
+ Instance : Block_Instance_Acc;
+ Conf : Iir_Component_Configuration)
+ is
+ Component : constant Iir_Component_Declaration :=
+ Get_Instantiated_Unit (Stmt);
+ Stmt_Info : constant Sim_Info_Acc := Get_Info (Stmt);
+ Frame : Block_Instance_Acc;
+ Entity_Design : Iir_Design_Unit;
+ Entity : Iir_Entity_Declaration;
+ Arch_Name : Name_Id;
+ Arch_Design : Iir_Design_Unit;
+ Arch : Iir_Architecture_Declaration;
+ Arch_Frame : Block_Instance_Acc;
+ pragma Unreferenced (Arch_Frame);
+ Generic_Map_Aspect_Chain : Iir;
+ Port_Map_Aspect_Chain : Iir;
+ Unit : 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 (Disp_Node (Stmt) & " not bound");
+ 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.
+ Frame := Instance.Instances (Stmt_Info.Inst_Slot);
+
+ -- 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 =>
+ Entity_Design := Aspect;
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Entity_Design := Get_Entity (Aspect);
+ if Get_Architecture (Aspect) /= Null_Iir then
+ Arch_Name := Get_Identifier (Get_Architecture (Aspect));
+ end if;
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ if Sub_Conf /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ declare
+ Cf : Iir;
+ begin
+ Cf := Get_Configuration (Aspect);
+ Cf := Get_Library_Unit (Cf);
+ Entity_Design := Get_Entity (Cf);
+ Sub_Conf := Get_Block_Configuration (Cf);
+ Arch := Get_Block_Specification (Sub_Conf);
+ end;
+ when others =>
+ Error_Kind ("elaborate_component_declaration0", Aspect);
+ end case;
+
+ Unit := Get_Library_Unit (Entity_Design);
+ case Get_Kind (Unit) is
+ when Iir_Kind_Entity_Declaration =>
+ Entity := Unit;
+ when Iir_Kind_Configuration_Declaration =>
+ Entity_Design := Get_Entity (Unit);
+ Entity := Get_Library_Unit (Entity_Design);
+ when others =>
+ Error_Kind ("elaborate_component_declaration2", Unit);
+ 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 ("no architecture analysed for "
+ & Disp_Node (Entity), Stmt);
+ end if;
+ Arch_Name := Get_Identifier (Arch);
+ end if;
+ Arch_Design := Libraries.Load_Secondary_Unit
+ (Entity_Design, Arch_Name, Stmt);
+ if Arch_Design = Null_Iir then
+ Error_Msg_Elab ("no architecture `" & Name_Table.Image (Arch_Name)
+ & "' for " & Disp_Node (Entity), Stmt);
+ 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, Frame, 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_Slice_Or_Index
+ (Instance : Block_Instance_Acc; Item : Iir)
+ is
+ Spec : constant Iir := Get_Block_Specification (Item);
+ Generate : constant Iir_Generate_Statement := Get_Prefix (Spec);
+ Info : constant Sim_Info_Acc := Get_Info (Generate);
+ Sub_Instance : constant Block_Instance_Acc :=
+ Instance.Instances (Info.Inst_Slot);
+ Bounds : constant Iir_Value_Literal_Acc := Sub_Instance.Objects (1);
+ Expr : Iir_Value_Literal_Acc;
+ Ind : Iir_Index32;
+ begin
+ case Get_Kind (Spec) is
+ when Iir_Kind_Slice_Name =>
+ Expr := Execute_Bounds (Instance, Get_Suffix (Spec));
+ Ind := Get_Index_Offset (Execute_Low_Limit (Expr), Bounds, Spec);
+ for I in 1 .. Expr.Length loop
+ Elaborate_Block_Configuration
+ (Item, Sub_Instance.Instances (Ind + I - 1));
+ end loop;
+ when Iir_Kind_Indexed_Name =>
+ Expr := Execute_Expression
+ (Instance, Get_First_Element (Get_Index_List (Spec)));
+ Ind := Get_Index_Offset (Expr, Bounds, Spec);
+ Elaborate_Block_Configuration
+ (Item, Sub_Instance.Instances (Ind));
+ when Iir_Kind_Selected_Name =>
+ for I in Sub_Instance.Instances'Range loop
+ if Sub_Instance.Instances (I).Configuration = Null_Iir then
+ Elaborate_Block_Configuration
+ (Item, Sub_Instance.Instances (I));
+ end if;
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Apply_Block_Configuration_To_Slice_Or_Index;
+
+ procedure Elaborate_Block_Configuration
+ (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc)
+ is
+ Item : Iir;
+ List : Iir_List;
+ El : Iir;
+ Comp : Iir_Component_Declaration;
+ begin
+ if Conf = Null_Iir then
+ raise Program_Error;
+ -- FIXME.
+ -- Clear_Instantiation_Configuration (Stmt_Chain);
+ return;
+ end if;
+
+ if Instance.Configuration /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Instance.Configuration := Conf;
+
+ 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;
+ Sub_Instance : Block_Instance_Acc;
+ begin
+ Spec := 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.
+ if Get_Prev_Block_Configuration (Item) = Null_Iir then
+ Gen := Get_Prefix (Spec);
+ Set_Generate_Block_Configuration (Gen, Item);
+ end if;
+ Apply_Block_Configuration_To_Slice_Or_Index
+ (Instance, Item);
+ when Iir_Kind_Generate_Statement =>
+ -- Block configuration for any blocks created by the
+ -- generate statement.
+ Info := Get_Info (Spec);
+ Sub_Instance := Instance.Instances (Info.Inst_Slot);
+ if Get_Kind (Get_Generation_Scheme (Spec))
+ = Iir_Kind_Iterator_Declaration
+ then
+ -- Iterative generate: apply to all instances
+ for I in Sub_Instance.Instances'Range loop
+ Elaborate_Block_Configuration
+ (Item, Sub_Instance.Instances (I));
+ end loop;
+ else
+ -- Conditional generate: may not be instantiated
+ if Sub_Instance /= null then
+ Elaborate_Block_Configuration
+ (Item, Sub_Instance);
+ end if;
+ end if;
+ when Iir_Kind_Block_Statement =>
+ -- Block configuration for a block statement.
+ Info := Get_Info (Spec);
+ Sub_Instance := Instance.Instances (Info.Inst_Slot);
+ Elaborate_Block_Configuration (Item, Sub_Instance);
+ when others =>
+ Error_Kind ("elaborate_block_configuration1", Spec);
+ end case;
+ end;
+
+ when Iir_Kind_Component_Configuration =>
+ Comp := Get_Component_Name (Item);
+ List := Get_Instantiation_List (Item);
+ case List is
+ when Iir_List_All
+ | Iir_List_Others =>
+ El := Null_Iir; --Stmt_Chain;
+ while El /= Null_Iir loop
+ if Get_Kind (El) =
+ Iir_Kind_Component_Instantiation_Statement
+ and then Get_Instantiated_Unit (El) = Comp
+ then
+ if List = Iir_List_All
+ or else
+ Get_Component_Configuration (El) = Null_Iir
+ then
+ Set_Component_Configuration (El, Item);
+ end if;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ raise Internal_Error;
+ when others =>
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Elaborate_Component_Configuration (El, Instance, Item);
+ -- Set_Component_Configuration (El, Item);
+ end loop;
+ end case;
+
+ when others =>
+ Error_Kind ("elaborate_block_configuration", Item);
+ end case;
+ Item := Get_Chain (Item);
+ 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_List;
+ 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 ("time must be non-negative", Decl);
+ 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_List_All
+ | Iir_List_Others =>
+ Error_Kind ("elaborate_disconnection_specification", Decl);
+ when others =>
+ for I in Natural loop
+ Sig := Get_Nth_Element (List, I);
+ exit when Sig = Null_Iir;
+ 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 =>
+ Elaborate_Subprogram_Declaration (Instance, Decl);
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Elaborate_Type_Definition (Instance, Get_Type (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), True);
+ 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 =>
+ -- Elaboration of an object declaration that declares an object
+ -- other then a file object proceeds as follows:
+ -- 1. The subtype indication is first elaborated.
+ -- This establishes the subtype of the object.
+ if Get_Deferred_Declaration_Flag (Decl) then
+ Create_Object (Instance, Decl);
+ else
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Type (Decl));
+ Val := Elaborate_Default_Value (Instance, Decl);
+ if Get_Deferred_Declaration (Decl) = Null_Iir then
+ Create_Object (Instance, Decl);
+ end if;
+ Instance.Objects (Get_Info (Decl).Slot) :=
+ Unshare (Val, Instance_Pool);
+ end if;
+ 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
+ Value : Iir_Attribute_Value;
+ Val : Iir_Value_Literal_Acc;
+ Attr_Type : Iir;
+ begin
+ Value := Get_Attribute_Value_Spec_Chain (Decl);
+ Attr_Type := Get_Type (Get_Attribute_Designator (Decl));
+ while Value /= Null_Iir loop
+ -- 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_Delayed_Attribute =>
+ Elaborate_Delayed_Signal (Instance, Decl);
+ when Iir_Kind_Stable_Attribute =>
+ Elaborate_Implicit_Signal (Instance, Decl, Implicit_Stable);
+ when Iir_Kind_Quiet_Attribute =>
+ Elaborate_Implicit_Signal (Instance, Decl, Implicit_Quiet);
+ when Iir_Kind_Transaction_Attribute =>
+ Elaborate_Implicit_Signal (Instance, Decl, Implicit_Transaction);
+
+ 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.Scope_Level = Instance.Scope_Level
+ 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_Declaration;
+ 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));
+
+ Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Entity));
+ Elaborate_Generic_Map_Aspect (Instance, Parent_Instance, Generic_Map);
+ Elaborate_Port_Clause (Instance, Get_Port_Chain (Entity));
+ Elaborate_Port_Map_Aspect (Instance, Parent_Instance,
+ Get_Port_Chain (Entity), Port_Map);
+
+ 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;
+
+ -- 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_Declaration;
+ Entity : Iir_Entity_Declaration;
+ Generic_Map : Iir;
+ Port_Map : Iir;
+ begin
+ Package_Instances := new Block_Instance_Acc_Array (1 .. Nbr_Packages);
+
+ -- Use a 'fake' process to execute code during elaboration.
+ Current_Process := No_Process;
+
+ -- Find architecture and configuration for the top unit
+ case Get_Kind (Unit) is
+ when Iir_Kind_Architecture_Declaration =>
+ Arch := Unit;
+ Conf_Unit := Get_Default_Configuration_Declaration (Unit);
+ when Iir_Kind_Configuration_Declaration =>
+ Conf_Unit := Design;
+ Arch := Get_Block_Specification (Get_Block_Configuration (Unit));
+ Elaborate_Dependence (Design);
+ when others =>
+ Error_Kind ("elaborate_design", Unit);
+ end case;
+
+ Arch_Unit := Get_Design_Unit (Arch);
+ Entity := Get_Entity (Arch);
+
+ Elaborate_Dependence (Arch_Unit);
+
+ -- Sanity check: memory area for expressions must be empty.
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+
+ -- 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);
+
+ -- 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;
+
+ -- 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.
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+ end Elaborate_Design;
+
+end Elaboration;
diff --git a/simulate/elaboration.ads b/simulate/elaboration.ads
new file mode 100644
index 0000000..375d400
--- /dev/null
+++ b/simulate/elaboration.ads
@@ -0,0 +1,207 @@
+-- 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 Ada.Unchecked_Deallocation;
+with GNAT.Table;
+with Types; use Types;
+with Iirs; use Iirs;
+with Iir_Values; use Iir_Values;
+with Grt.Types;
+with Annotations; use Annotations;
+with Areapools;
+
+-- This package elaborates design hierarchy.
+
+package Elaboration is
+ Trace_Elaboration : Boolean := False;
+ Trace_Drivers : Boolean := False;
+
+ -- 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 Block_Instance_Acc_Array is array (Iir_Index32 range <>) of
+ Block_Instance_Acc;
+ type Block_Instance_Acc_Array_Acc is access Block_Instance_Acc_Array;
+
+ -- A block instance with its architecture/entity declaration is an
+ -- instancied entity.
+
+ type Block_Instance_Type (Max_Objs : Iir_Index32) is record
+ -- Flag for wait statement: true if not yet executed.
+ In_Wait_Flag : Boolean;
+
+ -- Useful informations for a dynamic block (ie, a frame).
+ -- The scope level and an access to the block of upper scope level.
+ Scope_Level: Scope_Level_Type;
+ Up_Block: Block_Instance_Acc;
+
+ -- Block, architecture or process for this instance.
+ -- null for the package (there is only one instance for all packages).
+ Name: Iir;
+
+ -- Instanciation tree.
+ Parent: Block_Instance_Acc;
+ Children: Block_Instance_Acc;
+ Brother: Block_Instance_Acc;
+
+ -- Pool marker for the child (only for subprograms).
+ Marker : Areapools.Mark_Type;
+
+ -- Block configuration for this instance.
+ Configuration: Iir;
+
+ Instances : Block_Instance_Acc_Array_Acc;
+
+ -- Statement being executed.
+ Cur_Stmt : Iir;
+
+ -- 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 : Iir_Index32 := 0;
+
+ -- Values of the objects in that frame.
+ Objects : Iir_Value_Literal_Array (1 .. Max_Objs);
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Block_Instance_Type, Name => Block_Instance_Acc);
+
+ 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);
+
+ -- Create a value for type DECL. Initialize it if DEFAULT is true.
+ function Create_Value_For_Type
+ (Block: Block_Instance_Acc; Decl: Iir; Default : Boolean)
+ 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;
+
+ Package_Instances : Block_Instance_Acc_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 GNAT.Table
+ (Table_Component_Type => Disconnection_Entry,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ -- 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;
+ Assoc : Iir;
+ end record;
+
+ package Connect_Table is new GNAT.Table
+ (Table_Component_Type => Connect_Entry,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 32,
+ Table_Increment => 100);
+
+ -- Signals.
+ type Signal_Type_Kind is
+ (User_Signal,
+ Implicit_Quiet, Implicit_Stable, Implicit_Delayed,
+ Implicit_Transaction,
+ Guard_Signal);
+
+ type Signal_Entry (Kind : Signal_Type_Kind := User_Signal) is record
+ Decl : Iir;
+ Sig : Iir_Value_Literal_Acc;
+ Instance : Block_Instance_Acc;
+ case Kind is
+ when User_Signal =>
+ Init : Iir_Value_Literal_Acc;
+ when Implicit_Quiet | Implicit_Stable | Implicit_Delayed
+ | Implicit_Transaction =>
+ Time : Grt.Types.Ghdl_I64;
+ Prefix : Iir_Value_Literal_Acc;
+ when Guard_Signal =>
+ null;
+ end case;
+ end record;
+
+ package Signals_Table is new GNAT.Table
+ (Table_Component_Type => Signal_Entry,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ type Process_Index_Type is new Natural;
+
+ package Processes_Table is new GNAT.Table
+ (Table_Component_Type => Block_Instance_Acc,
+ Table_Index_Type => Process_Index_Type,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ package Protected_Table is new GNAT.Table
+ (Table_Component_Type => Block_Instance_Acc,
+ Table_Index_Type => Protected_Index_Type,
+ Table_Low_Bound => 1,
+ Table_Initial => 2,
+ Table_Increment => 100);
+end Elaboration;
diff --git a/simulate/execution.adb b/simulate/execution.adb
new file mode 100644
index 0000000..5fa6d05
--- /dev/null
+++ b/simulate/execution.adb
@@ -0,0 +1,4285 @@
+-- Interpreted simulation
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ada.Unchecked_Conversion;
+with Ada.Text_IO; use Ada.Text_IO;
+with System;
+with Grt.Types; use Grt.Types;
+with Errorout; use Errorout;
+with Evaluation;
+with Iirs_Utils; use Iirs_Utils;
+with Annotations; use Annotations;
+with Flags;
+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;
+
+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);
+
+ function Get_Instance_By_Scope_Level
+ (Instance: Block_Instance_Acc; Scope_Level: Scope_Level_Type)
+ return Block_Instance_Acc
+ is
+ Current: Block_Instance_Acc := Instance;
+ begin
+ while Current /= null loop
+ if Current.Scope_Level = Scope_Level then
+ return Current;
+ end if;
+ Current := Current.Up_Block;
+ end loop;
+ -- Global scope (packages)
+ if Scope_Level < Scope_Level_Global then
+ return Package_Instances (Iir_Index32 (-Scope_Level));
+ end if;
+ if Current_Component /= null
+ and then Current_Component.Scope_Level = Scope_Level
+ then
+ return Current_Component;
+ end if;
+ if Scope_Level = Scope_Level_Global then
+ return null;
+ end if;
+ raise Internal_Error;
+ end Get_Instance_By_Scope_Level;
+
+ function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir)
+ return Block_Instance_Acc
+ is
+ begin
+ return Get_Instance_By_Scope_Level (Instance,
+ Get_Info (Decl).Scope_Level);
+ end Get_Instance_For_Slot;
+
+ function Create_Bounds_From_Length (Block : Block_Instance_Acc;
+ Atype : Iir;
+ Len : Iir_Index32)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Index_Bounds : Iir_Value_Literal_Acc;
+ begin
+ Index_Bounds := Execute_Bounds (Block, Atype);
+
+ Res := Create_Range_Value (Left => Index_Bounds.Left,
+ Right => null,
+ Dir => Index_Bounds.Dir,
+ Length => Len);
+
+ if Len = 0 then
+ -- Special case.
+ Res.Right := Res.Left;
+ case Res.Left.Kind is
+ when Iir_Value_I64 =>
+ case Index_Bounds.Dir is
+ when Iir_To =>
+ Res.Left := Create_I64_Value (Res.Right.I64 + 1);
+ when Iir_Downto =>
+ Res.Left := Create_I64_Value (Res.Right.I64 - 1);
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ else
+ case Res.Left.Kind is
+ when Iir_Value_E32 =>
+ declare
+ R : Ghdl_E32;
+ begin
+ case Index_Bounds.Dir is
+ when Iir_To =>
+ R := Res.Left.E32 + Ghdl_E32 (Len - 1);
+ when Iir_Downto =>
+ R := Res.Left.E32 - Ghdl_E32 (Len - 1);
+ end case;
+ Res.Right := Create_E32_Value (R);
+ end;
+ when Iir_Value_I64 =>
+ declare
+ R : Ghdl_I64;
+ begin
+ case Index_Bounds.Dir is
+ when Iir_To =>
+ R := Res.Left.I64 + Ghdl_I64 (Len - 1);
+ when Iir_Downto =>
+ R := Res.Left.I64 - Ghdl_I64 (Len - 1);
+ end case;
+ Res.Right := Create_I64_Value (R);
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ return Res;
+ end Create_Bounds_From_Length;
+
+ function Create_Enum_Value (Pos : Natural; Etype : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Base_Type : constant Iir := Get_Base_Type (Etype);
+ Mode : constant Iir_Value_Kind :=
+ Get_Info (Base_Type).Scalar_Mode;
+ begin
+ case Mode is
+ when Iir_Value_E32 =>
+ return Create_E32_Value (Ghdl_E32 (Pos));
+ when Iir_Value_B2 =>
+ return Create_B2_Value (Ghdl_B2'Val (Pos));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Create_Enum_Value;
+
+ 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;
+
+
+ -- EXPR is the expression whose implementation is an implicit function.
+ function Execute_Implicit_Function (Block : Block_Instance_Acc;
+ Expr: Iir;
+ Left_Param : Iir;
+ Right_Param : Iir;
+ Res_Type : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ pragma Unsuppress (Overflow_Check);
+
+ Func : Iir_Predefined_Functions;
+
+ -- Rename definition for monadic operations.
+ Left, Right: Iir_Value_Literal_Acc;
+ Operand : Iir_Value_Literal_Acc renames Left;
+ Res: Iir_Value_Literal_Acc;
+ 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 RES 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.
+ Res := Unshare (Left, Expr_Pool'Access);
+ end Eval_Array;
+
+ begin
+ Func := Get_Implicit_Definition (Get_Implementation (Expr));
+
+ -- Eval left operand (only if the predefined function is not NOW).
+ if Func /= Iir_Predefined_Now_Function then
+ Left := Execute_Expression (Block, Left_Param);
+ else
+ Left := null;
+ end if;
+ Right := null;
+
+ case Func is
+ when Iir_Predefined_Error =>
+ raise Internal_Error;
+
+ when Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Eval_Right;
+
+ declare
+ -- Array length of the result.
+ Len: Iir_Index32;
+
+ -- Index into the result.
+ Pos: Iir_Index32;
+ begin
+ -- Compute the length of the result.
+ case Func is
+ when Iir_Predefined_Array_Array_Concat =>
+ Len := Left.Val_Array.Len + Right.Val_Array.Len;
+ when Iir_Predefined_Element_Array_Concat =>
+ Len := 1 + Right.Val_Array.Len;
+ when Iir_Predefined_Array_Element_Concat =>
+ Len := Left.Val_Array.Len + 1;
+ when Iir_Predefined_Element_Element_Concat =>
+ Len := 1 + 1;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- LRM93 7.2.4
+ -- If both operands are null arrays, then the result of the
+ -- concatenation is the right operand.
+ if Len = 0 then
+ -- Note: this return is allowed since LEFT is free, and
+ -- RIGHT must not be free.
+ return Right;
+ end if;
+
+ -- Create the array result.
+ Res := Create_Array_Value (Len, 1);
+ Res.Bounds.D (1) := Create_Bounds_From_Length
+ (Block, Get_First_Element (Get_Index_Subtype_List (Res_Type)),
+ Len);
+
+ -- Fill the result: left.
+ case Func is
+ when Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Array_Element_Concat =>
+ for I in Left.Val_Array.V'Range loop
+ Res.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 =>
+ Res.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
+ Res.Val_Array.V (Pos + I) := Right.Val_Array.V (I);
+ end loop;
+ when Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Res.Val_Array.V (Pos + 1) := Right;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Result := Res;
+ end;
+
+ when Iir_Predefined_Bit_And
+ | Iir_Predefined_Boolean_And =>
+ if Left.B2 = Lit_Enum_0.B2 then
+ -- Short circuit operator.
+ Result := Lit_Enum_0;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B2 = Lit_Enum_1.B2);
+ end if;
+ when Iir_Predefined_Bit_Nand
+ | Iir_Predefined_Boolean_Nand =>
+ if Left.B2 = Lit_Enum_0.B2 then
+ -- Short circuit operator.
+ Result := Lit_Enum_1;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B2 = Lit_Enum_0.B2);
+ end if;
+ when Iir_Predefined_Bit_Or
+ | Iir_Predefined_Boolean_Or =>
+ if Left.B2 = Lit_Enum_1.B2 then
+ -- Short circuit operator.
+ Result := Lit_Enum_1;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B2 = Lit_Enum_1.B2);
+ end if;
+ when Iir_Predefined_Bit_Nor
+ | Iir_Predefined_Boolean_Nor =>
+ if Left.B2 = Lit_Enum_1.B2 then
+ -- Short circuit operator.
+ Result := Lit_Enum_0;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B2 = Lit_Enum_0.B2);
+ end if;
+ when Iir_Predefined_Bit_Xor
+ | Iir_Predefined_Boolean_Xor =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.B2 /= Right.B2);
+ when Iir_Predefined_Bit_Xnor
+ | Iir_Predefined_Boolean_Xnor =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.B2 = Right.B2);
+ when Iir_Predefined_Bit_Not
+ | Iir_Predefined_Boolean_Not =>
+ Result := Boolean_To_Lit (Operand.B2 = Lit_Enum_0.B2);
+
+ 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 =>
+ 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 =>
+ Eval_Right;
+ Result := Boolean_To_Lit (not Is_Equal (Left, Right));
+ when Iir_Predefined_Integer_Less
+ | Iir_Predefined_Physical_Less =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 < Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Greater
+ | Iir_Predefined_Physical_Greater =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 > Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Less_Equal
+ | Iir_Predefined_Physical_Less_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 <= Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Greater_Equal
+ | Iir_Predefined_Physical_Greater_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 >= Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Less =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B2 =>
+ Result := Boolean_To_Lit (Left.B2 < Right.B2);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 < Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Greater =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B2 =>
+ Result := Boolean_To_Lit (Left.B2 > Right.B2);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 > Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Less_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B2 =>
+ Result := Boolean_To_Lit (Left.B2 <= Right.B2);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 <= Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Greater_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B2 =>
+ Result := Boolean_To_Lit (Left.B2 >= Right.B2);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 >= Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ 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_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_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_Bit_Array_And
+ | Iir_Predefined_Boolean_Array_And =>
+ Eval_Array;
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I).B2 :=
+ Res.Val_Array.V (I).B2 and Right.Val_Array.V (I).B2;
+ end loop;
+ Result := Res;
+ when Iir_Predefined_Bit_Array_Nand
+ | Iir_Predefined_Boolean_Array_Nand =>
+ Eval_Array;
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I).B2 :=
+ not (Res.Val_Array.V (I).B2 and Right.Val_Array.V (I).B2);
+ end loop;
+ Result := Res;
+ when Iir_Predefined_Bit_Array_Or
+ | Iir_Predefined_Boolean_Array_Or =>
+ Eval_Array;
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I).B2 :=
+ Res.Val_Array.V (I).B2 or Right.Val_Array.V (I).B2;
+ end loop;
+ Result := Res;
+ when Iir_Predefined_Bit_Array_Nor
+ | Iir_Predefined_Boolean_Array_Nor =>
+ Eval_Array;
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I).B2 :=
+ not (Res.Val_Array.V (I).B2 or Right.Val_Array.V (I).B2);
+ end loop;
+ Result := Res;
+ when Iir_Predefined_Bit_Array_Xor
+ | Iir_Predefined_Boolean_Array_Xor =>
+ Eval_Array;
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I).B2 :=
+ Res.Val_Array.V (I).B2 xor Right.Val_Array.V (I).B2;
+ end loop;
+ Result := Res;
+
+ when Iir_Predefined_Bit_Array_Not
+ | Iir_Predefined_Boolean_Array_Not =>
+ -- Need to copy as the result is modified.
+ Res := Unshare (Operand, Expr_Pool'Access);
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I).B2 := not Res.Val_Array.V (I).B2;
+ end loop;
+ Result := Res;
+
+ 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_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 others =>
+ Error_Msg ("execute_implicit_function: unimplemented " &
+ Iir_Predefined_Functions'Image
+ (Get_Implicit_Definition (Expr)));
+ raise Internal_Error;
+ end case;
+ return Result;
+ exception
+ when Constraint_Error =>
+ Error_Msg_Constraint (Expr);
+ end Execute_Implicit_Function;
+
+ procedure Execute_Implicit_Procedure
+ (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call)
+ is
+ Imp : constant Iir_Implicit_Procedure_Declaration :=
+ Get_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_File_Close =>
+ if Get_Text_File_Flag (Get_Type (Inter_Chain)) then
+ File_Operation.File_Close_Text (Args (0), Stmt);
+ else
+ File_Operation.File_Close_Binary (Args (0), Stmt);
+ end if;
+ when others =>
+ Error_Kind ("execute_implicit_procedure",
+ Get_Implicit_Definition (Imp));
+ end case;
+ Release (Expr_Mark, Expr_Pool);
+ end Execute_Implicit_Procedure;
+
+ procedure Execute_Foreign_Procedure
+ (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call)
+ is
+ Imp : constant Iir_Implicit_Procedure_Declaration :=
+ Get_Implementation (Stmt);
+ Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt);
+ Assoc: Iir;
+ Args: Iir_Value_Literal_Array (0 .. 3) := (others => null);
+ Expr_Mark : Mark_Type;
+ begin
+ Mark (Expr_Mark, Expr_Pool);
+ Assoc := Assoc_Chain;
+ for I in Args'Range loop
+ exit when Assoc = Null_Iir;
+ Args (I) := Execute_Expression (Block, Get_Actual (Assoc));
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ case Get_Identifier (Imp) is
+ when Std_Names.Name_Untruncated_Text_Read =>
+ File_Operation.Untruncated_Text_Read
+ (Args (0), Args (1), Args (2));
+ when others =>
+ Error_Msg_Exec ("unsupported foreign procedure call", Stmt);
+ end case;
+ Release (Expr_Mark, Expr_Pool);
+ end Execute_Foreign_Procedure;
+
+ -- Compute the offset for INDEX into a range BOUNDS.
+ -- EXPR is only used in case of error.
+ function Get_Index_Offset
+ (Index: Iir_Value_Literal_Acc;
+ Bounds: Iir_Value_Literal_Acc;
+ Expr: Iir)
+ return Iir_Index32
+ is
+ Left_Pos, Right_Pos: Iir_Value_Literal_Acc;
+ begin
+ Left_Pos := Bounds.Left;
+ Right_Pos := Bounds.Right;
+ if Index.Kind /= Left_Pos.Kind or else Index.Kind /= Right_Pos.Kind then
+ raise Internal_Error;
+ end if;
+ case Index.Kind is
+ when Iir_Value_B2 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ if Index.B2 >= Left_Pos.B2 and then
+ Index.B2 <= Right_Pos.B2
+ then
+ -- to
+ return Ghdl_B2'Pos (Index.B2) - Ghdl_B2'Pos (Left_Pos.B2);
+ end if;
+ when Iir_Downto =>
+ if Index.B2 <= Left_Pos.B2 and then
+ Index.B2 >= Right_Pos.B2
+ then
+ -- downto
+ return Ghdl_B2'Pos (Left_Pos.B2) - Ghdl_B2'Pos (Index.B2);
+ end if;
+ end case;
+ when Iir_Value_E32 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ if Index.E32 >= Left_Pos.E32 and then
+ Index.E32 <= Right_Pos.E32
+ then
+ -- to
+ return Iir_Index32 (Index.E32 - Left_Pos.E32);
+ end if;
+ when Iir_Downto =>
+ if Index.E32 <= Left_Pos.E32 and then
+ Index.E32 >= Right_Pos.E32
+ then
+ -- downto
+ return Iir_Index32 (Left_Pos.E32 - Index.E32);
+ end if;
+ end case;
+ when Iir_Value_I64 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ if Index.I64 >= Left_Pos.I64 and then
+ Index.I64 <= Right_Pos.I64
+ then
+ -- to
+ return Iir_Index32 (Index.I64 - Left_Pos.I64);
+ end if;
+ when Iir_Downto =>
+ if Index.I64 <= Left_Pos.I64 and then
+ Index.I64 >= Right_Pos.I64
+ then
+ -- downto
+ return Iir_Index32 (Left_Pos.I64 - Index.I64);
+ end if;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Error_Msg_Constraint (Expr);
+ return 0;
+ end Get_Index_Offset;
+
+ -- Create an iir_value_literal of kind iir_value_array and of life LIFE.
+ -- Allocate the array of bounds, and fill it from A_TYPE.
+ -- Allocate the array of values.
+ function Create_Array_Bounds_From_Type
+ (Block : Block_Instance_Acc;
+ A_Type : Iir;
+ Create_Val_Array : Boolean)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Index_List : Iir_List;
+ Len : Iir_Index32;
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ -- Only for constrained subtypes.
+ if Get_Kind (A_Type) = Iir_Kind_Array_Type_Definition then
+ raise Internal_Error;
+ end if;
+
+ Index_List := Get_Index_Subtype_List (A_Type);
+ Res := Create_Array_Value
+ (Iir_Index32 (Get_Nbr_Elements (Index_List)));
+ Len := 1;
+ for I in 1 .. Res.Bounds.Nbr_Dims loop
+ Bound := Execute_Bounds
+ (Block, Get_Nth_Element (Index_List, Natural (I - 1)));
+ Len := Len * Bound.Length;
+ Res.Bounds.D (I) := Bound;
+ end loop;
+ if Create_Val_Array then
+ Create_Array_Data (Res, Len);
+ end if;
+ return Res;
+ end Create_Array_Bounds_From_Type;
+
+ -- Return the steps (ie, offset in the array when index DIM is increased
+ -- by one) for array ARR and dimension DIM.
+ function Get_Step_For_Dim (Arr: Iir_Value_Literal_Acc; Dim : Natural)
+ return Iir_Index32
+ is
+ Bounds : Value_Bounds_Array_Acc renames Arr.Bounds;
+ Res : Iir_Index32;
+ begin
+ Res := 1;
+ for I in Iir_Index32 (Dim + 1) .. Bounds.Nbr_Dims loop
+ Res := Res * Bounds.D (I).Length;
+ end loop;
+ return Res;
+ end Get_Step_For_Dim;
+
+ -- Create a literal for a string or a bit_string
+ function String_To_Enumeration_Array_1 (Str: Iir; El_Type : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Lit: Iir_Value_Literal_Acc;
+ Element_Mode : Iir_Value_Scalars;
+
+ procedure Create_Lit_El
+ (Index : Iir_Index32; Literal: Iir_Enumeration_Literal)
+ is
+ R : Iir_Value_Literal_Acc;
+ P : constant Iir_Int32 := Get_Enum_Pos (Literal);
+ begin
+ case Element_Mode is
+ when Iir_Value_B2 =>
+ R := Create_B2_Value (Ghdl_B2'Val (P));
+ when Iir_Value_E32 =>
+ R := Create_E32_Value (Ghdl_E32'Val (P));
+ when others =>
+ raise Internal_Error;
+ end case;
+ Lit.Val_Array.V (Index) := R;
+ end Create_Lit_El;
+
+ El_Btype : constant Iir := Get_Base_Type (El_Type);
+ Literal_List: constant Iir_List :=
+ Get_Enumeration_Literal_List (El_Btype);
+ Len: Iir_Index32;
+ Str_As_Str: constant String := Iirs_Utils.Image_String_Lit (Str);
+ El : Iir;
+ begin
+ Element_Mode := Get_Info (El_Btype).Scalar_Mode;
+
+ case Get_Kind (Str) is
+ when Iir_Kind_String_Literal =>
+ Len := Iir_Index32 (Str_As_Str'Length);
+ Lit := Create_Array_Value (Len, 1);
+
+ for I in Lit.Val_Array.V'Range loop
+ -- FIXME: use literal from type ??
+ El := Find_Name_In_List
+ (Literal_List,
+ Name_Table.Get_Identifier (Str_As_Str (Natural (I))));
+ if El = Null_Iir then
+ -- FIXME: could free what was already built.
+ return null;
+ end if;
+ Create_Lit_El (I, El);
+ end loop;
+
+ when Iir_Kind_Bit_String_Literal =>
+ declare
+ Lit_0, Lit_1 : Iir;
+ Buf : String_Fat_Acc;
+ Len1 : Int32;
+ begin
+ Lit_0 := Get_Bit_String_0 (Str);
+ Lit_1 := Get_Bit_String_1 (Str);
+ Buf := Str_Table.Get_String_Fat_Acc (Get_String_Id (Str));
+ Len1 := Get_String_Length (Str);
+ Lit := Create_Array_Value (Iir_Index32 (Len1), 1);
+
+ if Lit_0 = Null_Iir or Lit_1 = Null_Iir then
+ raise Internal_Error;
+ end if;
+ for I in 1 .. Len1 loop
+ case Buf (I) is
+ when '0' =>
+ Create_Lit_El (Iir_Index32 (I), Lit_0);
+ when '1' =>
+ Create_Lit_El (Iir_Index32 (I), Lit_1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ return Lit;
+ end String_To_Enumeration_Array_1;
+
+ -- Create a literal for a string or a bit_string
+ function String_To_Enumeration_Array (Block: Block_Instance_Acc; Str: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Array_Type: constant Iir := Get_Type (Str);
+ Index_Types : constant Iir_List := Get_Index_Subtype_List (Array_Type);
+ begin
+ if Get_Nbr_Elements (Index_Types) /= 1 then
+ raise Internal_Error; -- array must be unidimensional
+ end if;
+
+ Res := String_To_Enumeration_Array_1
+ (Str, Get_Element_Subtype (Array_Type));
+
+ -- When created from static evaluation, a string may still have an
+ -- unconstrained type.
+ if Get_Kind (Array_Type) = Iir_Kind_Array_Type_Definition then
+ Res.Bounds.D (1) :=
+ Create_Range_Value (Create_I64_Value (1),
+ Create_I64_Value (Ghdl_I64 (Res.Val_Array.Len)),
+ Iir_To,
+ Res.Val_Array.Len);
+ else
+ Res.Bounds.D (1) :=
+ Execute_Bounds (Block, Get_First_Element (Index_Types));
+ end if;
+
+ -- The range may not be statically constant.
+ if Res.Bounds.D (1).Length /= Res.Val_Array.Len then
+ Error_Msg_Constraint (Str);
+ end if;
+
+ return Res;
+ end String_To_Enumeration_Array;
+
+ -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP.
+ -- Use expressions from (BLOCK, AGGREGATE) to fill the elements.
+ -- EL_TYPE is the type of the array element.
+ procedure Fill_Array_Aggregate_1
+ (Block : Block_Instance_Acc;
+ Aggregate : Iir;
+ Res : Iir_Value_Literal_Acc;
+ Orig : Iir_Index32;
+ Step : Iir_Index32;
+ Dim : Iir_Index32;
+ Nbr_Dim : Iir_Index32;
+ El_Type : Iir)
+ is
+ Value : Iir;
+ Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim);
+
+ procedure Set_Elem (Pos : Iir_Index32)
+ is
+ Val : Iir_Value_Literal_Acc;
+ begin
+ if Dim = Nbr_Dim then
+ -- VALUE is an expression (which may be an aggregate, but not
+ -- a sub-aggregate.
+ Val := Execute_Expression_With_Type (Block, Value, El_Type);
+ -- LRM93 7.3.2.2
+ -- For a multi-dimensional aggregate of dimension n, a check
+ -- is made that all (n-1)-dimensional subaggregates have the
+ -- same bounds.
+ -- GHDL: I have added an implicit array conversion, however
+ -- it may be useful to allow cases like this:
+ -- type str_array is array (natural range <>)
+ -- of string (10 downto 1);
+ -- constant floats : str_array :=
+ -- ( "00000000.0", HT & "+1.5ABCDE");
+ -- The subtype of the first sub-aggregate (0.0) is
+ -- determinated by the context, according to rule 9 and 4
+ -- of LRM93 7.3.2.2 and therefore is string (10 downto 1),
+ -- while the subtype of the second sub-aggregate (HT & ...)
+ -- is determinated by rules 1 and 2 of LRM 7.2.4, and is
+ -- string (1 to 10).
+ -- Unless an implicit conversion is used, according to the
+ -- LRM, this should fail, but it makes no sens.
+ --
+ -- FIXME: Add a warning, a flag ?
+ --Implicit_Array_Conversion (Block, Val, El_Type, Value);
+ --Check_Constraints (Block, Val, El_Type, Value);
+ Res.Val_Array.V (1 + Orig + Pos * Step) := Val;
+ else
+ case Get_Kind (Value) is
+ when Iir_Kind_Aggregate =>
+ -- VALUE is a sub-aggregate.
+ Fill_Array_Aggregate_1 (Block, Value, Res,
+ Orig + Pos * Step,
+ Step / Res.Bounds.D (Dim + 1).Length,
+ Dim + 1, Nbr_Dim, El_Type);
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ pragma Assert (Dim + 1 = Nbr_Dim);
+ Val := String_To_Enumeration_Array_1 (Value, El_Type);
+ if Val.Val_Array.Len /= Res.Bounds.D (Nbr_Dim).Length then
+ Error_Msg_Constraint (Value);
+ end if;
+ for I in Val.Val_Array.V'Range loop
+ Res.Val_Array.V (Orig + Pos * Step + I) :=
+ Val.Val_Array.V (I);
+ end loop;
+ when others =>
+ Error_Kind ("fill_array_aggregate_1", Value);
+ end case;
+ end if;
+ end Set_Elem;
+
+ procedure Set_Elem_By_Expr (Expr : Iir)
+ is
+ Expr_Pos: Iir_Value_Literal_Acc;
+ begin
+ Expr_Pos := Execute_Expression (Block, Expr);
+ Set_Elem (Get_Index_Offset (Expr_Pos, Bound, Expr));
+ end Set_Elem_By_Expr;
+
+ procedure Set_Elem_By_Range (Expr : Iir)
+ is
+ A_Range : Iir_Value_Literal_Acc;
+ High, Low : Iir_Value_Literal_Acc;
+ begin
+ A_Range := Execute_Bounds (Block, Expr);
+ if Is_Nul_Range (A_Range) then
+ return;
+ end if;
+ if A_Range.Dir = Iir_To then
+ High := A_Range.Right;
+ Low := A_Range.Left;
+ else
+ High := A_Range.Left;
+ Low := A_Range.Right;
+ end if;
+
+ -- Locally modified (incremented)
+ Low := Unshare (Low, Expr_Pool'Access);
+
+ loop
+ Set_Elem (Get_Index_Offset (Low, Bound, Expr));
+ exit when Is_Equal (Low, High);
+ Increment (Low);
+ end loop;
+ end Set_Elem_By_Range;
+
+ Length : constant Iir_Index32 := Bound.Length;
+ Assoc : Iir;
+ Pos : Iir_Index32;
+ begin
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Pos := 0;
+ while Assoc /= Null_Iir loop
+ Value := Get_Associated (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_Expression (Assoc));
+ when Iir_Kind_Choice_By_Range =>
+ Set_Elem_By_Range (Get_Expression (Assoc));
+ when Iir_Kind_Choice_By_Others =>
+ for J in 1 .. Length loop
+ if Res.Val_Array.V (Orig + J * Step) = null then
+ Set_Elem (J - 1);
+ end if;
+ end loop;
+ return;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ exit when not Get_Same_Alternative_Flag (Assoc);
+ end loop;
+ end loop;
+
+ -- Check each elements have been set.
+ -- FIXME: check directly with type.
+ for J in 1 .. Length loop
+ if Res.Val_Array.V (Orig + J * Step) = null then
+ Error_Msg_Constraint (Aggregate);
+ end if;
+ end loop;
+ end Fill_Array_Aggregate_1;
+
+ -- Use expressions from (BLOCK, AGGREGATE) to fill RES.
+ procedure Fill_Array_Aggregate
+ (Block : Block_Instance_Acc;
+ Aggregate : Iir;
+ Res : Iir_Value_Literal_Acc)
+ is
+ Aggr_Type : constant Iir := Get_Type (Aggregate);
+ El_Type : constant Iir := Get_Element_Subtype (Aggr_Type);
+ Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type);
+ Nbr_Dim : constant Iir_Index32 :=
+ Iir_Index32 (Get_Nbr_Elements (Index_List));
+ Step : Iir_Index32;
+ begin
+ Step := Get_Step_For_Dim (Res, 1);
+ Fill_Array_Aggregate_1
+ (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type);
+ end Fill_Array_Aggregate;
+
+ function Execute_Record_Aggregate (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ List : constant Iir_List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type));
+
+ Res: Iir_Value_Literal_Acc;
+ Expr : Iir;
+
+ procedure Set_Expr (Pos : Iir_Index32) is
+ El : constant Iir := Get_Nth_Element (List, Natural (Pos - 1));
+ begin
+ Res.Val_Record.V (Pos) :=
+ Execute_Expression_With_Type (Block, Expr, Get_Type (El));
+ end Set_Expr;
+
+ Pos : Iir_Index32;
+ Assoc: Iir;
+ N_Expr : Iir;
+ begin
+ Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List)));
+
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Pos := 1;
+ loop
+ N_Expr := Get_Associated (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_Name (Assoc)));
+ when Iir_Kind_Choice_By_Others =>
+ for I in Res.Val_Record.V'Range loop
+ if Res.Val_Record.V (I) = null then
+ Set_Expr (I);
+ end if;
+ end loop;
+ when others =>
+ Error_Kind ("execute_record_aggregate", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ end loop;
+ return Res;
+ end Execute_Record_Aggregate;
+
+ function Execute_Aggregate
+ (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Get_Kind (Aggregate_Type) is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ declare
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Array_Bounds_From_Type
+ (Block, Aggregate_Type, True);
+ Fill_Array_Aggregate (Block, Aggregate, Res);
+ return Res;
+ end;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return Execute_Record_Aggregate
+ (Block, Aggregate, Aggregate_Type);
+ when others =>
+ Error_Kind ("execute_aggregate", Aggregate_Type);
+ end case;
+ end Execute_Aggregate;
+
+ function Execute_Simple_Aggregate (Block: Block_Instance_Acc; Aggr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ List : constant Iir_List := Get_Simple_Aggregate_List (Aggr);
+ begin
+ Res := Create_Array_Bounds_From_Type (Block, Get_Type (Aggr), True);
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I) :=
+ Execute_Expression (Block, Get_Nth_Element (List, Natural (I - 1)));
+ end loop;
+ return Res;
+ end Execute_Simple_Aggregate;
+
+ -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP.
+ -- Use expressions from (BLOCK, AGGREGATE) to fill the elements.
+ -- EL_TYPE is the type of the array element.
+ procedure Execute_Name_Array_Aggregate
+ (Block : Block_Instance_Acc;
+ Aggregate : Iir;
+ Res : Iir_Value_Literal_Acc;
+ Orig : Iir_Index32;
+ Step : Iir_Index32;
+ Dim : Iir_Index32;
+ Nbr_Dim : Iir_Index32;
+ El_Type : Iir)
+ is
+ Value : Iir;
+ Bound : Iir_Value_Literal_Acc;
+
+ procedure Set_Elem (Pos : Iir_Index32)
+ is
+ Val : Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ if Dim = Nbr_Dim then
+ -- VALUE is an expression (which may be an aggregate, but not
+ -- a sub-aggregate.
+ Execute_Name_With_Base (Block, Value, null, Val, Is_Sig);
+ Res.Val_Array.V (1 + Orig + Pos * Step) := Val;
+ else
+ -- VALUE is a sub-aggregate.
+ Execute_Name_Array_Aggregate
+ (Block, Value, Res,
+ Orig + Pos * Step,
+ Step / Res.Bounds.D (Dim + 1).Length,
+ Dim + 1, Nbr_Dim, El_Type);
+ end if;
+ end Set_Elem;
+
+ Assoc : Iir;
+ Pos : Iir_Index32;
+ begin
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Bound := Res.Bounds.D (Dim);
+ Pos := 0;
+ while Assoc /= Null_Iir loop
+ Value := Get_Associated (Assoc);
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ null;
+ when Iir_Kind_Choice_By_Expression =>
+ declare
+ Expr_Pos: Iir_Value_Literal_Acc;
+ Val : constant Iir := Get_Expression (Assoc);
+ begin
+ Expr_Pos := Execute_Expression (Block, Val);
+ Pos := Get_Index_Offset (Expr_Pos, Bound, Val);
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Set_Elem (Pos);
+ Pos := Pos + 1;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Execute_Name_Array_Aggregate;
+
+ function Execute_Record_Name_Aggregate
+ (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ List : constant Iir_List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type));
+ Res: Iir_Value_Literal_Acc;
+ Expr : Iir;
+ Pos : Iir_Index32;
+ El_Pos : Iir_Index32;
+ Is_Sig : Boolean;
+ Assoc: Iir;
+ begin
+ Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List)));
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Pos := 0;
+ loop
+ Expr := Get_Associated (Assoc);
+ if Expr = Null_Iir then
+ -- List of choices is not allowed.
+ raise Internal_Error;
+ end if;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ El_Pos := Pos;
+ Pos := Pos + 1;
+ when Iir_Kind_Choice_By_Name =>
+ El_Pos := Get_Element_Position (Get_Name (Assoc));
+ when Iir_Kind_Choice_By_Others =>
+ raise Internal_Error;
+ when others =>
+ Error_Kind ("execute_record_name_aggregate", Assoc);
+ end case;
+ Execute_Name_With_Base
+ (Block, Expr, null, Res.Val_Record.V (1 + El_Pos), Is_Sig);
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ end loop;
+ return Res;
+ end Execute_Record_Name_Aggregate;
+
+ function Execute_Name_Aggregate
+ (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Get_Kind (Aggregate_Type) is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ declare
+ Res : Iir_Value_Literal_Acc;
+ El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type);
+ Index_List : constant Iir_List :=
+ Get_Index_Subtype_List (Aggregate_Type);
+ Nbr_Dim : constant Iir_Index32 :=
+ Iir_Index32 (Get_Nbr_Elements (Index_List));
+ Step : Iir_Index32;
+ begin
+ Res := Create_Array_Bounds_From_Type
+ (Block, Aggregate_Type, True);
+ Step := Get_Step_For_Dim (Res, 1);
+ Execute_Name_Array_Aggregate
+ (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type);
+ return Res;
+ end;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return Execute_Record_Name_Aggregate
+ (Block, Aggregate, Aggregate_Type);
+ when others =>
+ Error_Kind ("execute_name_aggregate", Aggregate_Type);
+ end case;
+ end Execute_Name_Aggregate;
+
+ -- Return the indexes range of dimension DIM for type or object PREFIX.
+ -- DIM starts at 1.
+ function Execute_Indexes
+ (Block: Block_Instance_Acc; Prefix: Iir; Dim : Iir_Int64)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ declare
+ Index : Iir;
+ begin
+ Index := Get_Nth_Element
+ (Get_Index_Subtype_List (Get_Type (Prefix)),
+ Natural (Dim - 1));
+ return Execute_Bounds (Block, Index);
+ end;
+ when Iir_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 : Sim_Info_Acc;
+ begin
+ Info := Get_Info (Prefix);
+ if Info = null then
+ Bound := Create_Range_Value
+ (Execute_Expression (Block, Get_Left_Limit (Prefix)),
+ Execute_Expression (Block, Get_Right_Limit (Prefix)),
+ Get_Direction (Prefix));
+ elsif Info.Kind = Kind_Object then
+ Bound := Get_Instance_For_Slot
+ (Block, Prefix).Objects (Info.Slot);
+ else
+ raise Internal_Error;
+ end if;
+ end;
+
+ when Iir_Kind_Subtype_Declaration =>
+ return Execute_Bounds (Block, Get_Type (Prefix));
+
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ -- FIXME: move this block before and avoid recursion.
+ return Execute_Bounds (Block, Get_Range_Constraint (Prefix));
+
+ when Iir_Kind_Range_Array_Attribute =>
+ declare
+ Prefix_Val : Iir_Value_Literal_Acc;
+ Dim : Iir_Int64;
+ begin
+ Dim := Get_Value (Get_Parameter (Prefix));
+ Prefix_Val := Execute_Indexes (Block, Get_Prefix (Prefix), Dim);
+ Bound := Prefix_Val;
+ end;
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ declare
+ Dim : Iir_Int64;
+ begin
+ Dim := Get_Value (Get_Parameter (Prefix));
+ Bound := Execute_Indexes (Block, Get_Prefix (Prefix), Dim);
+ case Bound.Dir is
+ when Iir_To =>
+ Bound := Create_Range_Value
+ (Bound.Right, Bound.Left, Iir_Downto, Bound.Length);
+ when Iir_Downto =>
+ Bound := Create_Range_Value
+ (Bound.Right, Bound.Left, Iir_To, Bound.Length);
+ end case;
+ end;
+
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Integer_Type_Definition =>
+ return Execute_Bounds
+ (Block,
+ Get_Range_Constraint (Get_Type (Get_Type_Declarator (Prefix))));
+
+ when 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;
+
+ 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;
+
+ -- Perform type conversion as desribed in LRM93 7.3.5
+ function Execute_Type_Conversion (Block: Block_Instance_Acc;
+ Conv : Iir_Type_Conversion;
+ Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Target_Type : constant Iir := Get_Type (Conv);
+ Res: Iir_Value_Literal_Acc;
+ begin
+ Res := Val;
+ case Get_Kind (Target_Type) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ case Res.Kind is
+ when Iir_Value_I64 =>
+ null;
+ when Iir_Value_F64 =>
+ if Res.F64 > Ghdl_F64 (Iir_Int64'Last) or
+ Res.F64 < Ghdl_F64 (Iir_Int64'First)
+ then
+ Error_Msg_Constraint (Conv);
+ end if;
+ Res := Create_I64_Value (Ghdl_I64 (Res.F64));
+ when Iir_Value_B2
+ | Iir_Value_E32
+ | Iir_Value_Range
+ | Iir_Value_Array
+ | Iir_Value_Signal
+ | Iir_Value_Record
+ | Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ -- These values are not of abstract numeric type.
+ raise Internal_Error;
+ end case;
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ case Res.Kind is
+ when Iir_Value_F64 =>
+ null;
+ when Iir_Value_I64 =>
+ Res := Create_F64_Value (Ghdl_F64 (Res.I64));
+ when Iir_Value_B2
+ | Iir_Value_E32
+ | Iir_Value_Range
+ | Iir_Value_Array
+ | Iir_Value_Signal
+ | Iir_Value_Record
+ | Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ -- These values are not of abstract numeric type.
+ raise Internal_Error;
+ end case;
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ -- must be same type.
+ null;
+ when Iir_Kind_Array_Type_Definition =>
+ -- LRM93 7.3.5
+ -- if the type mark denotes an unconstrained array type and the
+ -- operand is not a null array, then for each index position, the
+ -- bounds of the result are obtained by converting the bounds of
+ -- the operand to the corresponding index type of the target type.
+ -- FIXME: what is bound conversion ??
+ null;
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- LRM93 7.3.5
+ -- If the type mark denotes a constrained array subtype, then the
+ -- bounds of the result are those imposed by the type mark.
+ Implicit_Array_Conversion (Block, Res, Target_Type, Conv);
+ when others =>
+ Error_Kind ("execute_type_conversion", Target_Type);
+ end case;
+ Check_Constraints (Block, Res, Target_Type, Conv);
+ return Res;
+ end Execute_Type_Conversion;
+
+ -- Decrement VAL.
+ -- May raise a constraint error using EXPR.
+ function Execute_Dec (Val : Iir_Value_Literal_Acc; Expr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Val.Kind is
+ when Iir_Value_B2 =>
+ if Val.B2 = False then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_B2_Value (False);
+ when Iir_Value_E32 =>
+ if Val.E32 = 0 then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_E32_Value (Val.E32 - 1);
+ when Iir_Value_I64 =>
+ if Val.I64 = Ghdl_I64'First then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_I64_Value (Val.I64 - 1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Execute_Dec;
+
+ -- Increment VAL.
+ -- May raise a constraint error using EXPR.
+ function Execute_Inc (Val : Iir_Value_Literal_Acc; Expr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Val.Kind is
+ when Iir_Value_B2 =>
+ if Val.B2 = True then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_B2_Value (True);
+ when Iir_Value_E32 =>
+ if Val.E32 = Ghdl_E32'Last then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_E32_Value (Val.E32 + 1);
+ when Iir_Value_I64 =>
+ if Val.I64 = Ghdl_I64'Last then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_I64_Value (Val.I64 + 1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Execute_Inc;
+
+ function Execute_Expression_With_Type
+ (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Expr_Type : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ if Get_Kind (Expr) = Iir_Kind_Aggregate
+ and then not Is_Fully_Constrained_Type (Get_Type (Expr))
+ then
+ return Execute_Aggregate (Block, Expr, Expr_Type);
+ else
+ Res := Execute_Expression (Block, Expr);
+ Implicit_Array_Conversion (Block, Res, Expr_Type, Expr);
+ Check_Constraints (Block, Res, Expr_Type, Expr);
+ return Res;
+ end if;
+ end Execute_Expression_With_Type;
+
+ function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Base : constant Iir := Get_Base_Name (Expr);
+ Info : constant Sim_Info_Acc := Get_Info (Base);
+ Bblk : Block_Instance_Acc;
+ Base_Val : Iir_Value_Literal_Acc;
+ Res : Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ Bblk := Get_Instance_By_Scope_Level (Block, Info.Scope_Level);
+ Base_Val := Bblk.Objects (Info.Slot + 1);
+ Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig);
+ pragma Assert (Is_Sig);
+ return Res;
+ end Execute_Signal_Init_Value;
+
+ procedure Execute_Name_With_Base (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Base : Iir_Value_Literal_Acc;
+ Res : out Iir_Value_Literal_Acc;
+ Is_Sig : out Boolean)
+ is
+ Slot_Block: Block_Instance_Acc;
+ begin
+ -- Default value
+ Is_Sig := False;
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ Is_Sig := True;
+ if Base /= null then
+ Res := Base;
+ else
+ Slot_Block := Get_Instance_For_Slot (Block, Expr);
+ Res := Slot_Block.Objects (Get_Info (Expr).Slot);
+ end if;
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ pragma Assert (Base = null);
+ -- FIXME: add a flag ?
+ case Get_Kind (Get_Object_Prefix (Expr)) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ Is_Sig := True;
+ when others =>
+ Is_Sig := False;
+ end case;
+ Slot_Block := Get_Instance_For_Slot (Block, Expr);
+ Res := Slot_Block.Objects (Get_Info (Expr).Slot);
+
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Interface_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kinds_Quantity_Declaration =>
+ if Base /= null then
+ Res := Base;
+ else
+ Slot_Block := Get_Instance_For_Slot (Block, Expr);
+ Res := Slot_Block.Objects (Get_Info (Expr).Slot);
+ end if;
+
+ when Iir_Kind_Indexed_Name =>
+ declare
+ Prefix: Iir;
+ Index_List: Iir_List;
+ Index: Iir;
+ Nbr_Dimensions: Iir_Index32;
+ Value: Iir_Value_Literal_Acc;
+ Pfx: Iir_Value_Literal_Acc;
+ Pos, Off : Iir_Index32;
+ begin
+ Prefix := Get_Prefix (Expr);
+ Index_List := Get_Index_List (Expr);
+ Nbr_Dimensions := Iir_Index32 (Get_Nbr_Elements (Index_List));
+ Execute_Name_With_Base (Block, Prefix, Base, Pfx, Is_Sig);
+ for I in 1 .. Nbr_Dimensions loop
+ Index := Get_Nth_Element (Index_List, Natural (I - 1));
+ Value := Execute_Expression (Block, Index);
+ Off := Get_Index_Offset (Value, Pfx.Bounds.D (I), Expr);
+ if I = 1 then
+ Pos := Off;
+ else
+ Pos := Pos * Pfx.Bounds.D (I).Length + Off;
+ end if;
+ end loop;
+ Res := Pfx.Val_Array.V (1 + Pos);
+ -- FIXME: free PFX.
+ end;
+
+ when Iir_Kind_Slice_Name =>
+ declare
+ Prefix: Iir;
+ Prefix_Array: Iir_Value_Literal_Acc;
+
+ Srange : Iir_Value_Literal_Acc;
+ Index_Order : Order;
+ -- Lower and upper bounds of the slice.
+ Low, High: Iir_Index32;
+
+ use Flags;
+ begin
+ Srange := Execute_Bounds (Block, Get_Suffix (Expr));
+
+ Prefix := Get_Prefix (Expr);
+
+ -- 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.
+ Execute_Name_With_Base
+ (Block, Prefix, Base, Prefix_Array, Is_Sig);
+ if Prefix_Array = null then
+ raise Internal_Error;
+ end if;
+
+ -- Check for null slice.
+ if Srange.Dir /= Prefix_Array.Bounds.D (1).Dir then
+ if Vhdl_Std = Vhdl_87 then
+ Res := null; -- FIXME
+ return;
+ else
+ raise Internal_Error;
+ end if;
+ end if;
+
+ Index_Order := Compare_Value (Srange.Left, Srange.Right);
+ if (Srange.Dir = Iir_To and Index_Order = Greater)
+ or (Srange.Dir = Iir_Downto and Index_Order = Less)
+ then
+ -- Null slice.
+ Low := 1;
+ High := 0;
+ else
+ Low := Get_Index_Offset
+ (Srange.Left, Prefix_Array.Bounds.D (1), Expr);
+ High := Get_Index_Offset
+ (Srange.Right, Prefix_Array.Bounds.D (1), Expr);
+ end if;
+ Res := Create_Array_Value (High - Low + 1, 1);
+ Res.Bounds.D (1) := Srange;
+ for I in Low .. High loop
+ Res.Val_Array.V (1 + I - Low) :=
+ Prefix_Array.Val_Array.V (1 + I);
+ end loop;
+ end;
+
+ when Iir_Kind_Selected_Element =>
+ declare
+ Prefix: Iir_Value_Literal_Acc;
+ Pos: Iir_Index32;
+ begin
+ Execute_Name_With_Base
+ (Block, Get_Prefix (Expr), Base, Prefix, Is_Sig);
+ Pos := Get_Element_Position (Get_Selected_Element (Expr));
+ Res := Prefix.Val_Record.V (Pos + 1);
+ end;
+
+ when Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference =>
+ declare
+ Prefix: Iir_Value_Literal_Acc;
+ begin
+ Prefix := Execute_Name (Block, Get_Prefix (Expr));
+ Res := Prefix.Val_Access;
+ if Res = null then
+ Error_Msg_Exec ("deferencing null access", Expr);
+ end if;
+ end;
+
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Execute_Name_With_Base
+ (Block, Get_Named_Entity (Expr), Base, Res, Is_Sig);
+
+ when Iir_Kind_Function_Call =>
+ -- A prefix can be an expression
+ if Base /= null then
+ raise Internal_Error;
+ end if;
+ Res := Execute_Expression (Block, Expr);
+
+ when Iir_Kind_Aggregate =>
+ Res := Execute_Name_Aggregate (Block, Expr, Get_Type (Expr));
+ -- FIXME: is_sig ?
+
+ when others =>
+ Error_Kind ("execute_name_with_base", Expr);
+ end case;
+ end Execute_Name_With_Base;
+
+ function Execute_Name (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Ref : Boolean := False)
+ return Iir_Value_Literal_Acc
+ is
+ Res: Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ Execute_Name_With_Base (Block, Expr, null, Res, Is_Sig);
+ if not Is_Sig or else Ref then
+ return Res;
+ else
+ return Execute_Signal_Value (Res);
+ end if;
+ end Execute_Name;
+
+ function String_To_Iir_Value (Str : String) return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Array_Value (Str'Length, 1);
+ Res.Bounds.D (1) := Create_Range_Value
+ (Create_I64_Value (1),
+ Create_I64_Value (Str'Length),
+ Iir_To);
+ for I in Str'Range loop
+ Res.Val_Array.V (1 + Iir_Index32 (I - Str'First)) :=
+ Create_E32_Value (Character'Pos (Str (I)));
+ end loop;
+ return Res;
+ end String_To_Iir_Value;
+
+ function Execute_Image_Attribute (Block: Block_Instance_Acc; Expr: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Val : Iir_Value_Literal_Acc;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Val := Execute_Expression (Block, Get_Parameter (Expr));
+ case Val.Kind is
+ when Iir_Value_F64 =>
+ declare
+ Str : String (1 .. 24);
+ Last : Natural;
+ begin
+ Grt.Vstrings.To_String (Str, Last, Val.F64);
+ Res := String_To_Iir_Value (Str (Str'First .. Last));
+ end;
+ when Iir_Value_I64 =>
+ declare
+ Str : String (1 .. 21);
+ First : Natural;
+ begin
+ Grt.Vstrings.To_String (Str, First, Val.I64);
+ Res := String_To_Iir_Value (Str (First .. Str'Last));
+ end;
+ when Iir_Value_B2 =>
+ declare
+ Lits : constant Iir_List := Get_Enumeration_Literal_List
+ (Get_Type (Get_Prefix (Expr)));
+ begin
+ Res := String_To_Iir_Value
+ (Name_Table.Image
+ (Get_Identifier
+ (Get_Nth_Element (Lits, Ghdl_B2'Pos (Val.B2)))));
+ end;
+ when Iir_Value_E32 =>
+ declare
+ Lits : constant Iir_List := Get_Enumeration_Literal_List
+ (Get_Type (Get_Prefix (Expr)));
+ begin
+ Res := String_To_Iir_Value
+ (Name_Table.Image
+ (Get_Identifier
+ (Get_Nth_Element (Lits, Ghdl_E32'Pos (Val.E32)))));
+ end;
+ when others =>
+ Error_Kind ("image_attribute " & Iir_Value_Kind'Image (Val.Kind),
+ Expr);
+ end case;
+ return Res;
+ end Execute_Image_Attribute;
+
+ function Execute_Value_Attribute (Block: Block_Instance_Acc;
+ Str_Val : Iir_Value_Literal_Acc;
+ Expr: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ use Grt_Interface;
+ use Name_Table;
+ pragma Unreferenced (Block);
+
+ Expr_Type : constant Iir := Get_Type (Expr);
+ Res : Iir_Value_Literal_Acc;
+
+ Str_Bnd : aliased Std_String_Bound := Build_Bound (Str_Val);
+ Str_Str : aliased Std_String_Uncons (1 .. Str_Bnd.Dim_1.Length);
+ Str : aliased Std_String := (To_Std_String_Basep (Str_Str'Address),
+ To_Std_String_Boundp (Str_Bnd'Address));
+ begin
+ Set_Std_String_From_Iir_Value (Str, Str_Val);
+ case Get_Kind (Expr_Type) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ Res := Create_I64_Value
+ (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access));
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ Res := Create_F64_Value
+ (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access));
+ when Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ declare
+ Is_Real : Boolean;
+ Lit_Pos : Ghdl_Index_Type;
+ Lit_End : Ghdl_Index_Type;
+ Unit_Pos : Ghdl_Index_Type;
+ Unit_Len : Ghdl_Index_Type;
+ Mult : Ghdl_I64;
+ Unit : Iir;
+ Unit_Id : Name_Id;
+ begin
+ Grt.Values.Ghdl_Value_Physical_Split
+ (Str'Unrestricted_Access,
+ Is_Real, Lit_Pos, Lit_End, Unit_Pos);
+
+ -- Find unit.
+ Unit_Len := 0;
+ Unit_Pos := Unit_Pos + 1; -- From 0 based to 1 based
+ for I in Unit_Pos .. Str_Bnd.Dim_1.Length loop
+ exit when Grt.Values.Is_Whitespace (Str_Str (I));
+ Unit_Len := Unit_Len + 1;
+ Str_Str (I) := Grt.Values.To_LC (Str_Str (I));
+ end loop;
+
+ Unit := Get_Primary_Unit (Expr_Type);
+ while Unit /= Null_Iir loop
+ Unit_Id := Get_Identifier (Unit);
+ exit when Get_Name_Length (Unit_Id) = Natural (Unit_Len)
+ and then Image (Unit_Id) =
+ String (Str_Str (Unit_Pos .. Unit_Pos + Unit_Len - 1));
+ Unit := Get_Chain (Unit);
+ end loop;
+
+ if Unit = Null_Iir then
+ Error_Msg_Exec ("incorrect unit name", Expr);
+ end if;
+ Mult := Ghdl_I64 (Get_Value (Get_Physical_Unit_Value (Unit)));
+
+ Str_Bnd.Dim_1.Length := Lit_End;
+ if Is_Real then
+ Res := Create_I64_Value
+ (Ghdl_I64
+ (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access)
+ * Ghdl_F64 (Mult)));
+ else
+ Res := Create_I64_Value
+ (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access)
+ * Mult);
+ end if;
+ end;
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ declare
+ Lit_Start : Ghdl_Index_Type;
+ Lit_End : Ghdl_Index_Type;
+ Enums : constant Iir_List :=
+ Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type));
+ Enum : Iir;
+ Enum_Id : Name_Id;
+ begin
+ -- Remove leading and trailing blanks
+ for I in Str_Str'Range loop
+ if not Grt.Values.Is_Whitespace (Str_Str (I)) then
+ Lit_Start := I;
+ exit;
+ end if;
+ end loop;
+ for I in reverse Lit_Start .. Str_Str'Last loop
+ if not Grt.Values.Is_Whitespace (Str_Str (I)) then
+ Lit_End := I;
+ exit;
+ end if;
+ end loop;
+
+ -- Convert to lower case.
+ for I in Lit_Start .. Lit_End loop
+ Str_Str (I) := Grt.Values.To_LC (Str_Str (I));
+ end loop;
+
+ for I in Natural loop
+ Enum := Get_Nth_Element (Enums, I);
+ if Enum = Null_Iir then
+ Error_Msg_Exec ("incorrect unit name", Expr);
+ end if;
+ Enum_Id := Get_Identifier (Enum);
+ exit when (Get_Name_Length (Enum_Id) =
+ Natural (Lit_End - Lit_Start + 1))
+ and then (Image (Enum_Id) =
+ String (Str_Str (Lit_Start .. Lit_End)));
+ end loop;
+
+ return Create_Enum_Value
+ (Natural (Get_Enum_Pos (Enum)), Expr_Type);
+ end;
+ when others =>
+ Error_Kind ("value_attribute", Expr_Type);
+ end case;
+ return Res;
+ end Execute_Value_Attribute;
+
+ function Execute_Path_Instance_Name_Attribute
+ (Block : Block_Instance_Acc; Attr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ use Evaluation;
+ use Grt.Vstrings;
+ use Name_Table;
+
+ Name : constant Path_Instance_Name_Type :=
+ Get_Path_Instance_Name_Suffix (Attr);
+ Instance : Block_Instance_Acc;
+ Rstr : Rstring;
+ Is_Instance : constant Boolean :=
+ Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute;
+ begin
+ Instance := Get_Instance_By_Scope_Level
+ (Block, Get_Info (Name.Path_Instance).Frame_Scope_Level);
+
+ loop
+ case Get_Kind (Instance.Name) is
+ when Iir_Kind_Entity_Declaration =>
+ if Instance.Parent = null then
+ Prepend (Rstr, Image (Get_Identifier (Instance.Name)));
+ exit;
+ end if;
+ when Iir_Kind_Architecture_Declaration =>
+ if Is_Instance then
+ Prepend (Rstr, ')');
+ Prepend (Rstr, Image (Get_Identifier (Instance.Name)));
+ Prepend (Rstr, '(');
+ end if;
+
+ if Is_Instance or else Instance.Parent = null then
+ Prepend
+ (Rstr,
+ Image (Get_Identifier (Get_Entity (Instance.Name))));
+ end if;
+ if Instance.Parent = null then
+ Prepend (Rstr, ':');
+ exit;
+ else
+ Instance := Instance.Parent;
+ end if;
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Scheme : constant Iir :=
+ Get_Generation_Scheme (Instance.Name);
+ begin
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Prepend (Rstr, ')');
+ Prepend (Rstr, 'X');
+ Prepend (Rstr, '(');
+ Prepend (Rstr, Image (Get_Label (Instance.Name)));
+ end if;
+ Instance := Instance.Parent;
+ end;
+ when others =>
+ Error_Kind ("Execute_Path_Instance_Name_Attribute",
+ Instance.Name);
+ end case;
+ end loop;
+ declare
+ Str1 : String (1 .. Length (Rstr));
+ Len1 : Natural;
+ begin
+ Copy (Rstr, Str1, Len1);
+ Free (Rstr);
+ return String_To_Iir_Value (Str1 & ':' & Name.Suffix);
+ end;
+ end Execute_Path_Instance_Name_Attribute;
+
+ -- For 'Last_Event and 'Last_Active: convert the absolute last time to
+ -- a relative delay.
+ function To_Relative_Time (T : Ghdl_I64) return Iir_Value_Literal_Acc is
+ A : Ghdl_I64;
+ begin
+ if T = -Ghdl_I64'Last then
+ A := Ghdl_I64'Last;
+ else
+ A := Ghdl_I64 (Grt.Types.Current_Time) - T;
+ end if;
+ return Create_I64_Value (A);
+ end To_Relative_Time;
+
+ -- Evaluate an expression.
+ function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res: Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Object_Alias_Declaration =>
+ Res := Execute_Name (Block, Expr);
+ return Res;
+
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Interface_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference =>
+ return Execute_Name (Block, Expr);
+
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return Execute_Expression (Block, Get_Named_Entity (Expr));
+
+ when Iir_Kind_Aggregate =>
+ return Execute_Aggregate (Block, Expr, Get_Type (Expr));
+ when Iir_Kind_Simple_Aggregate =>
+ return Execute_Simple_Aggregate (Block, Expr);
+
+ when Iir_Kinds_Dyadic_Operator
+ | Iir_Kinds_Monadic_Operator =>
+ declare
+ Imp : Iir;
+ begin
+ Imp := Get_Implementation (Expr);
+ if Get_Kind (Imp) = Iir_Kind_Function_Declaration then
+ return Execute_Function_Call (Block, Expr, Imp);
+ else
+ if Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator then
+ Res := Execute_Implicit_Function
+ (Block, Expr, Get_Left (Expr), Get_Right (Expr),
+ Get_Type (Expr));
+ else
+ Res := Execute_Implicit_Function
+ (Block, Expr, Get_Operand (Expr), Null_Iir,
+ Get_Type (Expr));
+ end if;
+ return Res;
+ end if;
+ end;
+
+ when Iir_Kind_Function_Call =>
+ declare
+ Imp : Iir;
+ Assoc : Iir;
+ Args : Iir_Array (0 .. 1);
+ begin
+ Imp := Get_Implementation (Expr);
+ if Get_Kind (Imp) = Iir_Kind_Function_Declaration then
+ return Execute_Function_Call (Block, Expr, Imp);
+ else
+ Assoc := Get_Parameter_Association_Chain (Expr);
+ if Assoc /= Null_Iir then
+ Args (0) := Get_Actual (Assoc);
+ Assoc := Get_Chain (Assoc);
+ else
+ Args (0) := Null_Iir;
+ end if;
+ if Assoc /= Null_Iir then
+ Args (1) := Get_Actual (Assoc);
+ else
+ Args (1) := Null_Iir;
+ end if;
+ return Execute_Implicit_Function
+ (Block, Expr, Args (0), Args (1), Get_Type (Expr));
+ end if;
+ end;
+
+ when Iir_Kind_Integer_Literal =>
+ declare
+ Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr));
+ Lit : constant Iir_Int64 := Get_Value (Expr);
+ begin
+ case Get_Info (Lit_Type).Scalar_Mode is
+ when Iir_Value_I64 =>
+ return Create_I64_Value (Ghdl_I64 (Lit));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end;
+
+ when Iir_Kind_Floating_Point_Literal =>
+ return Create_F64_Value (Ghdl_F64 (Get_Fp_Value (Expr)));
+
+ when Iir_Kind_Enumeration_Literal =>
+ declare
+ Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr));
+ Lit : constant Iir_Int32 := Get_Enum_Pos (Expr);
+ begin
+ case Get_Info (Lit_Type).Scalar_Mode is
+ when Iir_Value_B2 =>
+ return Create_B2_Value (Ghdl_B2'Val (Lit));
+ when Iir_Value_E32 =>
+ return Create_E32_Value (Ghdl_E32 (Lit));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end;
+
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Unit_Declaration =>
+ return Create_I64_Value
+ (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr)));
+
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ return String_To_Enumeration_Array (Block, Expr);
+
+ when Iir_Kind_Null_Literal =>
+ return Null_Lit;
+
+ when Iir_Kind_Type_Conversion =>
+ return Execute_Type_Conversion
+ (Block, Expr,
+ Execute_Expression (Block, Get_Expression (Expr)));
+
+ when Iir_Kind_Qualified_Expression =>
+ Res := Execute_Expression_With_Type
+ (Block, Get_Expression (Expr), Get_Type_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_Expression (Expr), True);
+ Res := Unshare_Heap (Res);
+ return Create_Access_Value (Res);
+
+ when Iir_Kind_Left_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_Left_Limit (Res);
+
+ when Iir_Kind_Right_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_Right_Limit (Res);
+
+ when Iir_Kind_High_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_High_Limit (Res);
+
+ when Iir_Kind_Low_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_Low_Limit (Res);
+
+ when Iir_Kind_High_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_High_Limit (Res);
+
+ when Iir_Kind_Low_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Low_Limit (Res);
+
+ when Iir_Kind_Left_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Left_Limit (Res);
+
+ when Iir_Kind_Right_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Right_Limit (Res);
+
+ when Iir_Kind_Length_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Length (Res);
+
+ when Iir_Kind_Event_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Boolean_To_Lit (Execute_Event_Attribute (Res));
+
+ when Iir_Kind_Active_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Boolean_To_Lit (Execute_Active_Attribute (Res));
+
+ when Iir_Kind_Driving_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Boolean_To_Lit (Execute_Driving_Attribute (Res));
+
+ when Iir_Kind_Last_Value_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Execute_Last_Value_Attribute (Res);
+
+ when Iir_Kind_Driving_Value_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Execute_Driving_Value_Attribute (Res);
+
+ when Iir_Kind_Last_Event_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return To_Relative_Time (Execute_Last_Event_Attribute (Res));
+
+ when Iir_Kind_Last_Active_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return To_Relative_Time (Execute_Last_Active_Attribute (Res));
+
+ when Iir_Kind_Val_Attribute =>
+ declare
+ Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr));
+ Base_Type : constant Iir := Get_Base_Type (Prefix_Type);
+ Mode : constant Iir_Value_Kind :=
+ Get_Info (Base_Type).Scalar_Mode;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ case Mode is
+ when Iir_Value_I64 =>
+ null;
+ when Iir_Value_E32 =>
+ Res := Create_E32_Value (Ghdl_E32 (Res.I64));
+ when Iir_Value_B2 =>
+ Res := Create_B2_Value (Ghdl_B2'Val (Res.I64));
+ when others =>
+ Error_Kind ("execute_expression(val attribute)",
+ Prefix_Type);
+ end case;
+ Check_Constraints (Block, Res, Prefix_Type, Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Pos_Attribute =>
+ declare
+ N_Res: Iir_Value_Literal_Acc;
+ Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr));
+ Base_Type : constant Iir := Get_Base_Type (Prefix_Type);
+ Mode : constant Iir_Value_Kind :=
+ Get_Info (Base_Type).Scalar_Mode;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ case Mode is
+ when Iir_Value_I64 =>
+ null;
+ when Iir_Value_B2 =>
+ N_Res := Create_I64_Value (Ghdl_B2'Pos (Res.B2));
+ Res := N_Res;
+ when Iir_Value_E32 =>
+ N_Res := Create_I64_Value (Ghdl_I64 (Res.E32));
+ Res := N_Res;
+ when others =>
+ Error_Kind ("execute_expression(pos attribute)",
+ Base_Type);
+ end case;
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Succ_Attribute =>
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Res := Execute_Inc (Res, Expr);
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+
+ when Iir_Kind_Pred_Attribute =>
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Res := Execute_Dec (Res, Expr);
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+
+ when Iir_Kind_Leftof_Attribute =>
+ declare
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Bound := Execute_Bounds (Block, Get_Type (Get_Prefix (Expr)));
+ case Bound.Dir is
+ when Iir_To =>
+ Res := Execute_Dec (Res, Expr);
+ when Iir_Downto =>
+ Res := Execute_Inc (Res, Expr);
+ end case;
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Rightof_Attribute =>
+ declare
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Bound := Execute_Bounds (Block, Get_Type (Get_Prefix (Expr)));
+ case Bound.Dir is
+ when Iir_Downto =>
+ Res := Execute_Dec (Res, Expr);
+ when Iir_To =>
+ Res := Execute_Inc (Res, Expr);
+ end case;
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Image_Attribute =>
+ return Execute_Image_Attribute (Block, Expr);
+
+ when Iir_Kind_Value_Attribute =>
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ return Execute_Value_Attribute (Block, Res, Expr);
+
+ when Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute =>
+ return Execute_Path_Instance_Name_Attribute (Block, Expr);
+
+ when others =>
+ Error_Kind ("execute_expression", Expr);
+ end case;
+ end Execute_Expression;
+
+ procedure Execute_Dyadic_Association
+ (Out_Block: Block_Instance_Acc;
+ In_Block: Block_Instance_Acc;
+ Expr : Iir;
+ Inter_Chain: Iir)
+ is
+ Inter: Iir;
+ Val: Iir_Value_Literal_Acc;
+ begin
+ Inter := Inter_Chain;
+ for I in 0 .. 1 loop
+ if I = 0 then
+ Val := Execute_Expression (Out_Block, Get_Left (Expr));
+ else
+ Val := Execute_Expression (Out_Block, Get_Right (Expr));
+ end if;
+ Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr);
+ Check_Constraints (In_Block, Val, Get_Type (Inter), Expr);
+
+ Elaboration.Create_Object (In_Block, Inter);
+ In_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare (Val, Instance_Pool);
+ Inter := Get_Chain (Inter);
+ end loop;
+ end Execute_Dyadic_Association;
+
+ procedure Execute_Monadic_Association
+ (Out_Block: Block_Instance_Acc;
+ In_Block: Block_Instance_Acc;
+ Expr : Iir;
+ Inter: Iir)
+ is
+ Val: Iir_Value_Literal_Acc;
+ begin
+ Val := Execute_Expression (Out_Block, Get_Operand (Expr));
+ Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr);
+ Check_Constraints (In_Block, Val, Get_Type (Inter), Expr);
+
+ Elaboration.Create_Object (In_Block, Inter);
+ In_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare (Val, Instance_Pool);
+ end Execute_Monadic_Association;
+
+ -- Create a block instance for subprogram IMP.
+ function Create_Subprogram_Instance (Instance : Block_Instance_Acc;
+ Imp : Iir)
+ return Block_Instance_Acc
+ is
+ Func_Info : constant Sim_Info_Acc := Get_Info (Imp);
+
+ subtype Block_Type is Block_Instance_Type (Func_Info.Nbr_Objects);
+ function To_Block_Instance_Acc is new
+ Ada.Unchecked_Conversion (System.Address, Block_Instance_Acc);
+ function Alloc_Block_Instance is new
+ Alloc_On_Pool_Addr (Block_Type);
+
+ Up_Block: Block_Instance_Acc;
+ Res : Block_Instance_Acc;
+ begin
+ Up_Block := Get_Instance_By_Scope_Level
+ (Instance, Func_Info.Frame_Scope_Level - 1);
+
+ Res := To_Block_Instance_Acc
+ (Alloc_Block_Instance
+ (Instance_Pool,
+ Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects,
+ Scope_Level => Func_Info.Frame_Scope_Level,
+ Up_Block => Up_Block,
+ Name => Imp,
+ Parent => Instance,
+ Children => null,
+ Brother => null,
+ Configuration => Null_Iir,
+ Marker => Empty_Marker,
+ Objects => (others => null),
+ Elab_Objects => 0,
+ Instances => null,
+ In_Wait_Flag => False,
+ Cur_Stmt => Null_Iir,
+ 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.Name);
+ begin
+ Finalize_Declarative_Part
+ (Instance, Get_Declaration_Chain (Subprg_Body));
+ end Execute_Subprogram_Call_Final;
+
+ function Execute_Function_Body (Instance : Block_Instance_Acc; Func : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Subprg_Body : constant Iir := Get_Subprogram_Body (Func);
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Current_Process.Instance := Instance;
+
+ Elaborate_Declarative_Part
+ (Instance, Get_Declaration_Chain (Subprg_Body));
+
+ -- execute statements
+ Instance.Cur_Stmt := Get_Sequential_Statement_Chain (Subprg_Body);
+ Execute_Sequential_Statements (Current_Process);
+ pragma Assert (Current_Process.Instance = Instance);
+
+ if Instance.Result = null then
+ Error_Msg_Exec
+ ("function scope exited without a return statement", Func);
+ end if;
+
+ -- Free variables, slots...
+ -- Need to copy the return value, because it can contains values from
+ -- arguments.
+ Res := Instance.Result;
+
+ Current_Process.Instance := Instance.Parent;
+ Execute_Subprogram_Call_Final (Instance);
+
+ return Res;
+ end Execute_Function_Body;
+
+ function Execute_Assoc_Function_Conversion
+ (Block : Block_Instance_Acc; Func : Iir; Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Inter : Iir;
+ Instance : Block_Instance_Acc;
+ Res : Iir_Value_Literal_Acc;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Instance_Pool.all);
+
+ -- Create an instance for this function.
+ Instance := Create_Subprogram_Instance (Block, Func);
+
+ Inter := Get_Interface_Declaration_Chain (Func);
+ Elaboration.Create_Object (Instance, Inter);
+ -- FIXME: implicit conversion
+ Instance.Objects (Get_Info (Inter).Slot) := Val;
+
+ Res := Execute_Function_Body (Instance, Func);
+ Res := Unshare (Res, Expr_Pool'Access);
+ Release (Marker, Instance_Pool.all);
+ return Res;
+ end Execute_Assoc_Function_Conversion;
+
+ function Execute_Assoc_Conversion
+ (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ if Get_Kind (Conv) = Iir_Kind_Function_Call then
+ return Execute_Assoc_Function_Conversion
+ (Block, Get_Implementation (Conv), Val);
+ elsif Get_Kind (Conv) = Iir_Kind_Function_Declaration then
+ return Execute_Assoc_Function_Conversion (Block, Conv, Val);
+ else
+ return Execute_Type_Conversion (Block, Conv, Val);
+ end if;
+ end Execute_Assoc_Conversion;
+
+ -- Establish correspondance for association list ASSOC_LIST from block
+ -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK.
+ procedure Execute_Association
+ (Out_Block: Block_Instance_Acc;
+ Subprg_Block: Block_Instance_Acc;
+ Assoc_Chain: Iir)
+ is
+ Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain);
+ Assoc: Iir;
+ Actual : Iir;
+ Inter: Iir;
+ Formal : Iir;
+ Conv : Iir;
+ Val: Iir_Value_Literal_Acc;
+ Assoc_Idx : Iir_Index32;
+ Last_Individual : Iir_Value_Literal_Acc;
+ Mode : Iir_Mode;
+ Marker : Mark_Type;
+ begin
+ Subprg_Block.Actuals_Ref := null;
+ Mark (Marker, Expr_Pool);
+
+ Assoc := Assoc_Chain;
+ Assoc_Idx := 1;
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ Inter := Get_Base_Name (Formal);
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_Open =>
+ -- Not allowed in individual association.
+ pragma Assert (Formal = Inter);
+ pragma Assert (Get_Whole_Association_Flag (Assoc));
+ Actual := Get_Default_Value (Inter);
+ when Iir_Kind_Association_Element_By_Expression =>
+ Actual := Get_Actual (Assoc);
+ when Iir_Kind_Association_Element_By_Individual =>
+ -- FIXME: signals ?
+ pragma Assert
+ (Get_Kind (Inter) /= Iir_Kind_Signal_Interface_Declaration);
+ Last_Individual := Create_Value_For_Type
+ (Out_Block, Get_Actual_Type (Assoc), False);
+ Last_Individual := Unshare (Last_Individual, Instance_Pool);
+
+ Elaboration.Create_Object (Subprg_Block, Inter);
+ Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual;
+ goto Continue;
+ when others =>
+ Error_Kind ("execute_association(1)", Assoc);
+ end case;
+
+ case Get_Kind (Inter) is
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ Val := Execute_Expression (Out_Block, Actual);
+ Implicit_Array_Conversion
+ (Subprg_Block, Val, Get_Type (Formal), Assoc);
+ Check_Constraints (Subprg_Block, Val, Get_Type (Formal), Assoc);
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Val := Execute_Name (Out_Block, Actual, True);
+ Implicit_Array_Conversion
+ (Subprg_Block, Val, Get_Type (Formal), Assoc);
+ when Iir_Kind_Variable_Interface_Declaration =>
+ Mode := Get_Mode (Inter);
+ if Mode = Iir_In_Mode then
+ -- FIXME: Ref ?
+ Val := Execute_Expression (Out_Block, Actual);
+ else
+ Val := Execute_Name (Out_Block, Actual, False);
+ end if;
+
+ -- FIXME: by value for scalars ?
+
+ -- Keep ref for back-copy
+ if Mode /= Iir_In_Mode then
+ if Subprg_Block.Actuals_Ref = null then
+ declare
+ subtype Actuals_Ref_Type is
+ Value_Array (Iir_Index32 (Nbr_Assoc));
+ function To_Value_Array_Acc is new
+ Ada.Unchecked_Conversion (System.Address,
+ Value_Array_Acc);
+ function Alloc_Actuals_Ref is new
+ Alloc_On_Pool_Addr (Actuals_Ref_Type);
+
+ begin
+ Subprg_Block.Actuals_Ref := To_Value_Array_Acc
+ (Alloc_Actuals_Ref
+ (Instance_Pool,
+ Actuals_Ref_Type'(Len => Iir_Index32 (Nbr_Assoc),
+ V => (others => null))));
+ end;
+ end if;
+ Subprg_Block.Actuals_Ref.V (Assoc_Idx) :=
+ Unshare_Bounds (Val, Instance_Pool);
+ end if;
+
+ if Mode = Iir_Out_Mode
+ and then Get_Out_Conversion (Assoc) /= Null_Iir
+ then
+ -- For an OUT variable using an out conversion, don't
+ -- associate with the actual, create a temporary value.
+ Val := Create_Value_For_Type
+ (Out_Block, Get_Type (Formal), True);
+ else
+ if Get_Kind (Assoc) =
+ Iir_Kind_Association_Element_By_Expression
+ then
+ Conv := Get_In_Conversion (Assoc);
+ if Conv /= Null_Iir then
+ Val := Execute_Assoc_Conversion
+ (Subprg_Block, Conv, Val);
+ end if;
+ end if;
+
+ Implicit_Array_Conversion
+ (Subprg_Block, Val, Get_Type (Formal), Assoc);
+ end if;
+ when others =>
+ Error_Kind ("execute_association(2)", Inter);
+ end case;
+
+ if Get_Whole_Association_Flag (Assoc) then
+ case Get_Kind (Inter) is
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ -- FIXME: Arguments are passed by copy.
+ Elaboration.Create_Object (Subprg_Block, Inter);
+ Subprg_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare (Val, Instance_Pool);
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Elaboration.Create_Signal (Subprg_Block, Inter);
+ Subprg_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare_Bounds (Val, Instance_Pool);
+ when others =>
+ Error_Kind ("execute_association", Inter);
+ end case;
+ else
+ declare
+ Targ : Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ Execute_Name_With_Base
+ (Subprg_Block, Formal, Last_Individual, Targ, Is_Sig);
+ Store (Targ, Val);
+ end;
+ end if;
+
+ << Continue >> null;
+ Assoc := Get_Chain (Assoc);
+ Assoc_Idx := Assoc_Idx + 1;
+ end loop;
+
+ Release (Marker, Expr_Pool);
+ end Execute_Association;
+
+ procedure Execute_Back_Association (Instance : Block_Instance_Acc)
+ is
+ Proc : Iir;
+ Assoc: Iir;
+ Inter: Iir;
+ Formal : Iir;
+ Assoc_Idx : Iir_Index32;
+ begin
+ Proc := Get_Procedure_Call (Instance.Parent.Cur_Stmt);
+ Assoc := Get_Parameter_Association_Chain (Proc);
+ Assoc_Idx := 1;
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then
+ Formal := Get_Formal (Assoc);
+ Inter := Get_Base_Name (Formal);
+ case Get_Kind (Inter) is
+ when Iir_Kind_Variable_Interface_Declaration =>
+ if Get_Mode (Inter) /= Iir_In_Mode
+ and then Get_Kind (Get_Type (Inter)) /=
+ Iir_Kind_File_Type_Definition
+ then
+ -- For out/inout variable interface, the value must
+ -- be copied (FIXME: unless when passed by reference ?).
+ declare
+ Targ : constant Iir_Value_Literal_Acc :=
+ Instance.Actuals_Ref.V (Assoc_Idx);
+ Base : constant Iir_Value_Literal_Acc :=
+ Instance.Objects (Get_Info (Inter).Slot);
+ Val : Iir_Value_Literal_Acc;
+ Conv : Iir;
+ Is_Sig : Boolean;
+ Expr_Mark : Mark_Type;
+ begin
+ Mark (Expr_Mark, Expr_Pool);
+
+ -- Extract for individual association.
+ Execute_Name_With_Base
+ (Instance, Formal, Base, Val, Is_Sig);
+ Conv := Get_Out_Conversion (Assoc);
+ if Conv /= Null_Iir then
+ Val := Execute_Assoc_Conversion
+ (Instance, Conv, Val);
+ -- FIXME: free val ?
+ end if;
+ Store (Targ, Val);
+
+ Release (Expr_Mark, Expr_Pool);
+ end;
+ end if;
+ when Iir_Kind_File_Interface_Declaration =>
+ null;
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("execute_back_association", Inter);
+ end case;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ Assoc_Idx := Assoc_Idx + 1;
+ end loop;
+ end Execute_Back_Association;
+
+ -- When a subprogram of a protected type is called, a link to the object
+ -- must be passed. This procedure modifies the up_link of SUBPRG_BLOCK to
+ -- point to the block of the object (extracted from CALL and BLOCK).
+ -- This change doesn't modify the parent (so that the activation chain is
+ -- not changed).
+ procedure Adjust_Up_Link_For_Protected_Object
+ (Block: Block_Instance_Acc; Call: Iir; Subprg_Block : Block_Instance_Acc)
+ is
+ Meth_Obj : constant Iir := Get_Method_Object (Call);
+ Obj : Iir_Value_Literal_Acc;
+ Obj_Block : Block_Instance_Acc;
+ begin
+ if Meth_Obj /= Null_Iir then
+ Obj := Execute_Name (Block, Meth_Obj, True);
+ Obj_Block := Protected_Table.Table (Obj.Prot);
+ Subprg_Block.Up_Block := Obj_Block;
+ end if;
+ end Adjust_Up_Link_For_Protected_Object;
+
+ -- BLOCK is the block instance in which the function call appears.
+ function Execute_Function_Call
+ (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp);
+ Subprg_Block: Block_Instance_Acc;
+ Assoc_Chain: Iir;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Mark (Block.Marker, Instance_Pool.all);
+
+ Subprg_Block := Create_Subprogram_Instance (Block, Imp);
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Function_Call =>
+ Adjust_Up_Link_For_Protected_Object (Block, Expr, Subprg_Block);
+ Assoc_Chain := Get_Parameter_Association_Chain (Expr);
+ Execute_Association (Block, Subprg_Block, Assoc_Chain);
+ -- No out/inout interface for functions.
+ pragma Assert (Subprg_Block.Actuals_Ref = null);
+ when Iir_Kinds_Dyadic_Operator =>
+ Execute_Dyadic_Association
+ (Block, Subprg_Block, Expr, Inter_Chain);
+ when Iir_Kinds_Monadic_Operator =>
+ Execute_Monadic_Association
+ (Block, Subprg_Block, Expr, Inter_Chain);
+ when others =>
+ Error_Kind ("execute_subprogram_call_init", Expr);
+ end case;
+
+ Res := Execute_Function_Body (Subprg_Block, Imp);
+
+ -- Unfortunately, we don't know where the result has been allocated,
+ -- so copy it before releasing the instance pool.
+ Res := Unshare (Res, Expr_Pool'Access);
+
+ Release (Block.Marker, Instance_Pool.all);
+
+ return Res;
+ end Execute_Function_Call;
+
+ -- Slide an array VALUE using bounds from REF_VALUE. Do not modify
+ -- VALUE if not an array.
+ procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc;
+ Ref_Value : Iir_Value_Literal_Acc;
+ Expr : Iir)
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ if Value.Kind /= Iir_Value_Array then
+ return;
+ end if;
+ Res := Create_Array_Value (Value.Bounds.Nbr_Dims);
+ Res.Val_Array := Value.Val_Array;
+ for I in Value.Bounds.D'Range loop
+ if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then
+ Error_Msg_Constraint (Expr);
+ return;
+ end if;
+ Res.Bounds.D (I) := Ref_Value.Bounds.D (I);
+ end loop;
+ Value := Res;
+ end Implicit_Array_Conversion;
+
+ procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc;
+ Value : in out Iir_Value_Literal_Acc;
+ Ref_Type : Iir;
+ Expr : Iir)
+ is
+ Ref_Value : Iir_Value_Literal_Acc;
+ begin
+ -- Do array conversion only if REF_TYPE is a constrained array type
+ -- definition.
+ if Value.Kind /= Iir_Value_Array then
+ return;
+ end if;
+ if Get_Constraint_State (Ref_Type) /= Fully_Constrained then
+ return;
+ end if;
+ Ref_Value := Create_Array_Bounds_From_Type (Instance, Ref_Type, True);
+ for I in Value.Bounds.D'Range loop
+ if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then
+ Error_Msg_Constraint (Expr);
+ return;
+ end if;
+ end loop;
+ Ref_Value.Val_Array.V := Value.Val_Array.V;
+ Value := Ref_Value;
+ end Implicit_Array_Conversion;
+
+ procedure Check_Array_Constraints
+ (Instance: Block_Instance_Acc;
+ Value: Iir_Value_Literal_Acc;
+ Def: Iir;
+ Expr: Iir)
+ is
+ Index_List: Iir_List;
+ Element_Subtype: Iir;
+ New_Bounds : Iir_Value_Literal_Acc;
+ begin
+ -- Nothing to check for unconstrained arrays.
+ if not Get_Index_Constraint_Flag (Def) then
+ return;
+ end if;
+
+ Index_List := Get_Index_Subtype_List (Def);
+ for I in Value.Bounds.D'Range loop
+ New_Bounds := Execute_Bounds
+ (Instance, Get_Nth_Element (Index_List, Natural (I - 1)));
+ if not Is_Equal (Value.Bounds.D (I), New_Bounds) then
+ Error_Msg_Constraint (Expr);
+ return;
+ end if;
+ end loop;
+
+ if Boolean'(False) then
+ Index_List := Get_Index_List (Def);
+ Element_Subtype := Get_Element_Subtype (Def);
+ for I in Value.Val_Array.V'Range loop
+ Check_Constraints
+ (Instance, Value.Val_Array.V (I), Element_Subtype, Expr);
+ end loop;
+ end if;
+ end Check_Array_Constraints;
+
+ -- Check DEST and SRC are array compatible.
+ procedure Check_Array_Match
+ (Instance: Block_Instance_Acc;
+ Dest: Iir_Value_Literal_Acc;
+ Src : Iir_Value_Literal_Acc;
+ Expr: Iir)
+ is
+ pragma Unreferenced (Instance);
+ begin
+ for I in Dest.Bounds.D'Range loop
+ if Dest.Bounds.D (I).Length /= Src.Bounds.D (I).Length then
+ Error_Msg_Constraint (Expr);
+ exit;
+ end if;
+ end loop;
+ end Check_Array_Match;
+ pragma Unreferenced (Check_Array_Match);
+
+ procedure Check_Constraints
+ (Instance: Block_Instance_Acc;
+ Value: Iir_Value_Literal_Acc;
+ Def: Iir;
+ Expr: Iir)
+ is
+ Base_Type : constant Iir := Get_Base_Type (Def);
+ High, Low: Iir_Value_Literal_Acc;
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition =>
+ Bound := Execute_Bounds (Instance, Def);
+ if Bound.Dir = Iir_To then
+ High := Bound.Right;
+ Low := Bound.Left;
+ else
+ High := Bound.Left;
+ Low := Bound.Right;
+ end if;
+ case Get_Info (Base_Type).Scalar_Mode is
+ when Iir_Value_I64 =>
+ if Value.I64 in Low.I64 .. High.I64 then
+ return;
+ end if;
+ when Iir_Value_E32 =>
+ if Value.E32 in Low.E32 .. High.E32 then
+ return;
+ end if;
+ when Iir_Value_F64 =>
+ if Value.F64 in Low.F64 .. High.F64 then
+ return;
+ end if;
+ when Iir_Value_B2 =>
+ if Value.B2 in Low.B2 .. High.B2 then
+ return;
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Array_Type_Definition =>
+ Check_Array_Constraints (Instance, Value, Def, Expr);
+ return;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El: Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Check_Constraints
+ (Instance,
+ Value.Val_Record.V (Get_Element_Position (El) + 1),
+ Get_Type (El),
+ Expr);
+ end loop;
+ end;
+ return;
+ when Iir_Kind_Integer_Type_Definition =>
+ return;
+ when Iir_Kind_Floating_Type_Definition =>
+ return;
+ when Iir_Kind_Physical_Type_Definition =>
+ return;
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ return;
+ when Iir_Kind_File_Type_Definition =>
+ return;
+ when others =>
+ Error_Kind ("check_constraints", Def);
+ end case;
+ Error_Msg_Constraint (Expr);
+ end Check_Constraints;
+
+ function Execute_Resolution_Function
+ (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Inter : Iir;
+ Instance : Block_Instance_Acc;
+ begin
+ -- Create a frame for this function.
+ Instance := Create_Subprogram_Instance (Block, Imp);
+
+ Inter := Get_Interface_Declaration_Chain (Imp);
+ Elaboration.Create_Object (Instance, Inter);
+ Instance.Objects (Get_Info (Inter).Slot) := Arr;
+
+ return Execute_Function_Body (Instance, Imp);
+ end Execute_Resolution_Function;
+
+ procedure Execute_Signal_Assignment
+ (Instance: Block_Instance_Acc;
+ Stmt: Iir_Signal_Assignment_Statement)
+ is
+ Wf : constant Iir_Waveform_Element := Get_Waveform_Chain (Stmt);
+ Nbr_We : constant Natural := Get_Chain_Length (Wf);
+
+ Transactions : Transaction_Type (Nbr_We);
+
+ We: Iir_Waveform_Element;
+ Res: Iir_Value_Literal_Acc;
+ Rdest: Iir_Value_Literal_Acc;
+ Targ_Type : Iir;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Expr_Pool);
+
+ Rdest := Execute_Name (Instance, Get_Target (Stmt), True);
+ Targ_Type := Get_Type (Get_Target (Stmt));
+
+ -- Disconnection statement.
+ if Wf = Null_Iir then
+ Disconnect_Signal (Rdest);
+ Release (Marker, Expr_Pool);
+ return;
+ end if;
+
+ Transactions.Stmt := Stmt;
+
+ -- LRM93 8.4.1
+ -- Evaluation of a waveform consists of the evaluation of each waveform
+ -- elements in the waveform.
+ We := Wf;
+ for I in Transactions.Els'Range loop
+ declare
+ Trans : Transaction_El_Type renames Transactions.Els (I);
+ begin
+ if Get_Time (We) /= Null_Iir then
+ Res := Execute_Expression (Instance, Get_Time (We));
+ -- LRM93 8.4.1
+ -- It is an error if the time expression in a waveform element
+ -- evaluates to a negative value.
+ if Res.I64 < 0 then
+ Error_Msg_Exec ("time value is negative", Get_Time (We));
+ end if;
+ Trans.After := Std_Time (Res.I64);
+ else
+ -- LRM93 8.4.1
+ -- If the after clause of a waveform element is not present,
+ -- then an implicit "after 0 ns" is assumed.
+ Trans.After := 0;
+ end if;
+
+ -- LRM93 8.4.1
+ -- It is an error if the sequence of new transactions is not in
+ -- ascending order with respect to time.
+ if I > 1
+ and then Trans.After <= Transactions.Els (I - 1).After
+ then
+ Error_Msg_Exec
+ ("sequence not in ascending order with respect to time", We);
+ end if;
+
+ if Get_Kind (Get_We_Value (We)) = Iir_Kind_Null_Literal then
+ -- null transaction.
+ Trans.Value := null;
+ else
+ -- LRM93 8.4.1
+ -- For the first form of waveform element, the value component
+ -- of the transaction is determined by the value expression in
+ -- the waveform element.
+ Trans.Value := Execute_Expression_With_Type
+ (Instance, Get_We_Value (We), Targ_Type);
+ end if;
+ end;
+ We := Get_Chain (We);
+ end loop;
+ pragma Assert (We = Null_Iir);
+
+ case Get_Delay_Mechanism (Stmt) is
+ when Iir_Transport_Delay =>
+ Transactions.Reject := 0;
+ when Iir_Inertial_Delay =>
+ -- LRM93 8.4
+ -- or, in the case that a pulse rejection limit is specified,
+ -- a pulse whose duration is shorter than that limit will not
+ -- be transmitted.
+ -- Every inertially delayed signal assignment has a pulse
+ -- rejection limit.
+ if Get_Reject_Time_Expression (Stmt) /= Null_Iir then
+ -- LRM93 8.4
+ -- If the delay mechanism specifies inertial delay, and if the
+ -- reserved word reject followed by a time expression is
+ -- present, then the time expression specifies the pulse
+ -- rejection limit.
+ Res := Execute_Expression
+ (Instance, Get_Reject_Time_Expression (Stmt));
+ -- LRM93 8.4
+ -- It is an error if the pulse rejection limit for any
+ -- inertially delayed signal assignement statement is either
+ -- negative ...
+ if Res.I64 < 0 then
+ Error_Msg_Exec ("reject time negative", Stmt);
+ end if;
+ -- LRM93 8.4
+ -- ... or greather than the time expression associated with
+ -- the first waveform element.
+ Transactions.Reject := Std_Time (Res.I64);
+ if Transactions.Reject > Transactions.Els (1).After then
+ Error_Msg_Exec
+ ("reject time greather than time expression", Stmt);
+ end if;
+ else
+ -- LRM93 8.4
+ -- In all other cases, the pulse rejection limit is the time
+ -- expression associated ith the first waveform element.
+ Transactions.Reject := Transactions.Els (1).After;
+ end if;
+ end case;
+
+ -- FIXME: slice Transactions to remove transactions after end of time.
+ Assign_Value_To_Signal (Instance, Rdest, Transactions);
+
+ Release (Marker, Expr_Pool);
+ end Execute_Signal_Assignment;
+
+ procedure Assign_Simple_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Dest: Iir_Value_Literal_Acc;
+ Dest_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ begin
+ if Dest.Kind /= Value.Kind then
+ raise Internal_Error; -- literal kind mismatch.
+ end if;
+
+ Check_Constraints (Instance, Value, Dest_Type, Stmt);
+
+ Store (Dest, Value);
+ end Assign_Simple_Value_To_Object;
+
+ procedure Assign_Array_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Depth: Natural;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ Element_Type: Iir;
+ begin
+ if Target.Val_Array.Len /= Value.Val_Array.Len then
+ -- Dimension mismatch.
+ raise Program_Error;
+ end if;
+ if Depth = Get_Nbr_Elements (Get_Index_List (Target_Type)) then
+ Element_Type := Get_Element_Subtype (Target_Type);
+ for I in Target.Val_Array.V'Range loop
+ Assign_Value_To_Object (Instance,
+ Target.Val_Array.V (I),
+ Element_Type,
+ Value.Val_Array.V (I),
+ Stmt);
+ end loop;
+ else
+ for I in Target.Val_Array.V'Range loop
+ Assign_Array_Value_To_Object (Instance,
+ Target.Val_Array.V (I),
+ Target_Type,
+ Depth + 1,
+ Value.Val_Array.V (I),
+ Stmt);
+ end loop;
+ end if;
+ end Assign_Array_Value_To_Object;
+
+ procedure Assign_Record_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ Element_Type: Iir;
+ List : Iir_List;
+ Element: Iir_Element_Declaration;
+ Pos : Iir_Index32;
+ begin
+ if Target.Val_Record.Len /= Value.Val_Record.Len then
+ -- Dimension mismatch.
+ raise Program_Error;
+ end if;
+ List := Get_Elements_Declaration_List (Target_Type);
+ for I in Natural loop
+ Element := Get_Nth_Element (List, I);
+ exit when Element = Null_Iir;
+ Element_Type := Get_Type (Element);
+ Pos := Get_Element_Position (Element);
+ Assign_Value_To_Object (Instance,
+ Target.Val_Record.V (1 + Pos),
+ Element_Type,
+ Value.Val_Record.V (1 + Pos),
+ Stmt);
+ end loop;
+ end Assign_Record_Value_To_Object;
+
+ procedure Assign_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ begin
+ case Target.Kind is
+ when Iir_Value_Array =>
+ Assign_Array_Value_To_Object
+ (Instance, Target, Target_Type, 1, Value, Stmt);
+ when Iir_Value_Record =>
+ Assign_Record_Value_To_Object
+ (Instance, Target, Target_Type, Value, Stmt);
+ when Iir_Value_Scalars
+ | Iir_Value_Access =>
+ Assign_Simple_Value_To_Object
+ (Instance, Target, Target_Type, Value, Stmt);
+ when Iir_Value_File
+ | Iir_Value_Signal
+ | Iir_Value_Protected
+ | Iir_Value_Range
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Assign_Value_To_Object;
+
+ -- Display a message when an assertion has failed.
+ -- REPORT is the value (string) to display, or null to use default message.
+ -- SEVERITY is the severity or null to use default (error).
+ -- STMT is used to display location.
+ procedure Execute_Failed_Assertion (Report : Iir_Value_Literal_Acc;
+ Severity : Natural;
+ Stmt: Iir) is
+ begin
+ -- LRM93 8.2
+ -- The error message consists of at least:
+
+ -- 4: name of the design unit containing the assertion.
+ Disp_Iir_Location (Stmt);
+
+ -- 1: an indication that this message is from an assertion.
+ Put (Standard_Error, "(assertion ");
+
+ -- 2: the value of the severity level.
+ case Severity is
+ when 0 =>
+ Put (Standard_Error, "note");
+ when 1 =>
+ Put (Standard_Error, "warning");
+ when 2 =>
+ Put (Standard_Error, "error");
+ when 3 =>
+ Put (Standard_Error, "failure");
+ when others =>
+ Error_Internal (Null_Iir, "execute_failed_assertion");
+ end case;
+ if Disp_Time_Before_Values then
+ Put (Standard_Error, " at ");
+ Grt.Astdio.Put_Time (Grt.Stdio.stderr, Current_Time);
+ end if;
+ Put (Standard_Error, "): ");
+
+ -- 3: the value of the message string.
+ if Report /= null then
+ for I in Report.Val_Array.V'Range loop
+ Put (Standard_Error, Character'Val (Report.Val_Array.V (I).E32));
+ end loop;
+ New_Line (Standard_Error);
+ else
+ -- The default value for the message string is:
+ -- "Assertion violation.".
+ -- Does the message string include quotes ?
+ Put_Line (Standard_Error, "Assertion violation.");
+ end if;
+
+ -- 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_Report_Statement
+ (Instance: Block_Instance_Acc; Stmt: Iir; Default_Severity : Natural)
+ is
+ Expr: Iir;
+ Report, Severity_Lit: Iir_Value_Literal_Acc;
+ Severity : Natural;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Expr_Pool);
+ Expr := Get_Report_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Report := Execute_Expression (Instance, Expr);
+ else
+ Report := null;
+ end if;
+ Expr := Get_Severity_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Severity_Lit := Execute_Expression (Instance, Expr);
+ Severity := Natural'Val (Severity_Lit.E32);
+ else
+ Severity := Default_Severity;
+ end if;
+ Execute_Failed_Assertion (Report, Severity, Stmt);
+ Release (Marker, Expr_Pool);
+ end Execute_Report_Statement;
+
+ function Is_In_Choice
+ (Instance: Block_Instance_Acc;
+ Choice: Iir;
+ Expr: Iir_Value_Literal_Acc)
+ return Boolean
+ is
+ Res : Boolean;
+ begin
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ return True;
+ when Iir_Kind_Choice_By_Expression =>
+ declare
+ Expr1: Iir_Value_Literal_Acc;
+ begin
+ Expr1 := Execute_Expression (Instance, Get_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_Expression (Choice));
+ Res := Is_In_Range (Expr, A_Range);
+ end;
+ return Res;
+ when others =>
+ Error_Kind ("is_in_choice", Choice);
+ end case;
+ end Is_In_Choice;
+
+ -- Return TRUE iff VAL is in the range defined by BOUNDS.
+ function Is_In_Range (Val : Iir_Value_Literal_Acc;
+ Bounds : Iir_Value_Literal_Acc)
+ return Boolean
+ is
+ Max, Min : Iir_Value_Literal_Acc;
+ begin
+ case Bounds.Dir is
+ when Iir_To =>
+ Min := Bounds.Left;
+ Max := Bounds.Right;
+ when Iir_Downto =>
+ Min := Bounds.Right;
+ Max := Bounds.Left;
+ end case;
+
+ case Val.Kind is
+ when Iir_Value_E32 =>
+ return Val.E32 >= Min.E32 and Val.E32 <= Max.E32;
+ when Iir_Value_B2 =>
+ return Val.B2 >= Min.B2 and Val.B2 <= Max.B2;
+ when Iir_Value_I64 =>
+ return Val.I64 >= Min.I64 and Val.I64 <= Max.I64;
+ when others =>
+ raise Internal_Error;
+ return False;
+ end case;
+ end Is_In_Range;
+
+ -- Increment or decrement VAL according to BOUNDS.DIR.
+ -- FIXME: use increment ?
+ procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc;
+ Bounds : Iir_Value_Literal_Acc)
+ is
+ begin
+ case Val.Kind is
+ when Iir_Value_E32 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ Val.E32 := Val.E32 + 1;
+ when Iir_Downto =>
+ Val.E32 := Val.E32 - 1;
+ end case;
+ when Iir_Value_B2 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ Val.B2 := True;
+ when Iir_Downto =>
+ Val.B2 := False;
+ end case;
+ when Iir_Value_I64 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ Val.I64 := Val.I64 + 1;
+ when Iir_Downto =>
+ Val.I64 := Val.I64 - 1;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Update_Loop_Index;
+
+ procedure Finalize_For_Loop_Statement (Instance : Block_Instance_Acc;
+ Stmt : Iir)
+ is
+ begin
+ Destroy_Iterator_Declaration (Instance, Get_Iterator_Scheme (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.Cur_Stmt;
+ Bounds : Iir_Value_Literal_Acc;
+ Iterator : Iir;
+ Index : Iir_Value_Literal_Acc;
+ Stmt_Chain : Iir;
+ Is_Nul : Boolean;
+ Marker : Mark_Type;
+ begin
+ Iterator := Get_Iterator_Scheme (Stmt);
+
+ -- Elaborate the iterator (and its type).
+ Elaborate_Declaration (Instance, Iterator);
+
+ -- Extract bounds.
+ Mark (Marker, Expr_Pool);
+ Bounds := Execute_Bounds (Instance, Get_Type (Iterator));
+ Index := Instance.Objects (Get_Info (Iterator).Slot);
+ Store (Index, Bounds.Left);
+ Is_Nul := Is_Nul_Range (Bounds);
+ Release (Marker, Expr_Pool);
+
+ if Is_Nul then
+ -- Loop is complete.
+ Finalize_For_Loop_Statement (Instance, Stmt);
+ Update_Next_Statement (Proc);
+ else
+ Stmt_Chain := Get_Sequential_Statement_Chain (Stmt);
+ if Stmt_Chain = Null_Iir then
+ -- Nothing to do for an empty loop.
+ Finalize_For_Loop_Statement (Instance, Stmt);
+ Update_Next_Statement (Proc);
+ else
+ Instance.Cur_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_Iterator_Scheme (Instance.Cur_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.Cur_Stmt);
+ return False;
+ else
+ -- Update the loop index.
+ Update_Loop_Index (Index, Bounds);
+
+ Release (Marker, Expr_Pool);
+
+ -- start the loop again.
+ Instance.Cur_Stmt :=
+ Get_Sequential_Statement_Chain (Instance.Cur_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.B2 = 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.Cur_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.Cur_Stmt));
+
+ if Cond then
+ -- start the loop again.
+ Instance.Cur_Stmt :=
+ Get_Sequential_Statement_Chain (Instance.Cur_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.Cur_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.Cur_Stmt;
+ Label : constant Iir := Get_Loop (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.Cur_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.Cur_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 (Assoc);
+ end if;
+
+ if Is_In_Choice (Instance, Assoc, Value) then
+ if Stmt_Chain = Null_Iir then
+ Update_Next_Statement (Proc);
+ else
+ Instance.Cur_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.Cur_Stmt;
+ Call : constant Iir := Get_Procedure_Call (Stmt);
+ Imp : constant Iir := Get_Implementation (Call);
+ Subprg_Instance : Block_Instance_Acc;
+ Assoc_Chain: Iir;
+ Subprg_Body : Iir;
+ begin
+ if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration then
+ Execute_Implicit_Procedure (Instance, Call);
+ Update_Next_Statement (Proc);
+ elsif Get_Foreign_Flag (Imp) then
+ Execute_Foreign_Procedure (Instance, Call);
+ Update_Next_Statement (Proc);
+ else
+ Mark (Instance.Marker, Instance_Pool.all);
+ Subprg_Instance := Create_Subprogram_Instance (Instance, Imp);
+ Adjust_Up_Link_For_Protected_Object
+ (Instance, Call, Subprg_Instance);
+ Assoc_Chain := Get_Parameter_Association_Chain (Call);
+ Execute_Association (Instance, Subprg_Instance, Assoc_Chain);
+
+ Current_Process.Instance := Subprg_Instance;
+ Subprg_Body := Get_Subprogram_Body (Imp);
+ Elaborate_Declarative_Part
+ (Subprg_Instance, Get_Declaration_Chain (Subprg_Body));
+
+ Init_Sequential_Statements (Proc, Subprg_Body);
+ end if;
+ end Execute_Call_Statement;
+
+ procedure Finish_Procedure_Frame (Proc : Process_State_Acc)
+ is
+ Old_Instance : constant Block_Instance_Acc := Proc.Instance;
+ begin
+ Execute_Back_Association (Old_Instance);
+ Proc.Instance := Old_Instance.Parent;
+ Execute_Subprogram_Call_Final (Old_Instance);
+ Release (Proc.Instance.Marker, Instance_Pool.all);
+ end Finish_Procedure_Frame;
+
+ procedure Execute_If_Statement
+ (Proc : Process_State_Acc; Stmt: Iir_Wait_Statement)
+ is
+ Clause: Iir;
+ Cond: Boolean;
+ begin
+ Clause := Stmt;
+ loop
+ Cond := Execute_Condition (Proc.Instance, Get_Condition (Clause));
+ if Cond then
+ Init_Sequential_Statements (Proc, Clause);
+ return;
+ end if;
+ Clause := Get_Else_Clause (Clause);
+ exit when Clause = Null_Iir;
+ end loop;
+ Update_Next_Statement (Proc);
+ end Execute_If_Statement;
+
+ procedure Execute_Variable_Assignment
+ (Proc : Process_State_Acc; Stmt : Iir)
+ is
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Target : constant Iir := Get_Target (Stmt);
+ Target_Type : constant Iir := Get_Type (Target);
+ Expr : constant Iir := Get_Expression (Stmt);
+ Expr_Type : constant Iir := Get_Type (Expr);
+ Target_Val: Iir_Value_Literal_Acc;
+ Res : Iir_Value_Literal_Acc;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Expr_Pool);
+ Target_Val := Execute_Expression (Instance, Target);
+
+ -- If the type of the target is not static and the value is
+ -- an aggregate, then the aggregate may be contrained by the
+ -- target.
+ if Get_Kind (Expr) = Iir_Kind_Aggregate
+ and then Get_Type_Staticness (Expr_Type) < Locally
+ and then Get_Kind (Expr_Type)
+ in Iir_Kinds_Array_Type_Definition
+ then
+ Res := Copy_Array_Bound (Target_Val);
+ Fill_Array_Aggregate (Instance, Expr, Res);
+ else
+ Res := Execute_Expression (Instance, Expr);
+ end if;
+ if Get_Kind (Target_Type) in Iir_Kinds_Array_Type_Definition then
+ -- Note: target_type may be dynamic (slice case), so
+ -- check_constraints is not called.
+ Implicit_Array_Conversion (Res, Target_Val, Stmt);
+ else
+ Check_Constraints (Instance, Res, Target_Type, Stmt);
+ end if;
+
+ -- Note: we need to unshare before copying to avoid
+ -- overwrites (in assignments like: v (1 to 4) := v (3 to 6)).
+ -- FIXME: improve that handling (detect overlaps before).
+ Store (Target_Val, Unshare (Res, Expr_Pool'Access));
+
+ Release (Marker, Expr_Pool);
+ end Execute_Variable_Assignment;
+
+ function Execute_Return_Statement (Proc : Process_State_Acc)
+ return Boolean
+ is
+ Res : Iir_Value_Literal_Acc;
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Stmt : constant Iir := Instance.Cur_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.Name) 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.Cur_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.Cur_Stmt := Null_Iir;
+ return;
+ when Iir_Kind_Process_Statement =>
+ -- Start again.
+ Instance.Cur_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.Cur_Stmt);
+ if Stmt /= Null_Iir then
+ Instance.Cur_Stmt := Stmt;
+ return;
+ end if;
+ Stmt := Get_Parent (Instance.Cur_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.Cur_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.Cur_Stmt);
+ if Stmt /= Null_Iir then
+ Instance.Cur_Stmt := Stmt;
+ return;
+ end if;
+ Finish_Sequential_Statements (Proc, Get_Parent (Instance.Cur_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.Cur_Stmt;
+
+ -- End of process or subprogram.
+ exit when Stmt = Null_Iir;
+
+ if Trace_Statements then
+ declare
+ Name : Name_Id;
+ Line : Natural;
+ Col : Natural;
+ begin
+ Files_Map.Location_To_Position
+ (Get_Location (Stmt), Name, Line, Col);
+ Put_Line ("Execute statement at "
+ & Name_Table.Image (Name)
+ & Natural'Image (Line));
+ end;
+ end if;
+
+ if Flag_Need_Debug then
+ Debug (Reason_Break);
+ end if;
+
+ -- execute statement STMT.
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Null_Statement =>
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_If_Statement =>
+ Execute_If_Statement (Proc, Stmt);
+
+ when Iir_Kind_Signal_Assignment_Statement =>
+ Execute_Signal_Assignment (Instance, Stmt);
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Assertion_Statement =>
+ declare
+ Res : Boolean;
+ begin
+ Res := Execute_Condition
+ (Instance, Get_Assertion_Condition (Stmt));
+ if not Res then
+ Execute_Report_Statement (Instance, Stmt, 2);
+ end if;
+ end;
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Report_Statement =>
+ Execute_Report_Statement (Instance, Stmt, 0);
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Variable_Assignment_Statement =>
+ Execute_Variable_Assignment (Proc, Stmt);
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Return_Statement =>
+ if Execute_Return_Statement (Proc) then
+ return;
+ end if;
+
+ when Iir_Kind_For_Loop_Statement =>
+ Execute_For_Loop_Statement (Proc);
+
+ when Iir_Kind_While_Loop_Statement =>
+ Execute_While_Loop_Statement (Proc);
+
+ when Iir_Kind_Case_Statement =>
+ Execute_Case_Statement (Proc);
+
+ when Iir_Kind_Wait_Statement =>
+ if Execute_Wait_Statement (Instance, Stmt) then
+ return;
+ end if;
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Procedure_Call_Statement =>
+ Execute_Call_Statement (Proc);
+
+ when Iir_Kind_Exit_Statement =>
+ Execute_Exit_Next_Statement (Proc, True);
+ when Iir_Kind_Next_Statement =>
+ Execute_Exit_Next_Statement (Proc, False);
+
+ when others =>
+ Error_Kind ("execute_sequential_statements", Stmt);
+ end case;
+ end loop;
+ end Execute_Sequential_Statements;
+end Execution;
diff --git a/simulate/execution.ads b/simulate/execution.ads
new file mode 100644
index 0000000..79afd9c
--- /dev/null
+++ b/simulate/execution.ads
@@ -0,0 +1,180 @@
+-- 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;
+
+ -- 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;
+
+ 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_For_Slot (Instance: Block_Instance_Acc; Decl: Iir)
+ return Block_Instance_Acc;
+
+ -- Store VALUE to TARGET.
+ -- Note: VALUE is not freed.
+ procedure Assign_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir);
+
+ -- 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;
+ Imp : Iir)
+ return Block_Instance_Acc;
+
+ function Execute_Function_Body (Instance : Block_Instance_Acc; Func : Iir)
+ return Iir_Value_Literal_Acc;
+
+end Execution;
diff --git a/simulate/file_operation.adb b/simulate/file_operation.adb
new file mode 100644
index 0000000..03b3469
--- /dev/null
+++ b/simulate/file_operation.adb
@@ -0,0 +1,336 @@
+-- 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.Types; use Grt.Types;
+with Grt_Interface; use Grt_Interface;
+
+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).E32);
+ 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.E32);
+ 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.E32);
+ R_Status : Ghdl_I32;
+ begin
+ File_Open (R_Status, File, Name, File_Mode, Is_Text, True);
+ Status.E32 := Ghdl_E32 (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.E32);
+ 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_B2 =>
+ Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.B2'Address), 1);
+ when Iir_Value_I64 =>
+ Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8);
+ 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).E32);
+ 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)).E32 :=
+ 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
+ Res : Ghdl_Untruncated_Text_Read_Result;
+ 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
+ (Res'Unrestricted_Access, File.File, Val'Unrestricted_Access);
+ for I in 1 .. Res.Len loop
+ Str.Val_Array.V (Iir_Index32 (I)).E32 :=
+ Character'Pos (Val_Str (Ghdl_Index_Type (I)));
+ end loop;
+ Length.I64 := Ghdl_I64 (Res.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_B2 =>
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.B2'Address), 1);
+ when Iir_Value_I64 =>
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8);
+ 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;
+end File_Operation;
diff --git a/simulate/file_operation.ads b/simulate/file_operation.ads
new file mode 100644
index 0000000..39cbbb4
--- /dev/null
+++ b/simulate/file_operation.ads
@@ -0,0 +1,79 @@
+-- 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 Elaboration; use Elaboration;
+with Grt.Files; use Grt.Files;
+
+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);
+
+ -- Test end of FILE is reached.
+ function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir)
+ return Boolean;
+end File_Operation;
diff --git a/simulate/grt_interface.adb b/simulate/grt_interface.adb
new file mode 100644
index 0000000..c4eab58
--- /dev/null
+++ b/simulate/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 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).E32);
+ end loop;
+ end Set_Std_String_From_Iir_Value;
+end Grt_Interface;
diff --git a/simulate/grt_interface.ads b/simulate/grt_interface.ads
new file mode 100644
index 0000000..1098024
--- /dev/null
+++ b/simulate/grt_interface.ads
@@ -0,0 +1,34 @@
+-- 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 Grt.Types; use Grt.Types;
+with Iir_Values; use Iir_Values;
+
+package Grt_Interface is
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (System.Address, Std_String_Basep);
+ function To_Std_String_Boundp is new Ada.Unchecked_Conversion
+ (System.Address, Std_String_Boundp);
+
+ 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/simulate/iir_values.adb b/simulate/iir_values.adb
new file mode 100644
index 0000000..397875f
--- /dev/null
+++ b/simulate/iir_values.adb
@@ -0,0 +1,1038 @@
+-- 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_B2 =>
+ return Left.B2 = Right.B2;
+ 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 =>
+ 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_B2 =>
+ if Left.B2 < Right.B2 then
+ return Less;
+ elsif Left.B2 = Right.B2 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 =>
+ raise Internal_Error;
+ end case;
+ end Compare_Value;
+
+ function Is_Nul_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_Nul_Range;
+
+ procedure Increment (Val : Iir_Value_Literal_Acc) is
+ begin
+ case Val.Kind is
+ when Iir_Value_B2 =>
+ if Val.B2 = False then
+ Val.B2 := True;
+ else
+ raise Constraint_Error;
+ end if;
+ 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 =>
+ 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_B2 =>
+ Dest.B2 := Src.B2;
+ 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
+ | Iir_Value_Range
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ 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
+ | Iir_Value_Range
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ if Src.Kind /= Dest.Kind then
+ raise Internal_Error;
+ end if;
+ when Iir_Value_B2
+ | Iir_Value_E32
+ | Iir_Value_I64
+ | Iir_Value_F64
+ | Iir_Value_Signal =>
+ return;
+ 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);
+
+ 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
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Global_Pool'Access,
+ (Kind => Iir_Value_Signal, Sig => Sig)));
+ 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_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_B2_Value (Val : Ghdl_B2) return Iir_Value_Literal_Acc
+ is
+ subtype B2_Value is Iir_Value_Literal (Iir_Value_B2);
+ function Alloc is new Alloc_On_Pool_Addr (B2_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool, (Kind => Iir_Value_B2, B2 => Val)));
+ end Create_B2_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 (Low.Kind) is
+ when Iir_Value_B2 =>
+ if High.B2 >= Low.B2 then
+ Len := Ghdl_B2'Pos (High.B2) - Ghdl_B2'Pos (Low.B2) + 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_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;
+ when Iir_Value_Array
+ | Iir_Value_Record
+ | Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Range
+ | Iir_Value_Signal
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ 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_E32 =>
+ return Create_E32_Value (Src.E32);
+ when Iir_Value_I64 =>
+ return Create_I64_Value (Src.I64);
+ when Iir_Value_F64 =>
+ return Create_F64_Value (Src.F64);
+ when Iir_Value_B2 =>
+ return Create_B2_Value (Src.B2);
+ 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
+ | 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 =>
+ raise Internal_Error;
+ end case;
+ end Get_Nbr_Of_Scalars;
+
+ 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_B2 =>
+ Put_Line ("b2:" & Ghdl_B2'Image (Value.B2));
+ 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");
+ 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 =>
+ 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: Natural)
+ is
+ use Ada.Text_IO;
+ type Last_Enum_Type is (None, Char, Identifier);
+ Last_Enum: Last_Enum_Type;
+ Index_List: Iir_List;
+ El_Type: Iir;
+ Enum_List: Iir_List;
+ El: Name_Id;
+ begin
+ Index_List := Get_Index_Subtype_List (A_Type);
+ if Dim = Get_Nbr_Elements (Index_List) then
+ El_Type := Get_Base_Type (Get_Element_Subtype (A_Type));
+ 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 Value.Val_Array.V'Range loop
+ El := Get_Identifier
+ (Get_Nth_Element (Enum_List,
+ Ghdl_E32'Pos (Value.Val_Array.V (I).E32)));
+ if Name_Table.Is_Character (El) then
+ case Last_Enum is
+ when None =>
+ Put ("""");
+ when Identifier =>
+ Put (" & """);
+ when Char =>
+ null;
+ end case;
+ Put (Name_Table.Get_Character (El));
+ Last_Enum := Char;
+ else
+ case Last_Enum is
+ when None =>
+ null;
+ when Identifier =>
+ Put (" & ");
+ when Char =>
+ Put (""" & ");
+ end case;
+ Put (Name_Table.Image (El));
+ Last_Enum := Identifier;
+ end if;
+ end loop;
+ case Last_Enum is
+ when None =>
+ Put ("""");
+ when Identifier =>
+ null;
+ when Char =>
+ Put ("""");
+ end case;
+ return;
+ end if;
+ Put ("(");
+ for I in Value.Val_Array.V'Range loop
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Disp_Iir_Value (Value.Val_Array.V (I), El_Type);
+ end loop;
+ Put (")");
+ return;
+ else
+ Put ("(");
+ Disp_Iir_Value_Array (Value, A_Type, Dim + 1);
+ 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;
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Get_Base_Type (A_Type));
+ 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 (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
+ | Iir_Value_B2 =>
+ declare
+ Bt : constant Iir := Get_Base_Type (A_Type);
+ Id : Name_Id;
+ Pos : Integer;
+ begin
+ if Value.Kind = Iir_Value_E32 then
+ Pos := Ghdl_E32'Pos (Value.E32);
+ else
+ Pos := Ghdl_B2'Pos (Value.B2);
+ end if;
+ Id := Get_Identifier
+ (Get_Nth_Element (Get_Enumeration_Literal_List (Bt), Pos));
+ Put (Name_Table.Image (Id));
+ end;
+ when Iir_Value_Access =>
+ if Value.Val_Access = null then
+ Put ("null");
+ else
+ -- FIXME.
+ Put ("*acc*");
+ end if;
+ when Iir_Value_Array =>
+ Disp_Iir_Value_Array (Value, A_Type, 1);
+ 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 ("[quantity]");
+ when Iir_Value_Signal =>
+ Put ("[signal]");
+ when Iir_Value_Protected =>
+ Put ("[protected]");
+ end case;
+ end Disp_Iir_Value;
+end Iir_Values;
diff --git a/simulate/iir_values.ads b/simulate/iir_values.ads
new file mode 100644
index 0000000..7cbc892
--- /dev/null
+++ b/simulate/iir_values.ads
@@ -0,0 +1,352 @@
+-- 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 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_B2, 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);
+
+ type Protected_Index_Type is new Natural;
+
+ type Quantity_Index_Type is new Natural;
+ type Terminal_Index_Type is new Natural;
+
+ -- Scalar values. Only these ones can be signals.
+ subtype Iir_Value_Scalars is
+ Iir_Value_Kind range Iir_Value_B2 .. Iir_Value_F64;
+
+ 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;
+
+ type Iir_Value_Literal (Kind: Iir_Value_Kind) is record
+ case Kind is
+ when Iir_Value_B2 =>
+ B2 : Ghdl_B2;
+ 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;
+ 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_Range =>
+ Dir: Iir_Direction;
+ Length : Iir_Index32;
+ Left: Iir_Value_Literal_Acc;
+ Right: Iir_Value_Literal_Acc;
+ end case;
+ end record;
+
+ -- What is chosen for time.
+ -- Currently only int32 is available, but time should use an int64.
+ 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_B2_Value (Val : Ghdl_B2) 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 nul range.
+ function Is_Nul_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;
+
+ -- 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_B2,
+ B2 => False);
+ Lit_Enum_1 : constant Iir_Value_Literal_Acc :=
+ new Iir_Value_Literal'(Kind => Iir_Value_B2,
+ B2 => 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/simulate/sim_be.adb b/simulate/sim_be.adb
new file mode 100644
index 0000000..6474831
--- /dev/null
+++ b/simulate/sim_be.adb
@@ -0,0 +1,117 @@
+-- Interpreter back-end
+-- 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 Sem;
+with Canon;
+with Annotations;
+with Disp_Tree;
+with Errorout; use Errorout;
+with Flags;
+with Disp_Vhdl;
+with Post_Sems;
+
+package body Sim_Be is
+ procedure Finish_Compilation (Unit: Iir_Design_Unit; Main: Boolean := False)
+ is
+ use Ada.Text_IO;
+ Lib_Unit : Iir;
+ begin
+ Lib_Unit := Get_Library_Unit (Unit);
+ -- Semantic analysis.
+ if Flags.Verbose then
+ Put_Line ("semantize " & Disp_Node (Lib_Unit));
+ end if;
+ Sem.Semantic (Unit);
+
+ if (Main or Flags.Dump_All) and then Flags.Dump_Sem then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Sem then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+
+ -- Post checks
+ ----------------
+
+ Post_Sems.Post_Sem_Checks (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+
+ -- Canonicalisation.
+ ------------------
+ if Flags.Verbose then
+ Put_Line ("canonicalize " & Disp_Node (Lib_Unit));
+ end if;
+
+ Canon.Canonicalize (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Canon then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+
+ if Flags.Flag_Elaborate then
+ if Get_Kind (Lib_Unit) = Iir_Kind_Architecture_Declaration then
+ declare
+ Config : Iir_Design_Unit;
+ begin
+ Config := Canon.Create_Default_Configuration_Declaration
+ (Lib_Unit);
+ Set_Default_Configuration_Declaration (Lib_Unit, Config);
+ if (Main or Flags.Dump_All) and then Flags.Dump_Canon then
+ Disp_Tree.Disp_Tree (Config);
+ end if;
+ if (Main or Flags.List_All) and then Flags.List_Canon then
+ Disp_Vhdl.Disp_Vhdl (Config);
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Annotation.
+ -------------
+ if Flags.Verbose then
+ Put_Line ("annotate " & Disp_Node (Lib_Unit));
+ end if;
+
+ Annotations.Annotate (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Annotate then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+ if (Main or Flags.Dump_All) and then Flags.Dump_Annotate then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+ end Finish_Compilation;
+end Sim_Be;
diff --git a/simulate/sim_be.ads b/simulate/sim_be.ads
new file mode 100644
index 0000000..9256c4b
--- /dev/null
+++ b/simulate/sim_be.ads
@@ -0,0 +1,25 @@
+-- Interpreter back-end
+-- 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;
+
+package Sim_Be is
+ procedure Finish_Compilation
+ (Unit: Iir_Design_Unit; Main: Boolean := False);
+end Sim_Be;
+
diff --git a/simulate/simulation-ams-debugger.adb b/simulate/simulation-ams-debugger.adb
new file mode 100644
index 0000000..9cdbc75
--- /dev/null
+++ b/simulate/simulation-ams-debugger.adb
@@ -0,0 +1,87 @@
+-- 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 Debugger; use Debugger;
+with Iirs_Utils; use Iirs_Utils;
+with Ada.Text_IO; use Ada.Text_IO;
+with Disp_Vhdl;
+
+package body Simulation.AMS.Debugger 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 Simulation.AMS.Debugger;
+
diff --git a/simulate/simulation-ams-debugger.ads b/simulate/simulation-ams-debugger.ads
new file mode 100644
index 0000000..0cfcded
--- /dev/null
+++ b/simulate/simulation-ams-debugger.ads
@@ -0,0 +1,27 @@
+-- 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.
+
+package Simulation.AMS.Debugger is
+ procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type);
+
+ procedure Disp_Characteristic_Expression
+ (Ce : Characteristic_Expressions_Index);
+
+ procedure Disp_Characteristic_Expressions;
+end Simulation.AMS.Debugger;
+
diff --git a/simulate/simulation-ams.adb b/simulate/simulation-ams.adb
new file mode 100644
index 0000000..31dd43e
--- /dev/null
+++ b/simulate/simulation-ams.adb
@@ -0,0 +1,201 @@
+-- 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;
+
+package body Simulation.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 GNAT.Table
+ (Table_Component_Type => Quantity_Index_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ 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 := 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 Simulation.AMS;
+
diff --git a/simulate/simulation-ams.ads b/simulate/simulation-ams.ads
new file mode 100644
index 0000000..8ca5136
--- /dev/null
+++ b/simulate/simulation-ams.ads
@@ -0,0 +1,165 @@
+-- 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 GNAT.Table;
+
+package Simulation.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 (<>) is private;
+ 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;
+private
+ 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 Gnat.Table
+ (Table_Index_Type => Characteristic_Expressions_Index,
+ Table_Component_Type => Characteristic_Expr,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ 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 Gnat.Table
+ (Table_Index_Type => Quantity_Index_Type,
+ Table_Component_Type => Scalar_Quantity,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+end Simulation.AMS;
diff --git a/simulate/simulation.adb b/simulate/simulation.adb
new file mode 100644
index 0000000..446d68a
--- /dev/null
+++ b/simulate/simulation.adb
@@ -0,0 +1,1704 @@
+-- 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 Errorout; use Errorout;
+with Trans_Analyzes;
+with Types; use Types;
+with Debugger; use Debugger;
+with Simulation.AMS.Debugger;
+with Areapools; use Areapools;
+with Grt.Stacks;
+with Grt.Signals;
+with Grt.Processes;
+with Grt.Main;
+with Grt.Errors;
+with Grt.Rtis;
+
+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_B2 =>
+ return Create_B2_Value (Val.B2);
+ 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 Src.Kind is
+ when Iir_Value_B2 =>
+ Dst.B2 := Src.B2;
+ when Iir_Value_E32 =>
+ Dst.E32 := Src.E32;
+ when Iir_Value_I64 =>
+ Dst.I64 := Src.I64;
+ when Iir_Value_F64 =>
+ Dst.F64 := Src.F64;
+ when others =>
+ raise Internal_Error; -- FIXME
+ 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;
+
+ type Read_Signal_Value_Enum is
+ (Read_Signal_Last_Value,
+ Read_Signal_Driving_Value,
+ Read_Signal_Effective_Value);
+
+ 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_Driving_Value =>
+ return Value_To_Iir_Value
+ (Sig.Sig.Mode, Sig.Sig.Driving_Value);
+ when Read_Signal_Effective_Value =>
+ return Value_To_Iir_Value
+ (Sig.Sig.Mode, Sig.Sig.Value);
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Execute_Read_Signal_Value;
+
+ 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) 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);
+ 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_Driving_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_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);
+ 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_B2 =>
+ Ghdl_Signal_Start_Assign_B2
+ (Target.Sig, Transactions.Reject, El.Value.B2, 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_B2 =>
+ Ghdl_Signal_Next_Assign_B2
+ (Target.Sig, El.Value.B2, 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 =>
+ 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;
+ 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));
+ 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);
+ if List /= Null_Iir_List then
+ for J in Natural loop
+ El := Get_Nth_Element (List, J);
+ exit when El = Null_Iir;
+ Wait_Add_Sensitivity (Execute_Name (Instance, El, True));
+ end loop;
+ end if;
+
+ -- LRM93 8.1
+ -- It also causes the execution of the corresponding process
+ -- statement to be suspended.
+ Grt.Processes.Ghdl_Process_Wait_Wait;
+ 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_Has_Timeout 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_Wait;
+ 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;
+
+ function To_Instance_Acc is new Ada.Unchecked_Conversion
+ (System.Address, Grt.Stacks.Instance_Acc);
+
+ procedure Process_Executer (Self : Grt.Stacks.Instance_Acc);
+ pragma Convention (C, Process_Executer);
+
+ procedure Process_Executer (Self : Grt.Stacks.Instance_Acc)
+ is
+ function To_Process_State_Acc is new Ada.Unchecked_Conversion
+ (Grt.Stacks.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.Cur_Stmt = Null_Iir then
+ Process.Instance.Cur_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 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_First_Element (Get_Index_Subtype_List (Arr_Type)),
+ 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;
+
+ 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;
+
+ function Guard_Func (Data : System.Address) return Ghdl_B2
+ 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_B2'Val (Boolean'Pos (Val));
+ end Guard_Func;
+
+ -- 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;
+ 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).
+ if Driver_List = Null_Iir_List then
+ return;
+ end if;
+
+ for I in Natural loop
+ El := Get_Nth_Element (Driver_List, I);
+ exit when El = Null_Iir;
+ 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);
+ 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 Create_Processes
+ is
+ use Grt.Processes;
+ El : Iir;
+ Instance : Block_Instance_Acc;
+ Instance_Grt : Grt.Stacks.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.Name;
+
+ Instance_Pool := Processes_State (I).Pool'Access;
+ Instance.Cur_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.
+ declare
+ Sig_List : Iir_List;
+ Sig : Iir;
+ Marker : Mark_Type;
+ begin
+ Sig_List := Get_Sensitivity_List (El);
+ for J in Natural loop
+ Sig := Get_Nth_Element (Sig_List, J);
+ exit when Sig = Null_Iir;
+ Mark (Marker, Expr_Pool);
+ Process_Add_Sensitivity
+ (Execute_Name (Instance, Sig, True));
+ Release (Marker, Expr_Pool);
+ end loop;
+ end;
+
+ 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;
+
+ -- Configuration for the whole design
+ Top_Config : Iir_Design_Unit;
+
+ -- Elaborate the design
+ procedure Ghdl_Elaborate;
+ pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE");
+
+ 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;
+
+ 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 =>
+ case Port.Kind is
+ when 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_Access
+ | Iir_Value_File
+ | Iir_Value_Range
+ | Iir_Value_Scalars -- FIXME: by value
+ | Iir_Value_Record
+ | Iir_Value_Array
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ -- These cannot be driving value for a signal.
+ raise Internal_Error;
+ 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_B2 =>
+ if Mode = Connect_Source then
+ raise Internal_Error;
+ end if;
+ Grt.Signals.Ghdl_Signal_Associate_B2 (Port.Sig, Sig.B2);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Connect;
+
+ 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;
+
+ function Create_Shadow_Signal (Sig : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Signal =>
+ case Sig.Sig.Mode is
+ when Mode_I64 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_I64
+ (0, null, System.Null_Address));
+ when Mode_B2 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_B2
+ (False, null, System.Null_Address));
+ when Mode_E32 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_E32
+ (0, null, System.Null_Address));
+ when Mode_F64 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_F64
+ (0.0, null, System.Null_Address));
+ when Mode_E8
+ | 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 =>
+ raise Internal_Error;
+ end case;
+ end Create_Shadow_Signal;
+
+ 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;
+ Assoc : Iir_Association_Element_By_Expression)
+ is
+ pragma Unreferenced (Formal_Instance);
+ Formal : constant Iir := Get_Formal (Assoc);
+ Inter : constant Iir := Get_Base_Name (Formal);
+ 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_Out_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_In_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.Assoc);
+ end;
+ end loop;
+
+ Instance_Pool := null;
+ end Create_Connects;
+
+ procedure Create_Guard_Signal
+ (Instance : Block_Instance_Acc;
+ Sig_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 : Iir;
+ Data : Guard_Instance_Acc;
+ begin
+ Data := new Guard_Instance_Type'(Instance => Instance,
+ Guard => Guard);
+ Sig_Guard.Sig := Grt.Signals.Ghdl_Signal_Create_Guard
+ (Data.all'Address, Guard_Func'Access);
+ Dep_List := Get_Guard_Sensitivity_List (Guard);
+ for I in Natural loop
+ Dep := Get_Nth_Element (Dep_List, I);
+ exit when Dep = Null_Iir;
+ Add_Guard_Sensitivity (Execute_Name (Instance, Dep, True));
+ end loop;
+
+ -- FIXME: free mem
+ end Create_Guard_Signal;
+
+ procedure Create_Implicit_Signal (Sig : Iir_Value_Literal_Acc;
+ Time : Ghdl_I64;
+ Prefix : Iir_Value_Literal_Acc;
+ Kind : Signal_Type_Kind)
+ 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 Implicit_Stable =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Stable_Signal (Std_Time (Time));
+ when Implicit_Quiet =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Quiet_Signal (Std_Time (Time));
+ when Implicit_Transaction =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Transaction_Signal;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Register_Prefix (Prefix);
+ end Create_Implicit_Signal;
+
+ procedure Create_Delayed_Signal
+ (Sig : Iir_Value_Literal_Acc; Pfx : Iir_Value_Literal_Acc; Val : Std_Time)
+ is
+ 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), Pfx.Val_Array.V (I), Val);
+ end loop;
+ when Iir_Value_Record =>
+ for I in Pfx.Val_Record.V'Range loop
+ Create_Delayed_Signal
+ (Sig.Val_Record.V (I), Pfx.Val_Array.V (I), Val);
+ end loop;
+ when Iir_Value_Signal =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Delayed_Signal (Pfx.Sig, Val);
+ 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;
+ Signal: Iir;
+ Sig : Iir_Value_Literal_Acc;
+ Default : Iir_Value_Literal_Acc)
+ is
+ use Grt.Rtis;
+
+ procedure Create_Signal (Lit: 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_Function (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 (Lit)));
+ end if;
+ case Lit.Kind is
+ when Iir_Value_Array =>
+ declare
+ Sig_El_Type : constant Iir :=
+ Get_Element_Subtype (Get_Base_Type (Sig_Type));
+ begin
+ for I in Lit.Val_Array.V'Range loop
+ Create_Signal (Lit.Val_Array.V (I), Sig.Val_Array.V (I),
+ Sig_El_Type, Sub_Resolved);
+ end loop;
+ end;
+ when Iir_Value_Record =>
+ declare
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List
+ (Get_Base_Type (Sig_Type));
+ for I in Lit.Val_Record.V'Range loop
+ El := Get_Nth_Element (List, Natural (I - 1));
+ Create_Signal (Lit.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
+ (Lit.I64, null, System.Null_Address);
+ when Iir_Value_B2 =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Signal_B2
+ (Lit.B2, null, System.Null_Address);
+ when Iir_Value_E32 =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Signal_E32
+ (Lit.E32, null, System.Null_Address);
+ when Iir_Value_F64 =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Signal_F64
+ (Lit.F64, 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 =>
+ raise Internal_Error;
+ end case;
+ end Create_Signal;
+
+ Sig_Type: constant Iir := Get_Type (Signal);
+ Mode : Mode_Signal_Type;
+ Kind : Kind_Signal_Type;
+
+ type Iir_Mode_To_Mode_Signal_Type is
+ array (Iir_Mode) of Mode_Signal_Type;
+ Iir_Mode_To_Mode_Signal : constant Iir_Mode_To_Mode_Signal_Type :=
+ (Iir_Unknown_Mode => Mode_Signal,
+ Iir_Linkage_Mode => Mode_Linkage,
+ Iir_Buffer_Mode => Mode_Buffer,
+ Iir_Out_Mode => Mode_Out,
+ Iir_Inout_Mode => Mode_Inout,
+ Iir_In_Mode => Mode_In);
+
+ 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_No_Signal_Kind => Kind_Signal_No,
+ Iir_Register_Kind => Kind_Signal_Register,
+ Iir_Bus_Kind => Kind_Signal_Bus);
+ begin
+ case Get_Kind (Signal) is
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Mode := Iir_Mode_To_Mode_Signal (Get_Mode (Signal));
+ when Iir_Kind_Signal_Declaration =>
+ Mode := Mode_Signal;
+ when others =>
+ Error_Kind ("elaborate_signal", Signal);
+ end case;
+
+ Kind := Iir_Kind_To_Kind_Signal (Get_Signal_Kind (Signal));
+
+ Grt.Signals.Ghdl_Signal_Set_Mode (Mode, Kind, True);
+
+ Create_Signal (Default, 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 Guard_Signal =>
+ Create_Guard_Signal (E.Instance, E.Sig, E.Decl);
+ when Implicit_Stable | Implicit_Quiet | Implicit_Transaction =>
+ Create_Implicit_Signal (E.Sig, E.Time, E.Prefix, E.Kind);
+ when Implicit_Delayed =>
+ Create_Delayed_Signal (E.Sig, E.Prefix, Std_Time (E.Time));
+ when User_Signal =>
+ Create_User_Signal (E.Instance, E.Decl, E.Sig, E.Init);
+ end case;
+ end;
+ end loop;
+ end Create_Signals;
+
+ procedure Disp_Design_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).Name;
+ 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)");
+
+ Put (Integer'Image (Signals_Table.Last));
+ Put_Line (" signals");
+
+ Put (Integer'Image (Connect_Table.Last));
+ Put_Line (" connections");
+ end Disp_Design_Stats;
+
+ procedure Ghdl_Elaborate
+ is
+ Entity: Iir_Entity_Declaration;
+
+ -- Number of input ports of the top entity.
+ In_Signals: Natural;
+ El : Iir;
+ begin
+ Instance_Pool := Global_Pool'Access;
+
+ Elaboration.Elaborate_Design (Top_Config);
+ Entity := Get_Library_Unit
+ (Get_Entity (Get_Library_Unit (Top_Config)));
+
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+
+ Instance_Pool := null;
+
+ -- Be sure there is no IN ports in the top entity.
+ El := Get_Port_Chain (Entity);
+ In_Signals := 0;
+ while El /= Null_Iir loop
+ if Get_Mode (El) = Iir_In_Mode then
+ In_Signals := In_Signals + 1;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+
+ if In_Signals /= 0 then
+ Error_Msg ("top entity should not have inputs signals");
+ -- raise Simulation_Error;
+ end if;
+
+ if Disp_Stats then
+ Disp_Design_Stats;
+ end if;
+
+ if Disp_Ams then
+ Simulation.AMS.Debugger.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;
+
+ 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.Processes.One_Stack := True;
+
+ Grt.Errors.Error_Hook := Debug_Error'Access;
+
+ if Flag_Interractive then
+ Debug (Reason_Start);
+ end if;
+
+ Grt.Main.Run;
+ exception
+ when Debugger_Quit =>
+ null;
+ end Simulation_Entity;
+
+end Simulation;
diff --git a/simulate/simulation.ads b/simulate/simulation.ads
new file mode 100644
index 0000000..2ed5b9a
--- /dev/null
+++ b/simulate/simulation.ads
@@ -0,0 +1,128 @@
+-- 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;
+with Elaboration; use Elaboration;
+with Execution; use Execution;
+
+package Simulation is
+ Trace_Simulation : Boolean := False;
+ Disp_Tree : Boolean := False;
+ Disp_Stats : Boolean := False;
+ Disp_Ams : Boolean := False;
+ Flag_Debugger : Boolean := False;
+ Flag_Interractive : 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_B2;
+ pragma Convention (C, Guard_Func);
+
+ -- The entry point of the simulator.
+ procedure Simulation_Entity (Top_Conf : Iir_Design_Unit);
+
+ 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;
+
+ 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;
+end Simulation;
generated by cgit (git 2.34.1) at 2024-12-21 04:11:23 +0000