diff options
Diffstat (limited to 'src/vhdl')
33 files changed, 48309 insertions, 0 deletions
diff --git a/src/vhdl/simulate/annotations.adb b/src/vhdl/simulate/annotations.adb new file mode 100644 index 000000000..d07a99818 --- /dev/null +++ b/src/vhdl/simulate/annotations.adb @@ -0,0 +1,1236 @@ +-- 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); + 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; + 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 => + 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_B1)); + 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 => + declare + List : constant Iir_List := Get_Index_Subtype_List (Def); + begin + for I in Natural loop + El := Get_Index_Type (List, I); + exit when El = Null_Iir; + Annotate_Anonymous_Type_Definition (Block_Info, El); + end loop; + end; + + when Iir_Kind_Record_Type_Definition => + declare + List : constant Iir_List := Get_Elements_Declaration_List (Def); + begin + 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; + end; + + when Iir_Kind_Record_Subtype_Definition => + null; + + when Iir_Kind_Access_Type_Definition => + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Designated_Type (Def)); + + when Iir_Kind_Access_Subtype_Definition => + null; + + when Iir_Kind_File_Type_Definition => + declare + Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); + Res : String_Acc; + begin + if Get_Text_File_Flag (Def) + or else + Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_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 : Object_Slot_Type; + 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); + 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_Instance_Slot, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 1); -- For the instance. + 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_Anonymous_Type_Declaration => + Annotate_Type_Definition (Block_Info, Get_Type_Definition (Decl)); + when Iir_Kind_Subtype_Declaration => + Annotate_Type_Definition (Block_Info, Get_Type (Decl)); + + when Iir_Kind_Protected_Type_Body => + Annotate_Protected_Type_Body (Block_Info, Decl); + + when Iir_Kind_Component_Declaration => + Annotate_Component_Declaration (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if not Is_Second_Subprogram_Specification (Decl) then + Annotate_Subprogram_Interfaces_Type (Block_Info, Decl); + Annotate_Subprogram_Specification (Block_Info, Decl); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Annotate_Subprogram_Body (Block_Info, Decl); + + when Iir_Kind_Object_Alias_Declaration => + Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); + Create_Object_Info (Block_Info, Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Attribute_Specification => + declare + Value : Iir_Attribute_Value; + begin + Value := Get_Attribute_Value_Spec_Chain (Decl); + while Value /= Null_Iir loop + 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 : Object_Slot_Type; + Current_Nbr_Objects : Object_Slot_Type; + + procedure Save_Nbr_Objects is + begin + -- Objects used by loop statements can be reused later by + -- other (ie following) loop statements. + -- Furthermore, this allow to correctly check elaboration + -- order. + Max_Nbr_Objects := Object_Slot_Type'Max + (Block_Info.Nbr_Objects, Max_Nbr_Objects); + Block_Info.Nbr_Objects := Current_Nbr_Objects; + end Save_Nbr_Objects; + begin + Current_Nbr_Objects := Block_Info.Nbr_Objects; + Max_Nbr_Objects := Current_Nbr_Objects; + + El := Stmt_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Null_Statement => + null; + when Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement => + null; + when Iir_Kind_Return_Statement => + null; + when Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Variable_Assignment_Statement => + null; + when Iir_Kind_Procedure_Call_Statement => + null; + when Iir_Kind_Exit_Statement + | Iir_Kind_Next_Statement => + null; + when Iir_Kind_Wait_Statement => + null; + + when Iir_Kind_If_Statement => + declare + Clause: Iir := El; + begin + loop + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (Clause)); + Clause := Get_Else_Clause (Clause); + exit when Clause = Null_Iir; + Save_Nbr_Objects; + end loop; + end; + + when Iir_Kind_Case_Statement => + declare + Assoc: Iir; + begin + Assoc := Get_Case_Statement_Alternative_Chain (El); + loop + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Associated_Chain (Assoc)); + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + Save_Nbr_Objects; + end loop; + end; + + when Iir_Kind_For_Loop_Statement => + Annotate_Declaration + (Block_Info, Get_Parameter_Specification (El)); + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (El)); + + when Iir_Kind_While_Loop_Statement => + Annotate_Sequential_Statement_Chain + (Block_Info, Get_Sequential_Statement_Chain (El)); + + when others => + Error_Kind ("annotate_sequential_statement_chain", El); + end case; + + Save_Nbr_Objects; + + El := Get_Chain (El); + end loop; + Block_Info.Nbr_Objects := Max_Nbr_Objects; + end Annotate_Sequential_Statement_Chain; + + procedure Annotate_Block_Statement + (Block_Info : Sim_Info_Acc; Block : Iir_Block_Statement) + is + Info : Sim_Info_Acc; + Header : Iir_Block_Header; + Guard : Iir; + 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); + 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); + 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); + 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 + pragma Unreferenced (Block_Info); + 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 => Invalid_Instance_Slot, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + Set_Info (Stmt, Info); + + Annotate_Declaration_List + (Info, Get_Declaration_Chain (Stmt)); + Annotate_Sequential_Statement_Chain + (Info, Get_Sequential_Statement_Chain (Stmt)); + + Current_Scope_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_Instance_Slot, + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + 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_Body) + 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. + 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 => Instance_Slot_Type (Nbr_Packages), + Frame_Scope_Level => Current_Scope_Level, + Nbr_Objects => 0, + Nbr_Instances => 0); + + 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_Instance_Slot, + Frame_Scope_Level => Scope_Level_Global, + Nbr_Objects => 0, + Nbr_Instances => 0); + + 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); + + procedure Annotate_Expand_Table + is + El: Iir; + begin + Info_Node.Increment_Last; + El := Info_Node.Last; + Info_Node.Set_Last (Get_Last_Node); + for I in El .. Info_Node.Last loop + Info_Node.Table (I) := null; + end loop; + end Annotate_Expand_Table; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Annotate (Tree: Iir_Design_Unit) + is + El: Iir; + begin + -- Expand info table. + Annotate_Expand_Table; + + 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_Body => + Annotate_Architecture (El); + when Iir_Kind_Package_Declaration => + Annotate_Package (El); + declare + use Std_Package; + begin + if El = Standard_Package then + -- These types are not in std.standard! + Annotate_Type_Definition + (Get_Info (El), Convertible_Integer_Type_Definition); + Annotate_Type_Definition + (Get_Info (El), Convertible_Real_Type_Definition); + end if; + end; + when Iir_Kind_Package_Body => + Annotate_Package_Body (El); + when Iir_Kind_Configuration_Declaration => + Annotate_Configuration_Declaration (El); + when 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:" & Object_Slot_Type'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:" & Object_Slot_Type'Image (Info.Nbr_Objects)); + + when Kind_Object | Kind_Signal | Kind_File + | Kind_Terminal | Kind_Quantity => + Put_Line ("-- slot:" & Object_Slot_Type'Image (Info.Slot) + & ", scope:" + & Scope_Level_Type'Image (Info.Scope_Level)); + when Kind_Scalar_Type + | Kind_File_Type => + null; + when Kind_Range => + Put ("${"); + Put (Object_Slot_Type'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:" + & Instance_Slot_Type'Image (Info.Inst_Slot)); + Set_Col (Indent); + Put_Line ("nbr objects:" + & Object_Slot_Type'Image (Info.Nbr_Objects)); + Set_Col (Indent); + Put_Line ("nbr instance:" + & Instance_Slot_Type'Image (Info.Nbr_Instances)); + when Kind_Object | Kind_Signal | Kind_File + | Kind_Terminal | Kind_Quantity => + Put_Line ("slot:" & Object_Slot_Type'Image (Info.Slot) + & ", scope:" + & Scope_Level_Type'Image (Info.Scope_Level)); + when Kind_Range => + Put_Line ("range slot:" & Object_Slot_Type'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/src/vhdl/simulate/annotations.ads b/src/vhdl/simulate/annotations.ads new file mode 100644 index 000000000..e9b48d005 --- /dev/null +++ b/src/vhdl/simulate/annotations.ads @@ -0,0 +1,120 @@ +-- Annotations for interpreted simulation +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs; use Iirs; +with 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; + + type Instance_Slot_Type is new Integer; + Invalid_Instance_Slot : constant Instance_Slot_Type := -1; + + type Object_Slot_Type is new Integer; + + -- 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 => + -- Slot number. + Inst_Slot : Instance_Slot_Type; + + -- scope level for this frame. + Frame_Scope_Level: Scope_Level_Type; + + -- Number of objects/signals. + Nbr_Objects : Object_Slot_Type; + + -- Number of children (blocks, generate, instantiation). + Nbr_Instances : Instance_Slot_Type; + + when Kind_Object + | Kind_Signal + | Kind_Range + | Kind_File + | Kind_Terminal + | Kind_Quantity => + -- block considered (hierarchy). + Scope_Level: Scope_Level_Type; + + -- Variable index. + Slot: Object_Slot_Type; + + 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; + + -- Get/Set annotation fied from/to an iir. + procedure Set_Info (Target: Iir; Info: Sim_Info_Acc); + pragma Inline (Set_Info); + function Get_Info (Target: Iir) return Sim_Info_Acc; + pragma Inline (Get_Info); + + -- Expand the annotation table. This is automatically done by Annotate, + -- to be used only by debugger. + procedure Annotate_Expand_Table; +end Annotations; diff --git a/src/vhdl/simulate/areapools.adb b/src/vhdl/simulate/areapools.adb new file mode 100644 index 000000000..341b14240 --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/areapools.ads b/src/vhdl/simulate/areapools.ads new file mode 100644 index 000000000..186f29707 --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/debugger.adb b/src/vhdl/simulate/debugger.adb new file mode 100644 index 000000000..5a43533d6 --- /dev/null +++ b/src/vhdl/simulate/debugger.adb @@ -0,0 +1,1845 @@ +-- 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 + Name : constant Iir := Instance.Label; + begin + if Name = Null_Iir then + return "<anon>"; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Procedure_Declaration + | Iir_Kinds_Process_Statement => + return Image_Identifier (Name); + when Iir_Kind_Iterator_Declaration => + return Image_Identifier (Get_Parent (Name)) & '(' + & Execute_Image_Attribute + (Instance.Objects (Get_Info (Name).Slot), Get_Type (Name)) + & ')'; + when Iir_Kind_Architecture_Body => + if Short then + return Image_Identifier (Get_Entity (Name)); + else + return Image_Identifier (Get_Entity (Name)) + & '(' & Image_Identifier (Name) & ')'; + end if; + when others => + Error_Kind ("disp_instance_local_name", Name); + end case; + end Get_Instance_Local_Name; + + -- Disp the name of an instance, without newline. + procedure Disp_Instance_Name (Instance: Block_Instance_Acc; + Short : Boolean := False) is + begin + if Instance.Parent /= null then + Disp_Instance_Name (Instance.Parent); + Put ('.'); + end if; + Put (Get_Instance_Local_Name (Instance, Short)); + end Disp_Instance_Name; + + function Get_Instance_Name (Instance: Block_Instance_Acc) return String + is + function Parent_Name return String is + begin + if Instance.Parent /= null then + return Get_Instance_Name (Instance.Parent) & '.'; + else + return ""; + end if; + end Parent_Name; + begin + return Parent_Name & Get_Instance_Local_Name (Instance); + end Get_Instance_Name; + + procedure Disp_Instances_Tree_Name (Inst : Block_Instance_Acc) is + begin + if Inst = null then + Put ("*null*"); + New_Line; + return; + end if; + Put (Get_Instance_Local_Name (Inst)); + + Put (" "); + case Get_Kind (Inst.Label) is + when Iir_Kind_Block_Statement => + Put ("[block]"); + when Iir_Kind_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_Body => + Put ("[entity]"); + when others => + Error_Kind ("disp_instances_tree1", Inst.Label); + end case; + New_Line; + end Disp_Instances_Tree_Name; + + procedure Disp_Instances_Tree1 (Inst : Block_Instance_Acc; Pfx : String) + is + Child : Block_Instance_Acc; + begin + Child := Inst.Children; + if Child = null then + return; + end if; + + loop + if Child.Brother /= null then + Put (Pfx & "+-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & "| "); + Child := Child.Brother; + else + Put (Pfx & "`-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & " "); + exit; + end if; + end loop; + end Disp_Instances_Tree1; + + procedure Disp_Instances_Tree is + begin + Disp_Instances_Tree_Name (Top_Instance); + Disp_Instances_Tree1 (Top_Instance, ""); + end Disp_Instances_Tree; + + -- Disp a block instance, in a human readable way. + -- Used to debug. + procedure Disp_Block_Instance (Instance: Block_Instance_Acc) is + begin + Put_Line ("scope level:" + & Scope_Level_Type'Image (Instance.Scope_Level)); + Put_Line ("Objects:"); + for I in Instance.Objects'Range loop + Put (Object_Slot_Type'Image (I) & ": "); + Disp_Value_Tab (Instance.Objects (I), 3); + New_Line; + end loop; + end Disp_Block_Instance; + + procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir); + + procedure Disp_Signal_Array (Value : Iir_Value_Literal_Acc; + A_Type : Iir; + Dim : Natural) + is + begin + if Dim = Get_Nbr_Elements (Get_Index_Subtype_List (A_Type)) then + Put ("("); + for I in Value.Val_Array.V'Range loop + if I /= 1 then + Put (", "); + end if; + Disp_Signal (Value.Val_Array.V (I), Get_Element_Subtype (A_Type)); + end loop; + Put (")"); + else + Put ("("); + Disp_Signal_Array (Value, A_Type, Dim + 1); + Put (")"); + end if; + end Disp_Signal_Array; + + procedure Disp_Signal_Record (Value : Iir_Value_Literal_Acc; A_Type : Iir) + is + 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_B1 + | Iir_Value_Access => + Disp_Iir_Value (Value, A_Type); + when Iir_Value_Array => + Disp_Signal_Array (Value, A_Type, 1); + when Iir_Value_Record => + Disp_Signal_Record (Value, A_Type); + when Iir_Value_Range => + -- FIXME. + raise Internal_Error; + when Iir_Value_Signal => + Grt.Disp_Signals.Disp_A_Signal (Value.Sig); + when Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Disp_Signal; + + procedure Disp_Instance_Signal (Instance: Block_Instance_Acc; Decl : Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Put (" "); + Put (Name_Table.Image (Get_Identifier (Decl))); + Put (" = "); + Disp_Signal (Instance.Objects (Info.Slot), Get_Type (Decl)); + end Disp_Instance_Signal; + + procedure Disp_Instance_Signals_Of_Chain (Instance: Block_Instance_Acc; + Chain : Iir) + is + El : Iir; + begin + El := Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration => + Disp_Instance_Signal (Instance, El); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Disp_Instance_Signals_Of_Chain; + + procedure Disp_Instance_Signals (Instance: Block_Instance_Acc) + is + Blk : constant Iir := Instance.Label; + Child: Block_Instance_Acc; + begin + case Get_Kind (Blk) is + when Iir_Kind_Architecture_Body => + declare + Ent : constant Iir := Get_Entity (Blk); + begin + Disp_Instance_Name (Instance); + Put_Line (" [architecture]:"); + + Disp_Instance_Signals_Of_Chain + (Instance, Get_Port_Chain (Ent)); + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Ent)); + end; + when Iir_Kind_Block_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [block]:"); + + -- FIXME: ports. + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + when Iir_Kind_Generate_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [generate]:"); + + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + when Iir_Kind_Component_Instantiation_Statement => + null; + when Iir_Kinds_Process_Statement => + null; + when Iir_Kind_Iterator_Declaration => + null; + when others => + Error_Kind ("disp_instance_signals", Instance.Label); + end case; + + Child := Instance.Children; + while Child /= null loop + Disp_Instance_Signals (Child); + Child := Child.Brother; + end loop; + end Disp_Instance_Signals; + + -- Disp all signals name and values. + procedure Disp_Signals_Value is + begin + if Disp_Time_Before_Values then + Grt.Disp.Disp_Now; + end if; + Disp_Instance_Signals (Top_Instance); + end Disp_Signals_Value; + + procedure Disp_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.Label; + begin + Disp_Instance_Name (Instance); + New_Line; + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + Disp_Declaration_Objects + (Instance, Get_Interface_Declaration_Chain (Decl)); + Disp_Declaration_Objects + (Instance, + Get_Declaration_Chain (Get_Subprogram_Body (Decl))); + when Iir_Kind_Architecture_Body => + declare + Entity : constant Iir_Entity_Declaration := Get_Entity (Decl); + begin + Disp_Declaration_Objects + (Instance, Get_Generic_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Port_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Decl)); + -- FIXME: processes. + end; + when Iir_Kind_Component_Instantiation_Statement => + null; + when others => + Error_Kind ("disp_objects", Decl); + end case; + end Disp_Objects; + pragma Unreferenced (Disp_Objects); + + procedure Disp_Process_Stats + is + Proc : Iir; + Stmt : Iir; + Nbr_User_Sensitized_Processes : Natural := 0; + Nbr_User_If_Sensitized_Processes : Natural := 0; + Nbr_Conc_Sensitized_Processes : Natural := 0; + Nbr_User_Non_Sensitized_Processes : Natural := 0; + Nbr_Conc_Non_Sensitized_Processes : Natural := 0; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Proc := Processes_Table.Table (I).Label; + case Get_Kind (Proc) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Stmt := Get_Sequential_Statement_Chain (Proc); + if Stmt /= Null_Iir + and then Get_Kind (Stmt) = Iir_Kind_If_Statement + and then Get_Chain (Stmt) = Null_Iir + then + Nbr_User_If_Sensitized_Processes := + Nbr_User_If_Sensitized_Processes + 1; + else + Nbr_User_Sensitized_Processes := + Nbr_User_Sensitized_Processes + 1; + end if; + else + Nbr_Conc_Sensitized_Processes := + Nbr_Conc_Sensitized_Processes + 1; + end if; + when Iir_Kind_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Nbr_User_Non_Sensitized_Processes := + Nbr_User_Non_Sensitized_Processes + 1; + else + Nbr_Conc_Non_Sensitized_Processes := + Nbr_Conc_Non_Sensitized_Processes + 1; + end if; + when others => + raise Internal_Error; + end case; + end loop; + + Put (Natural'Image (Nbr_User_If_Sensitized_Processes)); + Put_Line (" user sensitized processes with only a if stmt"); + Put (Natural'Image (Nbr_User_Sensitized_Processes)); + Put_Line (" user sensitized processes (others)"); + Put (Natural'Image (Nbr_User_Non_Sensitized_Processes)); + Put_Line (" user non sensitized processes"); + Put (Natural'Image (Nbr_Conc_Sensitized_Processes)); + Put_Line (" sensitized concurrent statements"); + Put (Natural'Image (Nbr_Conc_Non_Sensitized_Processes)); + Put_Line (" non sensitized concurrent statements"); + Put (Process_Index_Type'Image (Processes_Table.Last)); + Put_Line (" processes (total)"); + end Disp_Process_Stats; + + procedure Disp_Signals_Stats + is + type Counters_Type is array (Signal_Type_Kind) of Natural; + Counters : Counters_Type := (others => 0); + Nbr_Signal_Elements : Natural := 0; + begin + for I in Signals_Table.First .. Signals_Table.Last loop + declare + Ent : Signal_Entry renames Signals_Table.Table (I); + begin + if Ent.Kind = User_Signal then + Nbr_Signal_Elements := Nbr_Signal_Elements + + Get_Nbr_Of_Scalars (Signals_Table.Table (I).Sig); + end if; + Counters (Ent.Kind) := Counters (Ent.Kind) + 1; + end; + end loop; + Put (Integer'Image (Counters (User_Signal))); + Put_Line (" declared user signals or ports"); + Put (Integer'Image (Nbr_Signal_Elements)); + Put_Line (" user signals sub-elements"); + Put (Integer'Image (Counters (Implicit_Quiet))); + Put_Line (" 'quiet implicit signals"); + Put (Integer'Image (Counters (Implicit_Stable))); + Put_Line (" 'stable implicit signals"); + Put (Integer'Image (Counters (Implicit_Delayed))); + Put_Line (" 'delayed implicit signals"); + Put (Integer'Image (Counters (Implicit_Transaction))); + Put_Line (" 'transaction implicit signals"); + Put (Integer'Image (Counters (Guard_Signal))); + Put_Line (" guard signals"); + end Disp_Signals_Stats; + + procedure Disp_Design_Stats is + begin + Disp_Process_Stats; + + New_Line; + + Disp_Signals_Stats; + + New_Line; + + Put (Integer'Image (Connect_Table.Last)); + Put_Line (" connections"); + end Disp_Design_Stats; + + procedure Disp_Design_Non_Sensitized + is + Instance : Block_Instance_Acc; + Proc : Iir; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Instance := Processes_Table.Table (I); + Proc := Processes_Table.Table (I).Label; + if Get_Kind (Proc) = Iir_Kind_Process_Statement then + Disp_Instance_Name (Instance); + New_Line; + Put_Line (" at " & Disp_Location (Proc)); + end if; + end loop; + end Disp_Design_Non_Sensitized; + + procedure Disp_Design_Connections is + begin + for I in Connect_Table.First .. Connect_Table.Last loop + declare + Conn : Connect_Entry renames Connect_Table.Table (I); + begin + Disp_Iir_Location (Conn.Assoc); + New_Line; + end; + end loop; + end Disp_Design_Connections; + + function Walk_Files (Cb : Walk_Cb) return Walk_Status + is + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + File : Iir_Design_File; + begin + while Lib /= Null_Iir loop + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + case Cb.all (File) is + when Walk_Continue => + null; + when Walk_Up => + exit; + when Walk_Abort => + return Walk_Abort; + end case; + File := Get_Chain (File); + end loop; + Lib := Get_Chain (Lib); + end loop; + return Walk_Continue; + end Walk_Files; + + Walk_Units_Cb : Walk_Cb; + + function Cb_Walk_Units (Design_File : Iir) return Walk_Status + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is + when Walk_Continue => + null; + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + exit; + end case; + Unit := Get_Chain (Unit); + end loop; + return Walk_Continue; + end Cb_Walk_Units; + + function Walk_Units (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Units_Cb := Cb; + return Walk_Files (Cb_Walk_Units'Access); + end Walk_Units; + + Walk_Declarations_Cb : Walk_Cb; + + function Cb_Walk_Declarations (Unit : Iir) return Walk_Status + is + function Walk_Decl_Chain (Chain : Iir) return Walk_Status + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Walk_Declarations_Cb.all (Decl) is + when Walk_Abort => + return Walk_Abort; + when Walk_Up => + return Walk_Continue; + when Walk_Continue => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return Walk_Continue; + end Walk_Decl_Chain; + + function Walk_Conc_Chain (Chain : Iir) return Walk_Status + 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_Body => + if (Walk_Decl_Chain + (Get_Declaration_Chain (Unit)) = Walk_Abort) + or else (Walk_Conc_Chain + (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort) + then + return Walk_Abort; + end if; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + when Iir_Kind_Configuration_Declaration => + if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort + then + return Walk_Abort; + end if; + -- FIXME: block configuration ? + when others => + Error_Kind ("Cb_Walk_Declarations", Unit); + end case; + return Walk_Continue; + end Cb_Walk_Declarations; + + function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is + begin + Walk_Declarations_Cb := Cb; + return Walk_Units (Cb_Walk_Declarations'Access); + end Walk_Declarations; + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + function Skip_Blanks (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P; + end Skip_Blanks; + + -- Return the position of the last character of the word (the last + -- non-blank character). + function Get_Word (S : String) return Positive + is + P : Positive := S'First; + begin + while P <= S'Last and then not Is_Blank (S (P)) loop + P := P + 1; + end loop; + return P - 1; + end Get_Word; + + procedure Disp_A_Frame (Instance: Block_Instance_Acc) is + begin + Put (Disp_Node (Instance.Label)); + if Instance.Stmt /= Null_Iir then + Put (" at "); + Put (Get_Location_Str (Get_Location (Instance.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_Instances_Tree; + 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.Label; + if Decl = Null_Iir + or else Get_Kind (Decl) not in Iir_Kinds_Subprogram_Declaration + then + Put_Line ("current frame is not a subprogram"); + return; + end if; + Params := Get_Interface_Declaration_Chain (Decl); + Disp_Declaration_Objects (Dbg_Cur_Frame, Params); + end Info_Params_Proc; + + procedure Info_Proc_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Check_Current_Process; + Disp_Process_Loc (Current_Process.all); + end Info_Proc_Proc; + + function Cb_Disp_Subprograms (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Put_Line (Name_Table.Image (Get_Identifier (El))); + when others => + null; + end case; + return Walk_Continue; + end Cb_Disp_Subprograms; + + procedure Info_Subprograms_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Declarations (Cb_Disp_Subprograms'Access); + pragma Assert (Status = Walk_Continue); + end Info_Subprograms_Proc; + + function Cb_Disp_Units (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + Put ("package "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Entity_Declaration => + Put ("entity "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Architecture_Body => + Put ("architecture "); + Put (Name_Table.Image (Get_Identifier (El))); + Put (" of "); + Put_Line (Name_Table.Image (Get_Identifier (Get_Entity (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_Stats_Proc (Line : String) is + P : Natural := Line'First; + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + -- No parameters. + Disp_Design_Stats; + return; + end if; + + E := Get_Word (Line (P .. Line'Last)); + if Line (P .. E) = "global" then + Disp_Design_Stats; + elsif Line (P .. E) = "non-sensitized" then + Disp_Design_Non_Sensitized; + null; + elsif Line (P .. E) = "connections" then + Disp_Design_Connections; + -- TODO: nbr of conversions + else + Put_Line ("options are: global, non-sensitized, connections"); + -- TODO: signals: nbr of scalars, nbr of non-user... + end if; + end Info_Stats_Proc; + + procedure Info_Files_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Files (Cb_Disp_File'Access); + pragma Assert (Status = Walk_Continue); + end Info_Files_Proc; + + procedure Info_Libraries_Proc (Line : String) is + pragma Unreferenced (Line); + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + begin + while Lib /= Null_Iir loop + Put_Line (Name_Table.Image (Get_Identifier (Lib))); + Lib := Get_Chain (Lib); + end loop; + end Info_Libraries_Proc; + + procedure Disp_Declared_Signals_Chain + (Chain : Iir; Instance : Block_Instance_Acc) + is + pragma Unreferenced (Instance); + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_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_Body => + Disp_Declared_Signals (Get_Entity (Decl), Instance); + when Iir_Kind_Entity_Declaration => + null; + when others => + Error_Kind ("disp_declared_signals", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + -- No signal declaration in a process (FIXME: implicit signals) + null; + when Iir_Kind_Architecture_Body => + Put_Line ("Signals of architecture " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Declaration_Chain (Decl), Instance); + when Iir_Kind_Entity_Declaration => + Put_Line ("Ports of entity " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Port_Chain (Decl), Instance); + when others => + Error_Kind ("disp_declared_signals (2)", Decl); + end case; + end Disp_Declared_Signals; + + procedure Info_Signals_Proc (Line : String) is + pragma Unreferenced (Line); + begin + 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_Body => + 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 + | Iir_Kind_Case_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + + when Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_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_Body => + Open_Declarative_Region; + Add_Context_Clauses (Get_Design_Unit (N)); + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when Iir_Kind_Package_Body => + declare + Package_Decl : constant Iir := Get_Package (N); + Package_Unit : constant Iir := Get_Design_Unit (Package_Decl); + begin + Add_Name (Package_Unit); + Add_Context_Clauses (Package_Unit); + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (Package_Decl), False); + Add_Declarations (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + declare + Spec : constant Iir := Get_Subprogram_Specification (N); + begin + Open_Declarative_Region; + Add_Declarations + (Get_Interface_Declaration_Chain (Spec), False); + Add_Declarations + (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + when Iir_Kind_For_Loop_Statement => + Open_Declarative_Region; + Add_Name (Get_Parameter_Specification (N)); + when Iir_Kind_Block_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when Iir_Kind_Generate_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when others => + Error_Kind ("enter_scope(2)", N); + end case; + end Add_Decls_For; + + procedure Enter_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Push_Interpretations; + Open_Declarative_Region; + + -- Add STD + Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); + Use_All_Names (Std_Package.Standard_Package); + + Foreach_Scopes (Node, Add_Decls_For'Access); + end Enter_Scope; + + procedure Del_Decls_For (N : Iir) + is + use Sem_Scopes; + begin + case Get_Kind (N) is + when Iir_Kind_Entity_Declaration => + null; + when Iir_Kind_Architecture_Body => + Close_Declarative_Region; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Package_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Close_Declarative_Region; + when others => + Error_Kind ("Decl_Decls_For", N); + end case; + end Del_Decls_For; + + procedure Leave_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Foreach_Scopes (Node, Del_Decls_For'Access); + + Close_Declarative_Region; + Pop_Interpretations; + end Leave_Scope; + + Buffer_Index : Natural := 1; + + procedure Print_Proc (Line : String) + is + use Tokens; + Index_Str : String := Natural'Image (Buffer_Index); + File : Source_File_Entry; + Expr : Iir; + Res : Iir_Value_Literal_Acc; + P : Natural; + Opt_Value : Boolean := False; + 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.Stmt); + Expr := Sem_Expr.Sem_Expression_Universal (Expr); + Leave_Scope (Dbg_Cur_Frame.Stmt); + + if Expr = Null_Iir + or else Nbr_Errors /= 0 + then + Put_Line ("error while analyzing expression, evaluation aborted"); + Nbr_Errors := 0; + return; + end if; + + Disp_Vhdl.Disp_Expression (Expr); + New_Line; + + Annotate_Expand_Table; + + Mark (Marker, Expr_Pool); + + Res := Execute_Expression (Dbg_Cur_Frame, Expr); + if Opt_Value then + Disp_Value (Res); + else + Disp_Iir_Value (Res, Get_Type (Expr)); + end if; + New_Line; + + -- Free value + Release (Marker, Expr_Pool); + end Print_Proc; + + procedure Quit_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Command_Status := Status_Quit; + raise Debugger_Quit; + end Quit_Proc; + + procedure Cont_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Command_Status := Status_Quit; + + -- Set Flag_Need_Debug only if there is at least one enabled breakpoint. + Flag_Need_Debug := False; + for I in Breakpoints.First .. Breakpoints.Last loop + Flag_Need_Debug := True; + exit; + end loop; + end Cont_Proc; + + Menu_Info_Stats : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("stats"), + Next => null, + Proc => Info_Stats_Proc'Access); + + Menu_Info_Tree : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("tree"), + Next => Menu_Info_Stats'Access, + Proc => Info_Tree_Proc'Access); + + Menu_Info_Params : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("param*eters"), + Next => Menu_Info_Tree'Access, + Proc => Info_Params_Proc'Access); + + Menu_Info_Subprograms : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("subp*rograms"), + Next => Menu_Info_Params'Access, + Proc => Info_Subprograms_Proc'Access); + + Menu_Info_Units : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("units"), + Next => Menu_Info_Subprograms'Access, + Proc => Info_Units_Proc'Access); + + Menu_Info_Files : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("files"), + Next => Menu_Info_Units'Access, + Proc => Info_Files_Proc'Access); + + Menu_Info_Libraries : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("lib*raries"), + Next => Menu_Info_Files'Access, + Proc => Info_Libraries_Proc'Access); + + Menu_Info_Signals : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("sig*nals"), + Next => Menu_Info_Libraries'Access, + Proc => Info_Signals_Proc'Access); + + Menu_Info_Proc : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("proc*esses"), + Next => Menu_Info_Signals'Access, + Proc => Info_Proc_Proc'Access); + + Menu_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)); + if Menu = null then + Put_Line ("command '" & Line (P .. E) & "' not found"); + end if; + P := E + 1; + end Parse_Command; + + procedure Help_Proc (Line : String) is + P : Natural; + Root : Menu_Entry_Acc := Menu_Top'access; + begin + Put_Line ("This is the help command"); + P := Line'First; + while P < Line'Last loop + Parse_Command (Line, P, Root); + if Root = null then + return; + elsif Root.Kind /= Menu_Submenu then + Put_Line ("Menu entry " & Root.Name.all & " is not a submenu"); + return; + end if; + end loop; + + Root := Root.First; + while Root /= null loop + Put (Root.Name.all); + if Root.Kind = Menu_Submenu then + Put (" (menu)"); + end if; + New_Line; + Root := Root.Next; + end loop; + end Help_Proc; + + 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.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.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/src/vhdl/simulate/debugger.ads b/src/vhdl/simulate/debugger.ads new file mode 100644 index 000000000..5e8c7ac67 --- /dev/null +++ b/src/vhdl/simulate/debugger.ads @@ -0,0 +1,90 @@ +-- 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); + + -- 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; + + -- Disp stats about the design (number of process, number of signals...) + procedure Disp_Design_Stats; + + -- The reason why the debugger is invoked. + type Debug_Reason is + (-- Called from an external debugger while debugging ghdl. + Reason_Internal_Debug, + + -- Interractive session, elaboration not done + Reason_Start, + + -- At end of elaboration, for an interractive session + Reason_Elab, + + -- Before execution of a statement. + Reason_Break, + + -- Assertion failure + Reason_Assert, + + -- Non recoverable error occurred (such as index error, overflow...) + Reason_Error + ); + + Debugger_Quit : exception; + + -- Interractive debugger. + procedure Debug (Reason: Debug_Reason); + + -- Call the debugger in case of error. + procedure Debug_Error; +end Debugger; diff --git a/src/vhdl/simulate/elaboration.adb b/src/vhdl/simulate/elaboration.adb new file mode 100644 index 000000000..dd405ec18 --- /dev/null +++ b/src/vhdl/simulate/elaboration.adb @@ -0,0 +1,2582 @@ +-- 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 Types; use Types; +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_Body; + 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_B1 + | 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 Object_Slot_Type := Get_Info (Signal).Slot; + begin + Sig := Create_Signal (Default); + Def := Unshare (Default, Global_Pool'Access); + Block.Objects (Slot) := Sig; + Block.Objects (Slot + 1) := Def; + + 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_B1_Value (False); + else + T := Execute_Time_Attribute (Instance, Signal); + Init := Create_B1_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 + Instance := new Block_Instance_Type' + (Max_Objs => Package_Info.Nbr_Objects, + Scope_Level => Package_Info.Frame_Scope_Level, + Up_Block => null, + Label => Decl, + Stmt => Null_Iir, + Parent => null, + Children => null, + Brother => null, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + 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)); + 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 + (Instance_Slot_Type (-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; + 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 => + declare + Info : constant Sim_Info_Acc := Get_Info (Library_Unit); + Body_Design: Iir_Design_Unit; + begin + if Package_Instances (Info.Inst_Slot) = null then + -- Package not yet elaborated. + + -- Load the body now, as it can add objects in the + -- package instance. + 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); + + -- And then the body (if any). + if Body_Design = Null_Iir then + if Get_Need_Body (Library_Unit) then + Error_Msg_Elab + ("no package body for `" & + Image_Identifier (Library_Unit) & '''); + end if; + else + -- Note: the body can elaborate some packages. + Elaborate_Dependence (Body_Design); + + Elaborate_Package_Body + (Get_Library_Unit (Body_Design)); + end if; + end if; + end; + when Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Architecture_Body => + 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, + Label => Stmt, + Stmt => Obj, + Parent => Father, + Children => null, + Brother => null, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + Actuals_Ref => null, + Result => null); + + if Father /= null then + Res.Brother := Father.Children; + Father.Children := 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; + + -- Temporary put the instancce on the stack in case of function calls + -- during the elaboration of the protected object. + Current_Process.Instance := Inst; + + Elaborate_Declarative_Part (Inst, Get_Declaration_Chain (Bod)); + + Current_Process.Instance := Block; + + return Res; + end Create_Protected_Object; + + -- Create an value_literal for DECL (defined in BLOCK) and set it with + -- its default values. Nodes are shared. + function Create_Value_For_Type + (Block: Block_Instance_Acc; Decl: Iir; 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_B1 => + Res := Create_B1_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 Object_Slot_Type := 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 Object_Slot_Type := 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 Object_Slot_Type := 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 : constant Object_Slot_Type := Get_Info (Decl).Slot; + begin + if Slot + 1 = Instance.Elab_Objects then + -- Reference terminal of nature declaration may have already been + -- elaborated. + return; + end if; + if Slot /= Instance.Elab_Objects then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Instance.Objects (Slot) := + Create_Terminal_Object (Instance, Decl, Get_Nature (Decl)); + Instance.Elab_Objects := Slot + 1; + end Create_Terminal; + + function Create_Quantity_Object (Block: Block_Instance_Acc; + Decl : Iir; + Def: Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Kind : Quantity_Kind; + begin + case Get_Kind (Def) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + case Iir_Kinds_Quantity_Declaration (Get_Kind (Decl)) is + when Iir_Kind_Across_Quantity_Declaration => + Kind := Quantity_Across; + when Iir_Kind_Through_Quantity_Declaration => + Kind := Quantity_Through; + when Iir_Kind_Free_Quantity_Declaration => + Kind := Quantity_Free; + end case; + Res := Create_Quantity_Value + (Create_Scalar_Quantity (Kind, Decl, Block)); + when others => + Error_Kind ("create_quantity_object", Def); + end case; + return Res; + end Create_Quantity_Object; + + function Create_Quantity (Instance : Block_Instance_Acc; Decl : Iir) + return Iir_Value_Literal_Acc + is + Slot : constant Object_Slot_Type := Get_Info (Decl).Slot; + Res : Iir_Value_Literal_Acc; + begin + if Slot /= Instance.Elab_Objects then + Error_Msg_Elab ("bad elaboration order"); + raise Internal_Error; + end if; + Res := Create_Quantity_Object (Instance, Decl, Get_Type (Decl)); + Instance.Objects (Slot) := Res; + Instance.Elab_Objects := Slot + 1; + return Res; + end Create_Quantity; + + function Elaborate_Bound_Constraint + (Instance : Block_Instance_Acc; Bound: Iir) + return Iir_Value_Literal_Acc + is + Value : Iir_Value_Literal_Acc; + Ref : constant Iir := Get_Type (Bound); + Res : Iir_Value_Literal_Acc; + begin + 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 : constant Sim_Info_Acc := Get_Info (Rc); + Val : Iir_Value_Literal_Acc; + begin + 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 : constant Iir_List := Get_Index_Subtype_List (Ind); + St_El : Iir; + begin + for I in Natural loop + St_El := Get_Index_Type (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_Definition (Decl); + if Def = Null_Iir then + -- FIXME: can this happen ? + raise Program_Error; + end if; + if Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition then + Base_Type := Get_Base_Type (Def); + -- For a constrained array type declaration, however, + -- elaboration consists of the elaboration of the equivalent + -- anonymous unconstrained array type [...] + Elaborate_Subtype_Indication_If_Anonymous (Instance, Base_Type); + -- [...] followed by the elaboration of the named subtype + -- of that unconstrained type. + Elaborate_Subtype_Indication (Instance, Def); + else + Elaborate_Type_Definition (Instance, Def); + end if; + end Elaborate_Type_Declaration; + + procedure Elaborate_Nature_Definition + (Instance : Block_Instance_Acc; Def : Iir) + is + begin + case Get_Kind (Def) is + when Iir_Kind_Scalar_Nature_Definition => + Elaborate_Subtype_Indication (Instance, Get_Across_Type (Def)); + Elaborate_Subtype_Indication (Instance, Get_Through_Type (Def)); + when others => + Error_Kind ("elaborate_nature_definition", Def); + end case; + end Elaborate_Nature_Definition; + + -- LRM93 §12.2.1 The Generic Clause + 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_Association_Interface (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_Association_Interface (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) + and then Get_Collapse_Signal_Flag (Assoc) + then + declare + Slot : constant Object_Slot_Type := + Get_Info (Inter).Slot; + Actual_Sig : Iir_Value_Literal_Acc; + begin + Actual_Sig := + Execute_Name (Actual_Instance, Actual, True); + Implicit_Array_Conversion + (Formal_Instance, Actual_Sig, + Get_Type (Inter), Actual); + Formal_Instance.Objects (Slot) := Unshare_Bounds + (Actual_Sig, Global_Pool'Access); + Formal_Instance.Objects (Slot + 1) := Init_Expr; + end; + else + if Get_Whole_Association_Flag (Assoc) then + Elaborate_Signal (Formal_Instance, Inter, Init_Expr); + end if; + + -- Elaboration of a port association element consists of the + -- elaboration of the formal part; the port or subelement + -- or slice thereof designated by the formal part is then + -- associated with the signal or expression designated + -- by the actual part. + Elab_Connect + (Formal_Instance, Actual_Instance, Actual_Expr, Assoc); + end if; + + when Iir_Kind_Association_Element_Open => + -- Note that an open cannot be associated with a formal that + -- is associated individually. + Elaborate_Port_Declaration (Formal_Instance, Inter, null); + + when Iir_Kind_Association_Element_By_Individual => + Init_Expr := Create_Value_For_Type + (Formal_Instance, Get_Actual_Type (Assoc), 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_B1_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 + Frame : Block_Instance_Acc; + begin + if Is_Component_Instantiation (Stmt) then + declare + Component : constant Iir := + Get_Named_Entity (Get_Instantiated_Unit (Stmt)); + begin + -- Elaboration of a component instantiation statement that + -- instanciates a component declaration has no effect unless the + -- component instance is either fully bound to a design entity + -- defined by an entity declaration and architecture body or is + -- bound to a configuration of such a design entity. + -- FIXME: in fact the component is created. + + -- If a component instance is so bound, then elaboration of the + -- corresponding component instantiation statement consists of the + -- elaboration of the implied block statement representing the + -- component instance and [...] + Frame := Create_Block_Instance (Instance, Component, Stmt); + + 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)); + end; + else + -- Direct instantiation + declare + Aspect : constant Iir := Get_Instantiated_Unit (Stmt); + Arch : Iir; + Config : Iir; + begin + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Arch := Get_Architecture (Aspect); + if Arch = Null_Iir then + Arch := Libraries.Get_Latest_Architecture + (Get_Entity (Aspect)); + end if; + Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Configuration (Aspect); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + when others => + raise Internal_Error; + end case; + Config := Get_Block_Configuration (Config); + + Frame := Elaborate_Architecture + (Arch, Config, Instance, Stmt, + Get_Generic_Map_Aspect_Chain (Stmt), + Get_Port_Map_Aspect_Chain (Stmt)); + end; + end if; + end Elaborate_Component_Instantiation; + + -- LRM93 12.4.2 Generate Statements + procedure Elaborate_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.B1 /= 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 + Scheme : constant Iir_Iterator_Declaration := + Get_Generation_Scheme (Generate); + Ninstance : Block_Instance_Acc; + Sub_Instance : Block_Instance_Acc; + Bound, Index : Iir_Value_Literal_Acc; + begin + -- LRM93 12.4.2 + -- For a generate statement with a for generation scheme, elaboration + -- consists of the elaboration of the discrete range + + Ninstance := Create_Block_Instance (Instance, Generate, Generate); + Elaborate_Declaration (Ninstance, Scheme); + Bound := Execute_Bounds (Ninstance, Get_Type (Scheme)); + + -- 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; + + loop + Sub_Instance := Create_Block_Instance (Ninstance, Generate, Scheme); + + -- FIXME: this is needed to copy iterator type (if any). But this + -- elaborates the subtype several times (what about side effects). + Elaborate_Declaration (Sub_Instance, Scheme); + + -- Store index. + Store (Sub_Instance.Objects (Get_Info (Scheme).Slot), Index); + + Elaborate_Declarative_Part + (Sub_Instance, Get_Declaration_Chain (Generate)); + Elaborate_Statement_Part + (Sub_Instance, Get_Concurrent_Statement_Chain (Generate)); + + Update_Loop_Index (Index, Bound); + exit when not Is_In_Range (Index, Bound); + 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; + Comp_Instance : Block_Instance_Acc; + Conf : Iir_Component_Configuration) + is + Component : constant Iir_Component_Declaration := + Get_Named_Entity (Get_Instantiated_Unit (Stmt)); + Entity : Iir_Entity_Declaration; + Arch_Name : Name_Id; + Arch_Design : Iir_Design_Unit; + Arch : Iir_Architecture_Body; + Arch_Frame : Block_Instance_Acc; + pragma Unreferenced (Arch_Frame); + Generic_Map_Aspect_Chain : Iir; + Port_Map_Aspect_Chain : Iir; + Binding : Iir_Binding_Indication; + Aspect : Iir; + Sub_Conf : Iir; + begin + if Trace_Elaboration then + Ada.Text_IO.Put ("configure component "); + Ada.Text_IO.Put (Name_Table.Image (Get_Label (Stmt))); + Ada.Text_IO.Put (": "); + Ada.Text_IO.Put_Line (Image_Identifier (Component)); + end if; + + -- Elaboration of a component instantiation statement that instanciates + -- a component declaration has no effect unless the component instance + -- is either fully bound to a design entity defined by an entity + -- declaration and architecture body or is bound to a configuration of + -- such a design entity. + if not Is_Fully_Bound (Conf) then + Warning_Msg (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. + + -- and (within that block) the implied block statement representing the + -- design entity to which the component instance is so bound. + Arch := Null_Iir; + Arch_Name := Null_Identifier; + Binding := Get_Binding_Indication (Conf); + Aspect := Get_Entity_Aspect (Binding); + + case Get_Kind (Conf) is + when Iir_Kind_Component_Configuration => + Sub_Conf := Get_Block_Configuration (Conf); + when Iir_Kind_Configuration_Specification => + Sub_Conf := Null_Iir; + when others => + raise Internal_Error; + end case; + + case Get_Kind (Aspect) is + when Iir_Kind_Design_Unit => + raise Internal_Error; + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Aspect); + if Get_Architecture (Aspect) /= Null_Iir then + Arch_Name := Get_Identifier (Get_Architecture (Aspect)); + end if; + when Iir_Kind_Entity_Aspect_Configuration => + if Sub_Conf /= Null_Iir then + raise Internal_Error; + end if; + declare + Conf : constant Iir := Get_Configuration (Aspect); + begin + Entity := Get_Entity (Conf); + Sub_Conf := Get_Block_Configuration (Conf); + Arch := Get_Block_Specification (Sub_Conf); + end; + when others => + Error_Kind ("elaborate_component_declaration0", Aspect); + end case; + + if Arch = Null_Iir then + if Arch_Name = Null_Identifier then + Arch := Libraries.Get_Latest_Architecture (Entity); + if Arch = Null_Iir then + Error_Msg_Elab ("no architecture analysed for " + & Disp_Node (Entity), Stmt); + end if; + Arch_Name := Get_Identifier (Arch); + end if; + Arch_Design := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Entity), Arch_Name, Stmt); + if Arch_Design = Null_Iir then + Error_Msg_Elab ("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, Comp_Instance, Arch, + Generic_Map_Aspect_Chain, Port_Map_Aspect_Chain); + end Elaborate_Component_Configuration; + + procedure Elaborate_Block_Configuration + (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc); + + procedure Apply_Block_Configuration_To_Iterative_Generate + (Stmt : Iir; Conf_Chain : Iir; Instance : Block_Instance_Acc) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Bounds : constant Iir_Value_Literal_Acc := + Execute_Bounds (Instance, Get_Type (Scheme)); + + Sub_Instances : Block_Instance_Acc_Array + (0 .. Instance_Slot_Type (Bounds.Length - 1)); + + type Sub_Conf_Type is array (0 .. Instance_Slot_Type (Bounds.Length - 1)) + of Boolean; + Sub_Conf : Sub_Conf_Type := (others => False); + + Child : Block_Instance_Acc; + + Item : Iir; + Prev_Item : Iir; + Default_Item : Iir := Null_Iir; + Spec : Iir; + Expr : Iir_Value_Literal_Acc; + Ind : Instance_Slot_Type; + begin + -- Gather children + Child := Instance.Children; + for I in reverse Sub_Instances'Range loop + Sub_Instances (I) := Child; + Child := Child.Brother; + end loop; + if Child /= null then + raise Internal_Error; + end if; + + -- Apply configuration items + Item := Conf_Chain; + while Item /= Null_Iir loop + Spec := Get_Block_Specification (Item); + if Get_Kind (Spec) = Iir_Kind_Simple_Name then + Spec := Get_Named_Entity (Spec); + end if; + Prev_Item := Get_Prev_Block_Configuration (Item); + + case Get_Kind (Spec) is + when Iir_Kind_Slice_Name => + Expr := Execute_Bounds (Instance, Get_Suffix (Spec)); + Ind := Instance_Slot_Type + (Get_Index_Offset (Execute_Low_Limit (Expr), Bounds, Spec)); + for I in 1 .. Instance_Slot_Type (Expr.Length) loop + Sub_Conf (Ind + I - 1) := True; + Elaborate_Block_Configuration + (Item, Sub_Instances (Ind + I - 1)); + end loop; + when Iir_Kind_Indexed_Name => + if Get_Index_List (Spec) = Iir_List_Others then + -- Must be the only default block configuration + pragma Assert (Default_Item = Null_Iir); + Default_Item := Item; + else + Expr := Execute_Expression + (Instance, Get_First_Element (Get_Index_List (Spec))); + Ind := Instance_Slot_Type + (Get_Index_Offset (Expr, Bounds, Spec)); + Sub_Conf (Ind) := True; + Elaborate_Block_Configuration (Item, Sub_Instances (Ind)); + end if; + when Iir_Kind_Generate_Statement => + -- Must be the only block configuration + pragma Assert (Item = Conf_Chain); + pragma Assert (Prev_Item = Null_Iir); + for I in Sub_Instances'Range loop + Sub_Conf (I) := True; + Elaborate_Block_Configuration (Item, Sub_Instances (I)); + end loop; + when others => + raise Internal_Error; + end case; + Item := Prev_Item; + end loop; + + if Default_Item /= Null_Iir then + for I in Sub_Instances'Range loop + if not Sub_Conf (I) then + Elaborate_Block_Configuration + (Default_Item, Sub_Instances (I)); + end if; + end loop; + end if; + end Apply_Block_Configuration_To_Iterative_Generate; + + procedure Elaborate_Block_Configuration + (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc) + is + Blk_Info : constant Sim_Info_Acc := Get_Info (Instance.Stmt); + Sub_Instances : Block_Instance_Acc_Array + (0 .. Blk_Info.Nbr_Instances - 1); + type Iir_Array is array (Instance_Slot_Type range <>) of Iir; + Sub_Conf : Iir_Array (0 .. Blk_Info.Nbr_Instances - 1) := + (others => Null_Iir); + + Item : Iir; + begin + pragma Assert (Conf /= Null_Iir); + + -- Associate configuration items with subinstance. Gather items for + -- for-generate statements. + Item := Get_Configuration_Item_Chain (Conf); + while Item /= Null_Iir loop + case Get_Kind (Item) is + when Iir_Kind_Block_Configuration => + declare + Spec : Iir; + Gen : Iir_Generate_Statement; + Info : Sim_Info_Acc; + begin + Spec := Get_Block_Specification (Item); + if Get_Kind (Spec) = Iir_Kind_Simple_Name then + Spec := Get_Named_Entity (Spec); + end if; + case Get_Kind (Spec) is + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Name => + -- Block configuration for a generate statement. + Gen := Get_Named_Entity (Get_Prefix (Spec)); + Info := Get_Info (Gen); + Set_Prev_Block_Configuration + (Item, Sub_Conf (Info.Inst_Slot)); + Sub_Conf (Info.Inst_Slot) := Item; + when Iir_Kind_Generate_Statement => + Info := Get_Info (Spec); + if Sub_Conf (Info.Inst_Slot) /= Null_Iir then + raise Internal_Error; + end if; + Sub_Conf (Info.Inst_Slot) := Item; + when Iir_Kind_Block_Statement => + -- Block configuration for a block statement. + Info := Get_Info (Spec); + if Sub_Conf (Info.Inst_Slot) /= Null_Iir then + raise Internal_Error; + end if; + Sub_Conf (Info.Inst_Slot) := Item; + when others => + Error_Kind ("elaborate_block_configuration1", Spec); + end case; + end; + + when Iir_Kind_Component_Configuration => + declare + List : constant Iir_List := + Get_Instantiation_List (Item); + El : Iir; + Info : Sim_Info_Acc; + begin + if List = Iir_List_All or else List = Iir_List_Others then + raise Internal_Error; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Info := Get_Info (Get_Named_Entity (El)); + if Sub_Conf (Info.Inst_Slot) /= Null_Iir then + raise Internal_Error; + end if; + Sub_Conf (Info.Inst_Slot) := Item; + end loop; + end; + + when others => + Error_Kind ("elaborate_block_configuration", Item); + end case; + Item := Get_Chain (Item); + end loop; + + -- Gather children. + declare + Child : Block_Instance_Acc; + begin + Child := Instance.Children; + while Child /= null loop + declare + Slot : constant Instance_Slot_Type := + Get_Info (Child.Label).Inst_Slot; + begin + if Slot /= Invalid_Instance_Slot then + -- Processes have no slot. + if Sub_Instances (Slot) /= null then + raise Internal_Error; + end if; + Sub_Instances (Slot) := Child; + end if; + end; + Child := Child.Brother; + end loop; + end; + + -- Configure sub instances. + declare + Stmt : Iir; + Info : Sim_Info_Acc; + Slot : Instance_Slot_Type; + begin + Stmt := Get_Concurrent_Statement_Chain (Instance.Stmt); + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Generate_Statement => + Info := Get_Info (Stmt); + Slot := Info.Inst_Slot; + if Get_Kind (Get_Generation_Scheme (Stmt)) + = Iir_Kind_Iterator_Declaration + then + -- Iterative generate: apply to all instances + Apply_Block_Configuration_To_Iterative_Generate + (Stmt, Sub_Conf (Slot), Sub_Instances (Slot)); + else + -- Conditional generate: may not be instantiated + if Sub_Instances (Slot) /= null then + Elaborate_Block_Configuration + (Sub_Conf (Slot), Sub_Instances (Slot)); + end if; + end if; + when Iir_Kind_Block_Statement => + Info := Get_Info (Stmt); + Slot := Info.Inst_Slot; + Elaborate_Block_Configuration + (Sub_Conf (Slot), Sub_Instances (Slot)); + when Iir_Kind_Component_Instantiation_Statement => + if Is_Component_Instantiation (Stmt) then + Info := Get_Info (Stmt); + Slot := Info.Inst_Slot; + Elaborate_Component_Configuration + (Stmt, Sub_Instances (Slot), Sub_Conf (Slot)); + else + -- Nothing to do for entity instantiation, will be + -- done during elaboration of statements. + null; + end if; + when others => + null; + end case; + Stmt := Get_Chain (Stmt); + end loop; + end; + 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 => + if not Is_Second_Subprogram_Specification (Decl) then + Elaborate_Subprogram_Declaration (Instance, Decl); + end if; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + when Iir_Kind_Anonymous_Type_Declaration => + Elaborate_Type_Definition (Instance, Get_Type_Definition (Decl)); + when Iir_Kind_Type_Declaration => + Elaborate_Type_Declaration (Instance, Decl); + when Iir_Kind_Subtype_Declaration => + Elaborate_Subtype_Indication (Instance, Get_Type (Decl)); + when Iir_Kind_Iterator_Declaration => + Elaborate_Subtype_Indication_If_Anonymous + (Instance, Get_Type (Decl)); + Val := Create_Value_For_Type (Instance, Get_Type (Decl), 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 + Attr_Decl : constant Iir := + Get_Named_Entity (Get_Attribute_Designator (Decl)); + Attr_Type : constant Iir := Get_Type (Attr_Decl); + Value : Iir_Attribute_Value; + Val : Iir_Value_Literal_Acc; + begin + Value := Get_Attribute_Value_Spec_Chain (Decl); + while Value /= Null_Iir loop + -- 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_Body; + Conf : Iir_Block_Configuration; + Parent_Instance : Block_Instance_Acc; + Stmt : Iir; + Generic_Map : Iir; + Port_Map : Iir) + return Block_Instance_Acc + is + Entity : constant Iir_Entity_Declaration := Get_Entity (Arch); + Instance : Block_Instance_Acc; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + + if Trace_Elaboration then + Ada.Text_IO.Put ("elaborating "); + Ada.Text_IO.Put (Image_Identifier (Arch)); + Ada.Text_IO.Put (" of "); + Ada.Text_IO.Put_Line (Image_Identifier (Entity)); + end if; + + Instance := Create_Block_Instance (Parent_Instance, Arch, Stmt); + Instance.Up_Block := null; -- Packages_Instance; + + -- LRM93 §12.1 + -- Elaboration of a block statement involves first elaborating each not + -- yet elaborated package containing declarations referenced by the + -- block. + Elaborate_Dependence (Get_Design_Unit (Arch)); + + 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_Body; + Entity : Iir_Entity_Declaration; + Generic_Map : Iir; + Port_Map : Iir; + begin + Package_Instances := + new Block_Instance_Acc_Array (1 .. Instance_Slot_Type (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_Body => + 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/src/vhdl/simulate/elaboration.ads b/src/vhdl/simulate/elaboration.ads new file mode 100644 index 000000000..5a9ea8da2 --- /dev/null +++ b/src/vhdl/simulate/elaboration.ads @@ -0,0 +1,209 @@ +-- 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 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 Objects_Array is array (Object_Slot_Type range <>) of + Iir_Value_Literal_Acc; + + -- A block instance with its architecture/entity declaration is an + -- instancied entity. + + type Block_Instance_Type (Max_Objs : Object_Slot_Type) 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, package, process, component instantiation for + -- this instance. + Label : Iir; + + -- For blocks: corresponding block (different from label for direct + -- component instantiation statement and generate iterator). + -- For packages: Null_Iir + -- For subprograms and processes: statement being executed. + Stmt : Iir; + + -- Instanciation tree. + -- Parent is always set (but null for top-level block and packages) + Parent: Block_Instance_Acc; + -- Not null only for blocks and processes. + Children: Block_Instance_Acc; + Brother: Block_Instance_Acc; + + -- Pool marker for the child (only for subprograms and processes). + Marker : Areapools.Mark_Type; + + -- Reference to the actuals, for copy-out when returning from a + -- procedure. + Actuals_Ref : Value_Array_Acc; + + -- Only for function frame; contains the result. + Result: Iir_Value_Literal_Acc; + + -- Last object elaborated (or number of objects elaborated). + -- Note: this is generally the slot index of the next object to be + -- elaborated (this may be wrong for dynamic objects due to execution + -- branches). + Elab_Objects : Object_Slot_Type := 0; + + -- Values of the objects in that frame. + Objects : Objects_Array (1 .. Max_Objs); + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Block_Instance_Type, Name => Block_Instance_Acc); + + 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; + + type Block_Instance_Acc_Array is array (Instance_Slot_Type range <>) of + Block_Instance_Acc; + type Block_Instance_Acc_Array_Acc is access Block_Instance_Acc_Array; + + 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/src/vhdl/simulate/execution.adb b/src/vhdl/simulate/execution.adb new file mode 100644 index 000000000..ef4cccc46 --- /dev/null +++ b/src/vhdl/simulate/execution.adb @@ -0,0 +1,4837 @@ +-- Interpreted simulation +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Unchecked_Conversion; +with Ada.Text_IO; use Ada.Text_IO; +with System; +with Grt.Types; use Grt.Types; +with Errorout; use Errorout; +with Std_Package; +with Evaluation; +with Iirs_Utils; use Iirs_Utils; +with Annotations; use Annotations; +with Name_Table; +with File_Operation; +with Debugger; use Debugger; +with Std_Names; +with Str_Table; +with Files_Map; +with Iir_Chains; use Iir_Chains; +with Simulation; use Simulation; +with Grt.Astdio; +with Grt.Stdio; +with Grt.Options; +with Grt.Vstrings; +with Grt_Interface; +with Grt.Values; +with Grt.Errors; +with Grt.Std_Logic_1164; + +package body Execution is + + function Execute_Function_Call + (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) + return Iir_Value_Literal_Acc; + + procedure Finish_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir); + procedure Init_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir); + procedure Update_Next_Statement (Proc : Process_State_Acc); + + -- Display a message when an assertion has failed. + procedure Execute_Failed_Assertion (Report : String; + Severity : Natural; + Stmt: Iir); + + function Get_Instance_By_Scope_Level + (Instance: Block_Instance_Acc; Scope_Level: Scope_Level_Type) + return Block_Instance_Acc + is + Current: Block_Instance_Acc := Instance; + begin + while Current /= null loop + if Current.Scope_Level = Scope_Level then + return Current; + end if; + Current := Current.Up_Block; + end loop; + -- Global scope (packages) + if Scope_Level < Scope_Level_Global then + return Package_Instances (Instance_Slot_Type (-Scope_Level)); + end if; + if Current_Component /= null + and then Current_Component.Scope_Level = Scope_Level + then + return Current_Component; + end if; + if Scope_Level = Scope_Level_Global then + return null; + end if; + raise Internal_Error; + end Get_Instance_By_Scope_Level; + + function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) + return Block_Instance_Acc + is + begin + return Get_Instance_By_Scope_Level (Instance, + Get_Info (Decl).Scope_Level); + end Get_Instance_For_Slot; + + function Create_Bounds_From_Length (Block : Block_Instance_Acc; + Atype : Iir; + Len : Iir_Index32) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Index_Bounds : Iir_Value_Literal_Acc; + begin + Index_Bounds := Execute_Bounds (Block, Atype); + + Res := Create_Range_Value (Left => Index_Bounds.Left, + Right => null, + Dir => Index_Bounds.Dir, + Length => Len); + + if Len = 0 then + -- Special case. + Res.Right := Res.Left; + case Res.Left.Kind is + when Iir_Value_I64 => + case Index_Bounds.Dir is + when Iir_To => + Res.Left := Create_I64_Value (Res.Right.I64 + 1); + when Iir_Downto => + Res.Left := Create_I64_Value (Res.Right.I64 - 1); + end case; + when others => + raise Internal_Error; + end case; + else + case Res.Left.Kind is + when Iir_Value_E32 => + declare + R : Ghdl_E32; + begin + case Index_Bounds.Dir is + when Iir_To => + R := Res.Left.E32 + Ghdl_E32 (Len - 1); + when Iir_Downto => + R := Res.Left.E32 - Ghdl_E32 (Len - 1); + end case; + Res.Right := Create_E32_Value (R); + end; + when Iir_Value_I64 => + declare + R : Ghdl_I64; + begin + case Index_Bounds.Dir is + when Iir_To => + R := Res.Left.I64 + Ghdl_I64 (Len - 1); + when Iir_Downto => + R := Res.Left.I64 - Ghdl_I64 (Len - 1); + end case; + Res.Right := Create_I64_Value (R); + end; + when others => + raise Internal_Error; + end case; + end if; + return Res; + end Create_Bounds_From_Length; + + function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Right; + else + return Bounds.Left; + end if; + end Execute_High_Limit; + + function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + if Bounds.Dir = Iir_To then + return Bounds.Left; + else + return Bounds.Right; + end if; + end Execute_Low_Limit; + + function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Left; + end Execute_Left_Limit; + + function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Bounds.Right; + end Execute_Right_Limit; + + function Execute_Length (Bounds : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc is + begin + return Create_I64_Value (Ghdl_I64 (Bounds.Length)); + end Execute_Length; + + function Create_Enum_Value (Pos : Natural; Etype : Iir) + return Iir_Value_Literal_Acc + is + Base_Type : constant Iir := Get_Base_Type (Etype); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + case Mode is + when Iir_Value_E32 => + return Create_E32_Value (Ghdl_E32 (Pos)); + when Iir_Value_B1 => + return Create_B1_Value (Ghdl_B1'Val (Pos)); + when others => + raise Internal_Error; + end case; + end Create_Enum_Value; + + function String_To_Iir_Value (Str : String) return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Value (Str'Length, 1); + Res.Bounds.D (1) := Create_Range_Value + (Create_I64_Value (1), + Create_I64_Value (Str'Length), + Iir_To); + for I in Str'Range loop + Res.Val_Array.V (1 + Iir_Index32 (I - Str'First)) := + Create_E32_Value (Character'Pos (Str (I))); + end loop; + return Res; + end String_To_Iir_Value; + + function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; + Expr_Type : Iir) + return String + is + begin + case Get_Kind (Expr_Type) is + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + declare + Str : String (1 .. 24); + Last : Natural; + begin + Grt.Vstrings.To_String (Str, Last, Val.F64); + return Str (Str'First .. Last); + end; + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + declare + Str : String (1 .. 21); + First : Natural; + begin + Grt.Vstrings.To_String (Str, First, Val.I64); + return Str (First .. Str'Last); + end; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + declare + Lits : constant Iir_List := + Get_Enumeration_Literal_List (Expr_Type); + Pos : Natural; + begin + case Val.Kind is + when Iir_Value_B1 => + Pos := Ghdl_B1'Pos (Val.B1); + when Iir_Value_E32 => + Pos := Ghdl_E32'Pos (Val.E32); + when others => + raise Internal_Error; + end case; + return Name_Table.Image + (Get_Identifier (Get_Nth_Element (Lits, Pos))); + end; + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Str : String (1 .. 21); + First : Natural; + Id : constant Name_Id := + Get_Identifier (Get_Primary_Unit (Get_Base_Type (Expr_Type))); + begin + Grt.Vstrings.To_String (Str, First, Val.I64); + return Str (First .. Str'Last) & ' ' & Name_Table.Image (Id); + end; + when others => + Error_Kind ("execute_image_attribute", Expr_Type); + end case; + end Execute_Image_Attribute; + + function Execute_Shift_Operator (Left : Iir_Value_Literal_Acc; + Count : Ghdl_I64; + Expr : Iir) + return Iir_Value_Literal_Acc + is + Func : constant Iir_Predefined_Shift_Functions := + Get_Implicit_Definition (Get_Implementation (Expr)); + Cnt : Iir_Index32; + Len : constant Iir_Index32 := Left.Bounds.D (1).Length; + Dir_Left : Boolean; + P : Iir_Index32; + Res : Iir_Value_Literal_Acc; + E : Iir_Value_Literal_Acc; + begin + -- LRM93 7.2.3 + -- That is, if R is 0 or if L is a null array, the return value is L. + if Count = 0 or else Len = 0 then + return Left; + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Dir_Left := True; + when Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + Dir_Left := False; + end case; + if Count < 0 then + Cnt := Iir_Index32 (-Count); + Dir_Left := not Dir_Left; + else + Cnt := Iir_Index32 (Count); + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + E := Create_Enum_Value + (0, Get_Element_Subtype (Get_Base_Type (Get_Type (Expr)))); + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + E := Left.Val_Array.V (Len); + else + E := Left.Val_Array.V (1); + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Cnt := Cnt mod Len; + if not Dir_Left then + Cnt := (Len - Cnt) mod Len; + end if; + end case; + + Res := Create_Array_Value (1); + Res.Bounds.D (1) := Left.Bounds.D (1); + Create_Array_Data (Res, Len); + P := 1; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + if Cnt < Len then + for I in Cnt .. Len - 1 loop + Res.Val_Array.V (P) := Left.Val_Array.V (I + 1); + P := P + 1; + end loop; + else + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Res.Val_Array.V (P) := E; + P := P + 1; + end loop; + else + if Cnt > Len then + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Res.Val_Array.V (P) := E; + P := P + 1; + end loop; + for I in Cnt .. Len - 1 loop + Res.Val_Array.V (P) := Left.Val_Array.V (I - Cnt + 1); + P := P + 1; + end loop; + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + for I in 1 .. Len loop + Res.Val_Array.V (P) := Left.Val_Array.V (Cnt + 1); + P := P + 1; + Cnt := Cnt + 1; + if Cnt = Len then + Cnt := 0; + end if; + end loop; + end case; + return Res; + end Execute_Shift_Operator; + + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + function Execute_Bit_Vector_To_String (Val : Iir_Value_Literal_Acc; + Log_Base : Natural) + return Iir_Value_Literal_Acc + is + Base : constant Natural := 2 ** Log_Base; + Blen : constant Natural := Natural (Val.Bounds.D (1).Length); + Str : String (1 .. (Blen + Log_Base - 1) / Log_Base); + Pos : Natural; + V : Natural; + N : Natural; + begin + V := 0; + N := 1; + Pos := Str'Last; + for I in reverse Val.Val_Array.V'Range loop + V := V + Ghdl_B1'Pos (Val.Val_Array.V (I).B1) * N; + N := N * 2; + if N = Base or else I = Val.Val_Array.V'First then + Str (Pos) := Hex_Chars (V); + Pos := Pos - 1; + N := 1; + V := 0; + end if; + end loop; + return String_To_Iir_Value (Str); + end Execute_Bit_Vector_To_String; + + procedure Check_Std_Ulogic_Dc + (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic) + is + use Grt.Std_Logic_1164; + begin + if V = '-' then + Execute_Failed_Assertion + ("STD_LOGIC_1164: '-' operand for matching ordering operator", + 2, Loc); + end if; + end Check_Std_Ulogic_Dc; + + -- EXPR is the expression whose implementation is an implicit function. + function Execute_Implicit_Function (Block : Block_Instance_Acc; + Expr: Iir; + Left_Param : Iir; + Right_Param : Iir; + Res_Type : Iir) + return Iir_Value_Literal_Acc + is + pragma Unsuppress (Overflow_Check); + + Func : Iir_Predefined_Functions; + + -- Rename definition for monadic operations. + Left, Right: Iir_Value_Literal_Acc; + Operand : Iir_Value_Literal_Acc renames Left; + Result: Iir_Value_Literal_Acc; + + procedure Eval_Right is + begin + Right := Execute_Expression (Block, Right_Param); + end Eval_Right; + + -- Eval right argument, check left and right have same length, + -- Create RESULT from left. + procedure Eval_Array is + begin + Eval_Right; + if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then + Error_Msg_Constraint (Expr); + end if; + -- Need to copy as the result is modified. + Result := Unshare (Left, Expr_Pool'Access); + end Eval_Array; + + Imp : Iir; + begin + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) in Iir_Kinds_Denoting_Name then + Imp := Get_Named_Entity (Imp); + end if; + Func := Get_Implicit_Definition (Imp); + + -- Eval left operand. + case Func is + when Iir_Predefined_Now_Function => + Left := null; + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge=> + Operand := Execute_Name (Block, Left_Param, True); + when others => + Left := Execute_Expression (Block, Left_Param); + end case; + Right := null; + + case Func is + when Iir_Predefined_Error => + raise Internal_Error; + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Eval_Right; + + declare + -- Array length of the result. + Len: Iir_Index32; + + -- Index into the result. + Pos: Iir_Index32; + begin + -- Compute the length of the result. + case Func is + when Iir_Predefined_Array_Array_Concat => + Len := Left.Val_Array.Len + Right.Val_Array.Len; + when Iir_Predefined_Element_Array_Concat => + Len := 1 + Right.Val_Array.Len; + when Iir_Predefined_Array_Element_Concat => + Len := Left.Val_Array.Len + 1; + when Iir_Predefined_Element_Element_Concat => + Len := 1 + 1; + when others => + raise Program_Error; + end case; + + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + if Len = 0 then + -- Note: this return is allowed since LEFT is free, and + -- RIGHT must not be free. + return Right; + end if; + + -- Create the array result. + Result := Create_Array_Value (Len, 1); + Result.Bounds.D (1) := Create_Bounds_From_Length + (Block, Get_First_Element (Get_Index_Subtype_List (Res_Type)), + Len); + + -- Fill the result: left. + case Func is + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Array_Element_Concat => + for I in Left.Val_Array.V'Range loop + Result.Val_Array.V (I) := Left.Val_Array.V (I); + end loop; + Pos := Left.Val_Array.Len; + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Result.Val_Array.V (1) := Left; + Pos := 1; + when others => + raise Program_Error; + end case; + + -- Note: here POS is equal to the position of the last element + -- filled, or 0 if no elements were filled. + + -- Fill the result: right. + case Func is + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat => + for I in Right.Val_Array.V'Range loop + Result.Val_Array.V (Pos + I) := Right.Val_Array.V (I); + end loop; + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Result.Val_Array.V (Pos + 1) := Right; + when others => + raise Program_Error; + end case; + end; + + when Iir_Predefined_Bit_And + | Iir_Predefined_Boolean_And => + if Left.B1 = Lit_Enum_0.B1 then + -- Short circuit operator. + Result := Lit_Enum_0; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); + end if; + when Iir_Predefined_Bit_Nand + | Iir_Predefined_Boolean_Nand => + if Left.B1 = Lit_Enum_0.B1 then + -- Short circuit operator. + Result := Lit_Enum_1; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); + end if; + when Iir_Predefined_Bit_Or + | Iir_Predefined_Boolean_Or => + if Left.B1 = Lit_Enum_1.B1 then + -- Short circuit operator. + Result := Lit_Enum_1; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); + end if; + when Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_Nor => + if Left.B1 = Lit_Enum_1.B1 then + -- Short circuit operator. + Result := Lit_Enum_0; + else + Eval_Right; + Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); + end if; + when Iir_Predefined_Bit_Xor + | Iir_Predefined_Boolean_Xor => + Eval_Right; + Result := Boolean_To_Lit (Left.B1 /= Right.B1); + when Iir_Predefined_Bit_Xnor + | Iir_Predefined_Boolean_Xnor => + Eval_Right; + Result := Boolean_To_Lit (Left.B1 = Right.B1); + when Iir_Predefined_Bit_Not + | Iir_Predefined_Boolean_Not => + Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_0.B1); + + when Iir_Predefined_Bit_Condition => + Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_1.B1); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Eval_Right; + Result := Execute_Shift_Operator (Left, Right.I64, Expr); + + when Iir_Predefined_Enum_Equality + | Iir_Predefined_Integer_Equality + | Iir_Predefined_Array_Equality + | Iir_Predefined_Access_Equality + | Iir_Predefined_Physical_Equality + | Iir_Predefined_Floating_Equality + | Iir_Predefined_Record_Equality + | Iir_Predefined_Bit_Match_Equality + | Iir_Predefined_Bit_Array_Match_Equality => + Eval_Right; + Result := Boolean_To_Lit (Is_Equal (Left, Right)); + when Iir_Predefined_Enum_Inequality + | Iir_Predefined_Integer_Inequality + | Iir_Predefined_Array_Inequality + | Iir_Predefined_Access_Inequality + | Iir_Predefined_Physical_Inequality + | Iir_Predefined_Floating_Inequality + | Iir_Predefined_Record_Inequality + | Iir_Predefined_Bit_Match_Inequality + | Iir_Predefined_Bit_Array_Match_Inequality => + Eval_Right; + Result := Boolean_To_Lit (not Is_Equal (Left, Right)); + when Iir_Predefined_Integer_Less + | Iir_Predefined_Physical_Less => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 < Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Greater + | Iir_Predefined_Physical_Greater => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 > Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Less_Equal + | Iir_Predefined_Physical_Less_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 <= Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Greater_Equal + | Iir_Predefined_Physical_Greater_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 >= Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Less => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 < Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 < Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Greater => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 > Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 > Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Less_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 <= Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 <= Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Greater_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 >= Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 >= Right.E32); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Physical_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Enum_Maximum + | Iir_Predefined_Physical_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + + when Iir_Predefined_Integer_Plus + | Iir_Predefined_Physical_Plus => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 + Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Minus + | Iir_Predefined_Physical_Minus => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 - Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Mul => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Left.I64 * Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Mod => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 mod Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Rem => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 rem Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Div => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 = 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 / Right.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Absolute + | Iir_Predefined_Physical_Absolute => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (abs Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Negation + | Iir_Predefined_Physical_Negation => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (-Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Physical_Identity => + case Operand.Kind is + when Iir_Value_I64 => + Result := Create_I64_Value (Operand.I64); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Exp => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + if Right.I64 < 0 then + Error_Msg_Constraint (Expr); + end if; + Result := Create_I64_Value (Left.I64 ** Natural (Right.I64)); + when others => + raise Internal_Error; + end case; + + when Iir_Predefined_Integer_Minimum => + Eval_Right; + Result := Create_I64_Value (Ghdl_I64'Min (Left.I64, Right.I64)); + when Iir_Predefined_Integer_Maximum => + Eval_Right; + Result := Create_I64_Value (Ghdl_I64'Max (Left.I64, Right.I64)); + + when Iir_Predefined_Floating_Mul => + Eval_Right; + Result := Create_F64_Value (Left.F64 * Right.F64); + when Iir_Predefined_Floating_Div => + Eval_Right; + Result := Create_F64_Value (Left.F64 / Right.F64); + when Iir_Predefined_Floating_Minus => + Eval_Right; + Result := Create_F64_Value (Left.F64 - Right.F64); + when Iir_Predefined_Floating_Plus => + Eval_Right; + Result := Create_F64_Value (Left.F64 + Right.F64); + when Iir_Predefined_Floating_Exp => + Eval_Right; + Result := Create_F64_Value (Left.F64 ** Integer (Right.I64)); + when Iir_Predefined_Floating_Identity => + Result := Create_F64_Value (Operand.F64); + when Iir_Predefined_Floating_Negation => + Result := Create_F64_Value (-Operand.F64); + when Iir_Predefined_Floating_Absolute => + Result := Create_F64_Value (abs (Operand.F64)); + when Iir_Predefined_Floating_Less => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 < Right.F64); + when Iir_Predefined_Floating_Less_Equal => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 <= Right.F64); + when Iir_Predefined_Floating_Greater => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 > Right.F64); + when Iir_Predefined_Floating_Greater_Equal => + Eval_Right; + Result := Boolean_To_Lit (Left.F64 >= Right.F64); + + when Iir_Predefined_Floating_Minimum => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64'Min (Left.F64, Right.F64)); + when Iir_Predefined_Floating_Maximum => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64'Max (Left.F64, Right.F64)); + + when Iir_Predefined_Integer_Physical_Mul => + Eval_Right; + Result := Create_I64_Value (Left.I64 * Right.I64); + when Iir_Predefined_Physical_Integer_Mul => + Eval_Right; + Result := Create_I64_Value (Left.I64 * Right.I64); + when Iir_Predefined_Physical_Physical_Div => + Eval_Right; + Result := Create_I64_Value (Left.I64 / Right.I64); + when Iir_Predefined_Physical_Integer_Div => + Eval_Right; + Result := Create_I64_Value (Left.I64 / Right.I64); + when Iir_Predefined_Real_Physical_Mul => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Left.F64 * Ghdl_F64 (Right.I64))); + when Iir_Predefined_Physical_Real_Mul => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Ghdl_F64 (Left.I64) * Right.F64)); + when Iir_Predefined_Physical_Real_Div => + Eval_Right; + Result := Create_I64_Value + (Ghdl_I64 (Ghdl_F64 (Left.I64) / Right.F64)); + + when Iir_Predefined_Universal_I_R_Mul => + Eval_Right; + Result := Create_F64_Value (Ghdl_F64 (Left.I64) * Right.F64); + when Iir_Predefined_Universal_R_I_Mul => + Eval_Right; + Result := Create_F64_Value (Left.F64 * Ghdl_F64 (Right.I64)); + + when Iir_Predefined_TF_Array_And => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Nand => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1); + end loop; + when Iir_Predefined_TF_Array_Or => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Nor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1); + end loop; + when Iir_Predefined_TF_Array_Xor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Array_Xnor => + Eval_Array; + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1); + end loop; + + when Iir_Predefined_TF_Array_Element_And => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_And => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 and Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Or => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_Or => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 or Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Xor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Right.B1; + end loop; + when Iir_Predefined_TF_Element_Array_Xor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + Result.Val_Array.V (I).B1 xor Left.B1; + end loop; + + when Iir_Predefined_TF_Array_Element_Nand => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Nand => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 and Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Element_Nor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Nor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 or Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Element_Xnor => + Eval_Right; + Result := Unshare (Left, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Right.B1); + end loop; + when Iir_Predefined_TF_Element_Array_Xnor => + Eval_Right; + Result := Unshare (Right, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := + not (Result.Val_Array.V (I).B1 xor Left.B1); + end loop; + + when Iir_Predefined_TF_Array_Not => + -- Need to copy as the result is modified. + Result := Unshare (Operand, Expr_Pool'Access); + for I in Result.Val_Array.V'Range loop + Result.Val_Array.V (I).B1 := not Result.Val_Array.V (I).B1; + end loop; + + when Iir_Predefined_TF_Reduction_And => + Result := Create_B1_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Nand => + Result := Create_B1_Value (True); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + when Iir_Predefined_TF_Reduction_Or => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Nor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + when Iir_Predefined_TF_Reduction_Xor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; + end loop; + when Iir_Predefined_TF_Reduction_Xnor => + Result := Create_B1_Value (False); + for I in Operand.Val_Array.V'Range loop + Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; + end loop; + Result.B1 := not Result.B1; + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B1 = True); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Boolean_To_Lit + (Execute_Event_Attribute (Operand) + and then Execute_Signal_Value (Operand).B1 = False); + + when Iir_Predefined_Array_Greater => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) = Greater); + + when Iir_Predefined_Array_Greater_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); + + when Iir_Predefined_Array_Less => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) = Less); + + when Iir_Predefined_Array_Less_Equal => + Eval_Right; + Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); + + when Iir_Predefined_Array_Minimum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Left; + else + Result := Right; + end if; + when Iir_Predefined_Array_Maximum => + Eval_Right; + if Compare_Value (Left, Right) = Less then + Result := Right; + else + Result := Left; + end if; + + when Iir_Predefined_Vector_Maximum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_Low_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Greater then + Result := V; + end if; + end loop; + end; + when Iir_Predefined_Vector_Minimum => + declare + El_St : constant Iir := + Get_Return_Type (Get_Implementation (Expr)); + V : Iir_Value_Literal_Acc; + begin + Result := Execute_High_Limit (Execute_Bounds (Block, El_St)); + for I in Left.Val_Array.V'Range loop + V := Left.Val_Array.V (I); + if Compare_Value (V, Result) = Less then + Result := V; + end if; + end loop; + end; + + when Iir_Predefined_Endfile => + Result := Boolean_To_Lit (File_Operation.Endfile (Left, Null_Iir)); + + when Iir_Predefined_Now_Function => + Result := Create_I64_Value (Ghdl_I64 (Grt.Types.Current_Time)); + + when Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Physical_To_String => + Result := String_To_Iir_Value + (Execute_Image_Attribute (Left, Get_Type (Left_Param))); + + when Iir_Predefined_Enum_To_String => + declare + use Name_Table; + Base_Type : constant Iir := + Get_Base_Type (Get_Type (Left_Param)); + Lits : constant Iir_List := + Get_Enumeration_Literal_List (Base_Type); + Pos : constant Natural := Get_Enum_Pos (Left); + Id : Name_Id; + begin + if Base_Type = Std_Package.Character_Type_Definition then + Result := String_To_Iir_Value ((1 => Character'Val (Pos))); + else + Id := Get_Identifier (Get_Nth_Element (Lits, Pos)); + if Is_Character (Id) then + Result := String_To_Iir_Value ((1 => Get_Character (Id))); + else + Result := String_To_Iir_Value (Image (Id)); + end if; + end if; + end; + + when Iir_Predefined_Array_Char_To_String => + declare + Str : String (1 .. Natural (Left.Bounds.D (1).Length)); + Lits : constant Iir_List := + Get_Enumeration_Literal_List + (Get_Base_Type + (Get_Element_Subtype (Get_Type (Left_Param)))); + Pos : Natural; + begin + for I in Left.Val_Array.V'Range loop + Pos := Get_Enum_Pos (Left.Val_Array.V (I)); + Str (Positive (I)) := Name_Table.Get_Character + (Get_Identifier (Get_Nth_Element (Lits, Pos))); + end loop; + Result := String_To_Iir_Value (Str); + end; + + when Iir_Predefined_Bit_Vector_To_Hstring => + return Execute_Bit_Vector_To_String (Left, 4); + + when Iir_Predefined_Bit_Vector_To_Ostring => + return Execute_Bit_Vector_To_String (Left, 3); + + when Iir_Predefined_Real_To_String_Digits => + Eval_Right; + declare + Str : Grt.Vstrings.String_Real_Digits; + Last : Natural; + begin + Grt.Vstrings.To_String + (Str, Last, Left.F64, Ghdl_I32 (Right.I64)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Real_To_String_Format => + Eval_Right; + declare + Format : String (1 .. Natural (Right.Val_Array.Len) + 1); + Str : Grt.Vstrings.String_Real_Format; + Last : Natural; + begin + for I in Right.Val_Array.V'Range loop + Format (Positive (I)) := + Character'Val (Right.Val_Array.V (I).E32); + end loop; + Format (Format'Last) := ASCII.NUL; + Grt.Vstrings.To_String + (Str, Last, Left.F64, To_Ghdl_C_String (Format'Address)); + Result := String_To_Iir_Value (Str (1 .. Last)); + end; + when Iir_Predefined_Time_To_String_Unit => + Eval_Right; + declare + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Unit : Iir; + begin + Unit := Get_Unit_Chain (Std_Package.Time_Type_Definition); + while Unit /= Null_Iir loop + exit when Evaluation.Get_Physical_Value (Unit) + = Iir_Int64 (Right.I64); + Unit := Get_Chain (Unit); + end loop; + if Unit = Null_Iir then + Error_Msg_Exec + ("to_string for time called with wrong unit", Expr); + end if; + Grt.Vstrings.To_String (Str, First, Left.I64, Right.I64); + Result := String_To_Iir_Value + (Str (First .. Str'Last) & ' ' + & Name_Table.Image (Get_Identifier (Unit))); + end; + + when Iir_Predefined_Std_Ulogic_Match_Equality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E32_Value + (Std_Ulogic'Pos + (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32)))); + end; + when Iir_Predefined_Std_Ulogic_Match_Inequality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E32_Value + (Std_Ulogic'Pos + (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32))))); + end; + when Iir_Predefined_Std_Ulogic_Match_Ordering_Functions => + Eval_Right; + declare + use Grt.Std_Logic_1164; + L : constant Std_Ulogic := Std_Ulogic'Val (Left.E32); + R : constant Std_Ulogic := Std_Ulogic'Val (Right.E32); + Res : Std_Ulogic; + begin + Check_Std_Ulogic_Dc (Expr, L); + Check_Std_Ulogic_Dc (Expr, R); + case Iir_Predefined_Std_Ulogic_Match_Ordering_Functions (Func) + is + when Iir_Predefined_Std_Ulogic_Match_Less => + Res := Match_Lt_Table (L, R); + when Iir_Predefined_Std_Ulogic_Match_Less_Equal => + Res := Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R)); + when Iir_Predefined_Std_Ulogic_Match_Greater => + Res := Not_Table (Or_Table (Match_Lt_Table (L, R), + Match_Eq_Table (L, R))); + when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + Res := Not_Table (Match_Lt_Table (L, R)); + end case; + Result := Create_E32_Value (Std_Ulogic'Pos (Res)); + end; + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + Eval_Right; + if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then + Error_Msg_Constraint (Expr); + end if; + declare + use Grt.Std_Logic_1164; + Res : Std_Ulogic := '1'; + begin + Result := Create_E32_Value (Std_Ulogic'Pos ('1')); + for I in Left.Val_Array.V'Range loop + Res := And_Table + (Res, + Match_Eq_Table + (Std_Ulogic'Val (Left.Val_Array.V (I).E32), + Std_Ulogic'Val (Right.Val_Array.V (I).E32))); + end loop; + if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then + Res := Not_Table (Res); + end if; + Result := Create_E32_Value (Std_Ulogic'Pos (Res)); + end; + + when others => + Error_Msg ("execute_implicit_function: unimplemented " & + Iir_Predefined_Functions'Image (Func)); + raise Internal_Error; + end case; + return Result; + exception + when Constraint_Error => + Error_Msg_Constraint (Expr); + end Execute_Implicit_Function; + + procedure Execute_Implicit_Procedure + (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) + is + Imp : constant Iir_Implicit_Procedure_Declaration := + Get_Named_Entity (Get_Implementation (Stmt)); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Assoc: Iir; + Args: Iir_Value_Literal_Array (0 .. 3); + Inter_Chain : Iir; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + Assoc := Assoc_Chain; + for I in Iir_Index32 loop + exit when Assoc = Null_Iir; + Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + Inter_Chain := Get_Interface_Declaration_Chain (Imp); + case Get_Implicit_Definition (Imp) is + when Iir_Predefined_Deallocate => + if Args (0).Val_Access /= null then + Free_Heap_Value (Args (0)); + Args (0).Val_Access := null; + end if; + when Iir_Predefined_File_Open => + File_Operation.File_Open + (Args (0), Args (1), Args (2), Inter_Chain, Stmt); + when Iir_Predefined_File_Open_Status => + File_Operation.File_Open_Status + (Args (0), Args (1), Args (2), Args (3), + Get_Chain (Inter_Chain), Stmt); + when Iir_Predefined_Write => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.Write_Text (Args (0), Args (1)); + else + File_Operation.Write_Binary (Args (0), Args (1)); + end if; + when Iir_Predefined_Read_Length => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.Read_Length_Text + (Args (0), Args (1), Args (2)); + else + File_Operation.Read_Length_Binary + (Args (0), Args (1), Args (2)); + end if; + when Iir_Predefined_Read => + File_Operation.Read_Binary (Args (0), Args (1)); + when Iir_Predefined_Flush => + File_Operation.Flush (Args (0)); + when Iir_Predefined_File_Close => + if Get_Text_File_Flag (Get_Type (Inter_Chain)) then + File_Operation.File_Close_Text (Args (0), Stmt); + else + File_Operation.File_Close_Binary (Args (0), Stmt); + end if; + when others => + Error_Kind ("execute_implicit_procedure", + Get_Implicit_Definition (Imp)); + end case; + Release (Expr_Mark, Expr_Pool); + end Execute_Implicit_Procedure; + + procedure Execute_Foreign_Procedure + (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) + is + Imp : constant Iir_Implicit_Procedure_Declaration := + Get_Implementation (Stmt); + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Assoc: Iir; + Args: Iir_Value_Literal_Array (0 .. 3) := (others => null); + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + Assoc := Assoc_Chain; + for I in Args'Range loop + exit when Assoc = Null_Iir; + Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + case Get_Identifier (Imp) is + when Std_Names.Name_Untruncated_Text_Read => + File_Operation.Untruncated_Text_Read + (Args (0), Args (1), Args (2)); + when Std_Names.Name_Control_Simulation => + Put_Line (Standard_Error, "simulation finished"); + raise Simulation_Finished; + when others => + Error_Msg_Exec ("unsupported foreign procedure call", Stmt); + end case; + Release (Expr_Mark, Expr_Pool); + end Execute_Foreign_Procedure; + + -- Compute the offset for INDEX into a range BOUNDS. + -- EXPR is only used in case of error. + function Get_Index_Offset + (Index: Iir_Value_Literal_Acc; + Bounds: Iir_Value_Literal_Acc; + Expr: Iir) + return Iir_Index32 + is + Left_Pos, Right_Pos: Iir_Value_Literal_Acc; + begin + Left_Pos := Bounds.Left; + Right_Pos := Bounds.Right; + if Index.Kind /= Left_Pos.Kind or else Index.Kind /= Right_Pos.Kind then + raise Internal_Error; + end if; + case Index.Kind is + when Iir_Value_B1 => + case Bounds.Dir is + when Iir_To => + if Index.B1 >= Left_Pos.B1 and then + Index.B1 <= Right_Pos.B1 + then + -- to + return Ghdl_B1'Pos (Index.B1) - Ghdl_B1'Pos (Left_Pos.B1); + end if; + when Iir_Downto => + if Index.B1 <= Left_Pos.B1 and then + Index.B1 >= Right_Pos.B1 + then + -- downto + return Ghdl_B1'Pos (Left_Pos.B1) - Ghdl_B1'Pos (Index.B1); + end if; + end case; + when Iir_Value_E32 => + case Bounds.Dir is + when Iir_To => + if Index.E32 >= Left_Pos.E32 and then + Index.E32 <= Right_Pos.E32 + then + -- to + return Iir_Index32 (Index.E32 - Left_Pos.E32); + end if; + when Iir_Downto => + if Index.E32 <= Left_Pos.E32 and then + Index.E32 >= Right_Pos.E32 + then + -- downto + return Iir_Index32 (Left_Pos.E32 - Index.E32); + end if; + end case; + when Iir_Value_I64 => + case Bounds.Dir is + when Iir_To => + if Index.I64 >= Left_Pos.I64 and then + Index.I64 <= Right_Pos.I64 + then + -- to + return Iir_Index32 (Index.I64 - Left_Pos.I64); + end if; + when Iir_Downto => + if Index.I64 <= Left_Pos.I64 and then + Index.I64 >= Right_Pos.I64 + then + -- downto + return Iir_Index32 (Left_Pos.I64 - Index.I64); + end if; + end case; + when others => + raise Internal_Error; + end case; + Error_Msg_Constraint (Expr); + return 0; + end Get_Index_Offset; + + -- Create an iir_value_literal of kind iir_value_array and of life LIFE. + -- Allocate the array of bounds, and fill it from A_TYPE. + -- Allocate the array of values. + function Create_Array_Bounds_From_Type + (Block : Block_Instance_Acc; + A_Type : Iir; + Create_Val_Array : Boolean) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Index_List : Iir_List; + Len : Iir_Index32; + Bound : Iir_Value_Literal_Acc; + begin + -- Only for constrained subtypes. + if Get_Kind (A_Type) = Iir_Kind_Array_Type_Definition then + raise Internal_Error; + end if; + + Index_List := Get_Index_Subtype_List (A_Type); + Res := Create_Array_Value + (Iir_Index32 (Get_Nbr_Elements (Index_List))); + Len := 1; + for I in 1 .. Res.Bounds.Nbr_Dims loop + Bound := Execute_Bounds + (Block, Get_Nth_Element (Index_List, Natural (I - 1))); + Len := Len * Bound.Length; + Res.Bounds.D (I) := Bound; + end loop; + if Create_Val_Array then + Create_Array_Data (Res, Len); + end if; + return Res; + end Create_Array_Bounds_From_Type; + + -- Return the steps (ie, offset in the array when index DIM is increased + -- by one) for array ARR and dimension DIM. + function Get_Step_For_Dim (Arr: Iir_Value_Literal_Acc; Dim : Natural) + return Iir_Index32 + is + Bounds : Value_Bounds_Array_Acc renames Arr.Bounds; + Res : Iir_Index32; + begin + Res := 1; + for I in Iir_Index32 (Dim + 1) .. Bounds.Nbr_Dims loop + Res := Res * Bounds.D (I).Length; + end loop; + return Res; + end Get_Step_For_Dim; + + -- Create a literal for a string or a bit_string + function String_To_Enumeration_Array_1 (Str: Iir; El_Type : Iir) + return Iir_Value_Literal_Acc + is + Lit: Iir_Value_Literal_Acc; + Element_Mode : Iir_Value_Scalars; + + procedure Create_Lit_El + (Index : Iir_Index32; Literal: Iir_Enumeration_Literal) + is + R : Iir_Value_Literal_Acc; + P : constant Iir_Int32 := Get_Enum_Pos (Literal); + begin + case Element_Mode is + when Iir_Value_B1 => + R := Create_B1_Value (Ghdl_B1'Val (P)); + when Iir_Value_E32 => + R := Create_E32_Value (Ghdl_E32'Val (P)); + when others => + raise Internal_Error; + end case; + Lit.Val_Array.V (Index) := R; + end Create_Lit_El; + + El_Btype : constant Iir := Get_Base_Type (El_Type); + Literal_List: constant Iir_List := + Get_Enumeration_Literal_List (El_Btype); + Len: Iir_Index32; + Str_As_Str: constant String := Iirs_Utils.Image_String_Lit (Str); + El : Iir; + begin + Element_Mode := Get_Info (El_Btype).Scalar_Mode; + + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Len := Iir_Index32 (Str_As_Str'Length); + Lit := Create_Array_Value (Len, 1); + + for I in Lit.Val_Array.V'Range loop + -- FIXME: use literal from type ?? + El := Find_Name_In_List + (Literal_List, + Name_Table.Get_Identifier (Str_As_Str (Natural (I)))); + if El = Null_Iir then + -- FIXME: could free what was already built. + return null; + end if; + Create_Lit_El (I, El); + end loop; + + when Iir_Kind_Bit_String_Literal => + declare + Lit_0, Lit_1 : Iir; + Buf : String_Fat_Acc; + Len1 : Int32; + begin + Lit_0 := Get_Bit_String_0 (Str); + Lit_1 := Get_Bit_String_1 (Str); + Buf := Str_Table.Get_String_Fat_Acc (Get_String_Id (Str)); + Len1 := Get_String_Length (Str); + Lit := Create_Array_Value (Iir_Index32 (Len1), 1); + + if Lit_0 = Null_Iir or Lit_1 = Null_Iir then + raise Internal_Error; + end if; + for I in 1 .. Len1 loop + case Buf (I) is + when '0' => + Create_Lit_El (Iir_Index32 (I), Lit_0); + when '1' => + Create_Lit_El (Iir_Index32 (I), Lit_1); + when others => + raise Internal_Error; + end case; + end loop; + end; + when others => + raise Internal_Error; + end case; + + return Lit; + end String_To_Enumeration_Array_1; + + -- Create a literal for a string or a bit_string + function String_To_Enumeration_Array (Block: Block_Instance_Acc; Str: Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + Array_Type: constant Iir := Get_Type (Str); + Index_Types : constant Iir_List := Get_Index_Subtype_List (Array_Type); + begin + if Get_Nbr_Elements (Index_Types) /= 1 then + raise Internal_Error; -- array must be unidimensional + end if; + + Res := String_To_Enumeration_Array_1 + (Str, Get_Element_Subtype (Array_Type)); + + -- When created from static evaluation, a string may still have an + -- unconstrained type. + if Get_Constraint_State (Array_Type) /= Fully_Constrained then + Res.Bounds.D (1) := + Create_Range_Value (Create_I64_Value (1), + Create_I64_Value (Ghdl_I64 (Res.Val_Array.Len)), + Iir_To, + Res.Val_Array.Len); + else + Res.Bounds.D (1) := + Execute_Bounds (Block, Get_First_Element (Index_Types)); + end if; + + -- The range may not be statically constant. + if Res.Bounds.D (1).Length /= Res.Val_Array.Len then + Error_Msg_Constraint (Str); + end if; + + return Res; + end String_To_Enumeration_Array; + + -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. + -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. + -- EL_TYPE is the type of the array element. + procedure Fill_Array_Aggregate_1 + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc; + Orig : Iir_Index32; + Step : Iir_Index32; + Dim : Iir_Index32; + Nbr_Dim : Iir_Index32; + El_Type : Iir) + is + Value : Iir; + Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim); + + procedure Set_Elem (Pos : Iir_Index32) + is + Val : Iir_Value_Literal_Acc; + begin + if Dim = Nbr_Dim then + -- VALUE is an expression (which may be an aggregate, but not + -- a sub-aggregate. + Val := Execute_Expression_With_Type (Block, Value, El_Type); + -- LRM93 7.3.2.2 + -- For a multi-dimensional aggregate of dimension n, a check + -- is made that all (n-1)-dimensional subaggregates have the + -- same bounds. + -- GHDL: I have added an implicit array conversion, however + -- it may be useful to allow cases like this: + -- type str_array is array (natural range <>) + -- of string (10 downto 1); + -- constant floats : str_array := + -- ( "00000000.0", HT & "+1.5ABCDE"); + -- The subtype of the first sub-aggregate (0.0) is + -- determinated by the context, according to rule 9 and 4 + -- of LRM93 7.3.2.2 and therefore is string (10 downto 1), + -- while the subtype of the second sub-aggregate (HT & ...) + -- is determinated by rules 1 and 2 of LRM 7.2.4, and is + -- string (1 to 10). + -- Unless an implicit conversion is used, according to the + -- LRM, this should fail, but it makes no sens. + -- + -- FIXME: Add a warning, a flag ? + --Implicit_Array_Conversion (Block, Val, El_Type, Value); + --Check_Constraints (Block, Val, El_Type, Value); + Res.Val_Array.V (1 + Orig + Pos * Step) := Val; + else + case Get_Kind (Value) is + when Iir_Kind_Aggregate => + -- VALUE is a sub-aggregate. + Fill_Array_Aggregate_1 (Block, Value, Res, + Orig + Pos * Step, + Step / Res.Bounds.D (Dim + 1).Length, + Dim + 1, Nbr_Dim, El_Type); + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + pragma Assert (Dim + 1 = Nbr_Dim); + Val := String_To_Enumeration_Array_1 (Value, El_Type); + if Val.Val_Array.Len /= Res.Bounds.D (Nbr_Dim).Length then + Error_Msg_Constraint (Value); + end if; + for I in Val.Val_Array.V'Range loop + Res.Val_Array.V (Orig + Pos * Step + I) := + Val.Val_Array.V (I); + end loop; + when others => + Error_Kind ("fill_array_aggregate_1", Value); + end case; + end if; + end Set_Elem; + + procedure Set_Elem_By_Expr (Expr : Iir) + is + Expr_Pos: Iir_Value_Literal_Acc; + begin + Expr_Pos := Execute_Expression (Block, Expr); + Set_Elem (Get_Index_Offset (Expr_Pos, Bound, Expr)); + end Set_Elem_By_Expr; + + procedure Set_Elem_By_Range (Expr : Iir) + is + A_Range : Iir_Value_Literal_Acc; + High, Low : Iir_Value_Literal_Acc; + begin + A_Range := Execute_Bounds (Block, Expr); + if Is_Nul_Range (A_Range) then + return; + end if; + if A_Range.Dir = Iir_To then + High := A_Range.Right; + Low := A_Range.Left; + else + High := A_Range.Left; + Low := A_Range.Right; + end if; + + -- Locally modified (incremented) + Low := Unshare (Low, Expr_Pool'Access); + + loop + Set_Elem (Get_Index_Offset (Low, Bound, Expr)); + exit when Is_Equal (Low, High); + Increment (Low); + end loop; + end Set_Elem_By_Range; + + Length : constant Iir_Index32 := Bound.Length; + Assoc : Iir; + Pos : Iir_Index32; + begin + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 0; + while Assoc /= Null_Iir loop + Value := Get_Associated_Expr (Assoc); + loop + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if Pos >= Length then + Error_Msg_Constraint (Assoc); + end if; + Set_Elem (Pos); + Pos := Pos + 1; + when Iir_Kind_Choice_By_Expression => + Set_Elem_By_Expr (Get_Choice_Expression (Assoc)); + when Iir_Kind_Choice_By_Range => + Set_Elem_By_Range (Get_Choice_Range (Assoc)); + when Iir_Kind_Choice_By_Others => + for J in 1 .. Length loop + if Res.Val_Array.V (Orig + J * Step) = null then + Set_Elem (J - 1); + end if; + end loop; + return; + when others => + raise Internal_Error; + end case; + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + exit when not Get_Same_Alternative_Flag (Assoc); + end loop; + end loop; + + -- Check each elements have been set. + -- FIXME: check directly with type. + for J in 1 .. Length loop + if Res.Val_Array.V (Orig + J * Step) = null then + Error_Msg_Constraint (Aggregate); + end if; + end loop; + end Fill_Array_Aggregate_1; + + -- Use expressions from (BLOCK, AGGREGATE) to fill RES. + procedure Fill_Array_Aggregate + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc) + is + Aggr_Type : constant Iir := Get_Type (Aggregate); + El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); + Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); + Nbr_Dim : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Step : Iir_Index32; + begin + Step := Get_Step_For_Dim (Res, 1); + Fill_Array_Aggregate_1 + (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); + end Fill_Array_Aggregate; + + function Execute_Record_Aggregate (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); + + Res: Iir_Value_Literal_Acc; + Expr : Iir; + + procedure Set_Expr (Pos : Iir_Index32) is + El : constant Iir := Get_Nth_Element (List, Natural (Pos - 1)); + begin + Res.Val_Record.V (Pos) := + Execute_Expression_With_Type (Block, Expr, Get_Type (El)); + end Set_Expr; + + Pos : Iir_Index32; + Assoc: Iir; + N_Expr : Iir; + begin + Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); + + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 1; + loop + N_Expr := Get_Associated_Expr (Assoc); + if N_Expr /= Null_Iir then + Expr := N_Expr; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + Set_Expr (Pos); + Pos := Pos + 1; + when Iir_Kind_Choice_By_Name => + Set_Expr (1 + Get_Element_Position (Get_Choice_Name (Assoc))); + when Iir_Kind_Choice_By_Others => + for I in Res.Val_Record.V'Range loop + if Res.Val_Record.V (I) = null then + Set_Expr (I); + end if; + end loop; + when others => + Error_Kind ("execute_record_aggregate", Assoc); + end case; + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + end loop; + return Res; + end Execute_Record_Aggregate; + + function Execute_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + begin + case Get_Kind (Aggregate_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Res : Iir_Value_Literal_Acc; + begin + Res := Create_Array_Bounds_From_Type + (Block, Aggregate_Type, True); + Fill_Array_Aggregate (Block, Aggregate, Res); + return Res; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Execute_Record_Aggregate + (Block, Aggregate, Aggregate_Type); + when others => + Error_Kind ("execute_aggregate", Aggregate_Type); + end case; + end Execute_Aggregate; + + function Execute_Simple_Aggregate (Block: Block_Instance_Acc; Aggr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + List : constant Iir_List := Get_Simple_Aggregate_List (Aggr); + begin + Res := Create_Array_Bounds_From_Type (Block, Get_Type (Aggr), True); + for I in Res.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Expression (Block, Get_Nth_Element (List, Natural (I - 1))); + end loop; + return Res; + end Execute_Simple_Aggregate; + + -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. + -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. + -- EL_TYPE is the type of the array element. + procedure Execute_Name_Array_Aggregate + (Block : Block_Instance_Acc; + Aggregate : Iir; + Res : Iir_Value_Literal_Acc; + Orig : Iir_Index32; + Step : Iir_Index32; + Dim : Iir_Index32; + Nbr_Dim : Iir_Index32; + El_Type : Iir) + is + Value : Iir; + Bound : Iir_Value_Literal_Acc; + + procedure Set_Elem (Pos : Iir_Index32) + is + Val : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + if Dim = Nbr_Dim then + -- VALUE is an expression (which may be an aggregate, but not + -- a sub-aggregate. + Execute_Name_With_Base (Block, Value, null, Val, Is_Sig); + Res.Val_Array.V (1 + Orig + Pos * Step) := Val; + else + -- VALUE is a sub-aggregate. + Execute_Name_Array_Aggregate + (Block, Value, Res, + Orig + Pos * Step, + Step / Res.Bounds.D (Dim + 1).Length, + Dim + 1, Nbr_Dim, El_Type); + end if; + end Set_Elem; + + Assoc : Iir; + Pos : Iir_Index32; + begin + Assoc := Get_Association_Choices_Chain (Aggregate); + Bound := Res.Bounds.D (Dim); + Pos := 0; + while Assoc /= Null_Iir loop + Value := Get_Associated_Expr (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + null; + when Iir_Kind_Choice_By_Expression => + declare + Expr_Pos: Iir_Value_Literal_Acc; + Val : constant Iir := Get_Expression (Assoc); + begin + Expr_Pos := Execute_Expression (Block, Val); + Pos := Get_Index_Offset (Expr_Pos, Bound, Val); + end; + when others => + raise Internal_Error; + end case; + Set_Elem (Pos); + Pos := Pos + 1; + Assoc := Get_Chain (Assoc); + end loop; + end Execute_Name_Array_Aggregate; + + function Execute_Record_Name_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); + Res: Iir_Value_Literal_Acc; + Expr : Iir; + Pos : Iir_Index32; + El_Pos : Iir_Index32; + Is_Sig : Boolean; + Assoc: Iir; + begin + Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); + Assoc := Get_Association_Choices_Chain (Aggregate); + Pos := 0; + loop + Expr := Get_Associated_Expr (Assoc); + if Expr = Null_Iir then + -- List of choices is not allowed. + raise Internal_Error; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + El_Pos := Pos; + Pos := Pos + 1; + when Iir_Kind_Choice_By_Name => + El_Pos := Get_Element_Position (Get_Name (Assoc)); + when Iir_Kind_Choice_By_Others => + raise Internal_Error; + when others => + Error_Kind ("execute_record_name_aggregate", Assoc); + end case; + Execute_Name_With_Base + (Block, Expr, null, Res.Val_Record.V (1 + El_Pos), Is_Sig); + Assoc := Get_Chain (Assoc); + exit when Assoc = Null_Iir; + end loop; + return Res; + end Execute_Record_Name_Aggregate; + + function Execute_Name_Aggregate + (Block: Block_Instance_Acc; + Aggregate: Iir; + Aggregate_Type: Iir) + return Iir_Value_Literal_Acc + is + begin + case Get_Kind (Aggregate_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Res : Iir_Value_Literal_Acc; + El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type); + Index_List : constant Iir_List := + Get_Index_Subtype_List (Aggregate_Type); + Nbr_Dim : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + Step : Iir_Index32; + begin + Res := Create_Array_Bounds_From_Type + (Block, Aggregate_Type, True); + Step := Get_Step_For_Dim (Res, 1); + Execute_Name_Array_Aggregate + (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); + return Res; + end; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Execute_Record_Name_Aggregate + (Block, Aggregate, Aggregate_Type); + when others => + Error_Kind ("execute_name_aggregate", Aggregate_Type); + end case; + end Execute_Name_Aggregate; + + -- Return the indexes range of dimension DIM for type or object PREFIX. + -- DIM starts at 1. + function Execute_Indexes + (Block: Block_Instance_Acc; Prefix: Iir; Dim : Iir_Int64) + return Iir_Value_Literal_Acc + is + begin + case Get_Kind (Prefix) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + declare + Index : Iir; + begin + Index := Get_Nth_Element + (Get_Index_Subtype_List (Get_Type (Prefix)), + Natural (Dim - 1)); + return Execute_Bounds (Block, Index); + end; + when Iir_Kinds_Denoting_Name => + return Execute_Indexes (Block, Get_Named_Entity (Prefix), Dim); + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + Error_Kind ("execute_indexes", Prefix); + when others => + declare + Orig : Iir_Value_Literal_Acc; + begin + Orig := Execute_Name (Block, Prefix, True); + return Orig.Bounds.D (Iir_Index32 (Dim)); + end; + end case; + end Execute_Indexes; + + function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) + return Iir_Value_Literal_Acc + is + Bound : Iir_Value_Literal_Acc; + begin + case Get_Kind (Prefix) is + when Iir_Kind_Range_Expression => + declare + Info : constant Sim_Info_Acc := Get_Info (Prefix); + begin + if Info = null then + Bound := Create_Range_Value + (Execute_Expression (Block, Get_Left_Limit (Prefix)), + Execute_Expression (Block, Get_Right_Limit (Prefix)), + Get_Direction (Prefix)); + elsif Info.Kind = Kind_Object then + Bound := Get_Instance_For_Slot + (Block, Prefix).Objects (Info.Slot); + else + raise Internal_Error; + end if; + end; + + when Iir_Kind_Subtype_Declaration => + return Execute_Bounds (Block, Get_Type (Prefix)); + + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + -- FIXME: move this block before and avoid recursion. + return Execute_Bounds (Block, Get_Range_Constraint (Prefix)); + + when Iir_Kind_Range_Array_Attribute => + declare + Prefix_Val : Iir_Value_Literal_Acc; + Dim : Iir_Int64; + begin + Dim := Get_Value (Get_Parameter (Prefix)); + Prefix_Val := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); + Bound := Prefix_Val; + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + Dim : Iir_Int64; + begin + Dim := Get_Value (Get_Parameter (Prefix)); + Bound := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); + case Bound.Dir is + when Iir_To => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_Downto, Bound.Length); + when Iir_Downto => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_To, Bound.Length); + end case; + end; + + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Integer_Type_Definition => + return Execute_Bounds + (Block, + Get_Range_Constraint (Get_Type (Get_Type_Declarator (Prefix)))); + + when Iir_Kinds_Denoting_Name => + return Execute_Bounds (Block, Get_Named_Entity (Prefix)); + + when others => + -- Error_Kind ("execute_bounds", Get_Kind (Prefix)); + declare + Prefix_Val: Iir_Value_Literal_Acc; + begin + Prefix_Val := Execute_Expression (Block, Prefix); + Bound := Prefix_Val.Bounds.D (1); + end; + end case; + if not Bound.Dir'Valid then + raise Internal_Error; + end if; + return Bound; + end Execute_Bounds; + + -- Perform type conversion as desribed in LRM93 7.3.5 + function Execute_Type_Conversion (Block: Block_Instance_Acc; + Conv : Iir_Type_Conversion; + Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Target_Type : constant Iir := Get_Type (Conv); + Res: Iir_Value_Literal_Acc; + begin + Res := Val; + case Get_Kind (Target_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + case Res.Kind is + when Iir_Value_I64 => + null; + when Iir_Value_F64 => + if Res.F64 > Ghdl_F64 (Iir_Int64'Last) or + Res.F64 < Ghdl_F64 (Iir_Int64'First) + then + Error_Msg_Constraint (Conv); + end if; + Res := Create_I64_Value (Ghdl_I64 (Res.F64)); + when Iir_Value_B1 + | Iir_Value_E32 + | Iir_Value_Range + | Iir_Value_Array + | Iir_Value_Signal + | Iir_Value_Record + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + -- These values are not of abstract numeric type. + raise Internal_Error; + end case; + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + case Res.Kind is + when Iir_Value_F64 => + null; + when Iir_Value_I64 => + Res := Create_F64_Value (Ghdl_F64 (Res.I64)); + when Iir_Value_B1 + | Iir_Value_E32 + | Iir_Value_Range + | Iir_Value_Array + | Iir_Value_Signal + | Iir_Value_Record + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + -- These values are not of abstract numeric type. + raise Internal_Error; + end case; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + -- must be same type. + null; + when Iir_Kind_Array_Type_Definition => + -- LRM93 7.3.5 + -- if the type mark denotes an unconstrained array type and the + -- operand is not a null array, then for each index position, the + -- bounds of the result are obtained by converting the bounds of + -- the operand to the corresponding index type of the target type. + -- FIXME: what is bound conversion ?? + null; + when Iir_Kind_Array_Subtype_Definition => + -- LRM93 7.3.5 + -- If the type mark denotes a constrained array subtype, then the + -- bounds of the result are those imposed by the type mark. + Implicit_Array_Conversion (Block, Res, Target_Type, Conv); + when others => + Error_Kind ("execute_type_conversion", Target_Type); + end case; + Check_Constraints (Block, Res, Target_Type, Conv); + return Res; + end Execute_Type_Conversion; + + -- Decrement VAL. + -- May raise a constraint error using EXPR. + function Execute_Dec (Val : Iir_Value_Literal_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Val.Kind is + when Iir_Value_B1 => + if Val.B1 = False then + Error_Msg_Constraint (Expr); + end if; + Res := Create_B1_Value (False); + when Iir_Value_E32 => + if Val.E32 = 0 then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E32_Value (Val.E32 - 1); + when Iir_Value_I64 => + if Val.I64 = Ghdl_I64'First then + Error_Msg_Constraint (Expr); + end if; + Res := Create_I64_Value (Val.I64 - 1); + when others => + raise Internal_Error; + end case; + return Res; + end Execute_Dec; + + -- Increment VAL. + -- May raise a constraint error using EXPR. + function Execute_Inc (Val : Iir_Value_Literal_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + case Val.Kind is + when Iir_Value_B1 => + if Val.B1 = True then + Error_Msg_Constraint (Expr); + end if; + Res := Create_B1_Value (True); + when Iir_Value_E32 => + if Val.E32 = Ghdl_E32'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_E32_Value (Val.E32 + 1); + when Iir_Value_I64 => + if Val.I64 = Ghdl_I64'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_I64_Value (Val.I64 + 1); + when others => + raise Internal_Error; + end case; + return Res; + end Execute_Inc; + + function Execute_Expression_With_Type + (Block: Block_Instance_Acc; + Expr: Iir; + Expr_Type : Iir) + return Iir_Value_Literal_Acc + is + Res : Iir_Value_Literal_Acc; + begin + if Get_Kind (Expr) = Iir_Kind_Aggregate + and then not Is_Fully_Constrained_Type (Get_Type (Expr)) + then + return Execute_Aggregate (Block, Expr, Expr_Type); + else + Res := Execute_Expression (Block, Expr); + Implicit_Array_Conversion (Block, Res, Expr_Type, Expr); + Check_Constraints (Block, Res, Expr_Type, Expr); + return Res; + end if; + end Execute_Expression_With_Type; + + function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) + return Iir_Value_Literal_Acc + is + Base : constant Iir := Get_Object_Prefix (Expr); + Info : constant Sim_Info_Acc := Get_Info (Base); + Bblk : Block_Instance_Acc; + Base_Val : Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Bblk := Get_Instance_By_Scope_Level (Block, Info.Scope_Level); + Base_Val := Bblk.Objects (Info.Slot + 1); + Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig); + pragma Assert (Is_Sig); + return Res; + end Execute_Signal_Init_Value; + + procedure Execute_Name_With_Base (Block: Block_Instance_Acc; + Expr: Iir; + Base : Iir_Value_Literal_Acc; + Res : out Iir_Value_Literal_Acc; + Is_Sig : out Boolean) + is + Slot_Block: Block_Instance_Acc; + begin + -- Default value + Is_Sig := False; + + case Get_Kind (Expr) is + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + Is_Sig := True; + if Base /= null then + Res := Base; + else + Slot_Block := Get_Instance_For_Slot (Block, Expr); + Res := Slot_Block.Objects (Get_Info (Expr).Slot); + end if; + + when Iir_Kind_Object_Alias_Declaration => + pragma Assert (Base = null); + -- FIXME: add a flag ? + case Get_Kind (Get_Object_Prefix (Expr)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Guard_Signal_Declaration => + Is_Sig := True; + when others => + Is_Sig := False; + end case; + Slot_Block := Get_Instance_For_Slot (Block, Expr); + Res := Slot_Block.Objects (Get_Info (Expr).Slot); + + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Terminal_Declaration + | Iir_Kinds_Quantity_Declaration => + if Base /= null then + Res := Base; + else + declare + Info : constant Sim_Info_Acc := Get_Info (Expr); + begin + Slot_Block := + Get_Instance_By_Scope_Level (Block, Info.Scope_Level); + Res := Slot_Block.Objects (Info.Slot); + end; + end if; + + when Iir_Kind_Indexed_Name => + declare + Prefix: Iir; + Index_List: Iir_List; + Index: Iir; + Nbr_Dimensions: Iir_Index32; + Value: Iir_Value_Literal_Acc; + Pfx: Iir_Value_Literal_Acc; + Pos, Off : Iir_Index32; + begin + Prefix := Get_Prefix (Expr); + Index_List := Get_Index_List (Expr); + Nbr_Dimensions := Iir_Index32 (Get_Nbr_Elements (Index_List)); + Execute_Name_With_Base (Block, Prefix, Base, Pfx, Is_Sig); + for I in 1 .. Nbr_Dimensions loop + Index := Get_Nth_Element (Index_List, Natural (I - 1)); + Value := Execute_Expression (Block, Index); + Off := Get_Index_Offset (Value, Pfx.Bounds.D (I), Expr); + if I = 1 then + Pos := Off; + else + Pos := Pos * Pfx.Bounds.D (I).Length + Off; + end if; + end loop; + Res := Pfx.Val_Array.V (1 + Pos); + -- FIXME: free PFX. + end; + + when Iir_Kind_Slice_Name => + declare + Prefix: Iir; + Prefix_Array: Iir_Value_Literal_Acc; + + Srange : Iir_Value_Literal_Acc; + Index_Order : Order; + -- Lower and upper bounds of the slice. + Low, High: Iir_Index32; + begin + Srange := Execute_Bounds (Block, Get_Suffix (Expr)); + + Prefix := Get_Prefix (Expr); + + Execute_Name_With_Base + (Block, Prefix, Base, Prefix_Array, Is_Sig); + if Prefix_Array = null then + raise Internal_Error; + end if; + + -- LRM93 6.5 + -- It is an error if the direction of the discrete range is not + -- the same as that of the index range of the array denoted by + -- the prefix of the slice name. + if Srange.Dir /= Prefix_Array.Bounds.D (1).Dir then + Error_Msg_Exec ("slice direction mismatch", Expr); + end if; + + -- LRM93 6.5 + -- It is an error if either of the bounds of the + -- discrete range does not belong to the index range of the + -- prefixing array, unless the slice is a null slice. + Index_Order := Compare_Value (Srange.Left, Srange.Right); + if (Srange.Dir = Iir_To and Index_Order = Greater) + or (Srange.Dir = Iir_Downto and Index_Order = Less) + then + -- Null slice. + Low := 1; + High := 0; + else + Low := Get_Index_Offset + (Srange.Left, Prefix_Array.Bounds.D (1), Expr); + High := Get_Index_Offset + (Srange.Right, Prefix_Array.Bounds.D (1), Expr); + end if; + Res := Create_Array_Value (High - Low + 1, 1); + Res.Bounds.D (1) := Srange; + for I in Low .. High loop + Res.Val_Array.V (1 + I - Low) := + Prefix_Array.Val_Array.V (1 + I); + end loop; + end; + + when Iir_Kind_Selected_Element => + declare + Prefix: Iir_Value_Literal_Acc; + Pos: Iir_Index32; + begin + Execute_Name_With_Base + (Block, Get_Prefix (Expr), Base, Prefix, Is_Sig); + Pos := Get_Element_Position (Get_Selected_Element (Expr)); + Res := Prefix.Val_Record.V (Pos + 1); + end; + + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + declare + Prefix: Iir_Value_Literal_Acc; + begin + Prefix := Execute_Name (Block, Get_Prefix (Expr)); + Res := Prefix.Val_Access; + if Res = null then + Error_Msg_Exec ("deferencing null access", Expr); + end if; + end; + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name => + Execute_Name_With_Base + (Block, Get_Named_Entity (Expr), Base, Res, Is_Sig); + + when Iir_Kind_Function_Call => + -- A prefix can be an expression + if Base /= null then + raise Internal_Error; + end if; + Res := Execute_Expression (Block, Expr); + + when Iir_Kind_Aggregate => + Res := Execute_Name_Aggregate (Block, Expr, Get_Type (Expr)); + -- FIXME: is_sig ? + + when others => + Error_Kind ("execute_name_with_base", Expr); + end case; + end Execute_Name_With_Base; + + function Execute_Name (Block: Block_Instance_Acc; + Expr: Iir; + Ref : Boolean := False) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base (Block, Expr, null, Res, Is_Sig); + if not Is_Sig or else Ref then + return Res; + else + return Execute_Signal_Value (Res); + end if; + end Execute_Name; + + function Execute_Image_Attribute (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc + is + Val : Iir_Value_Literal_Acc; + Attr_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + begin + Val := Execute_Expression (Block, Get_Parameter (Expr)); + return String_To_Iir_Value + (Execute_Image_Attribute (Val, Attr_Type)); + end Execute_Image_Attribute; + + function Execute_Value_Attribute (Block: Block_Instance_Acc; + Str_Val : Iir_Value_Literal_Acc; + Expr: Iir) + return Iir_Value_Literal_Acc + is + use Grt_Interface; + use Name_Table; + pragma Unreferenced (Block); + + Expr_Type : constant Iir := Get_Type (Expr); + Res : Iir_Value_Literal_Acc; + + Str_Bnd : aliased Std_String_Bound := Build_Bound (Str_Val); + Str_Str : aliased Std_String_Uncons (1 .. Str_Bnd.Dim_1.Length); + Str : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), + To_Std_String_Boundp (Str_Bnd'Address)); + begin + Set_Std_String_From_Iir_Value (Str, Str_Val); + case Get_Kind (Expr_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + Res := Create_I64_Value + (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access)); + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + Res := Create_F64_Value + (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access)); + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + declare + Is_Real : Boolean; + Lit_Pos : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + Unit_Pos : Ghdl_Index_Type; + Unit_Len : Ghdl_Index_Type; + Mult : Ghdl_I64; + Unit : Iir; + Unit_Id : Name_Id; + begin + Grt.Values.Ghdl_Value_Physical_Split + (Str'Unrestricted_Access, + Is_Real, Lit_Pos, Lit_End, Unit_Pos); + + -- Find unit. + Unit_Len := 0; + Unit_Pos := Unit_Pos + 1; -- From 0 based to 1 based + for I in Unit_Pos .. Str_Bnd.Dim_1.Length loop + exit when Grt.Values.Is_Whitespace (Str_Str (I)); + Unit_Len := Unit_Len + 1; + Str_Str (I) := Grt.Values.To_LC (Str_Str (I)); + end loop; + + Unit := Get_Primary_Unit (Expr_Type); + while Unit /= Null_Iir loop + Unit_Id := Get_Identifier (Unit); + exit when Get_Name_Length (Unit_Id) = Natural (Unit_Len) + and then Image (Unit_Id) = + String (Str_Str (Unit_Pos .. Unit_Pos + Unit_Len - 1)); + Unit := Get_Chain (Unit); + end loop; + + if Unit = Null_Iir then + Error_Msg_Exec ("incorrect unit name", Expr); + end if; + Mult := Ghdl_I64 (Get_Value (Get_Physical_Unit_Value (Unit))); + + Str_Bnd.Dim_1.Length := Lit_End; + if Is_Real then + Res := Create_I64_Value + (Ghdl_I64 + (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access) + * Ghdl_F64 (Mult))); + else + Res := Create_I64_Value + (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access) + * Mult); + end if; + end; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + declare + Lit_Start : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); + Enum : Iir; + Enum_Id : Name_Id; + begin + -- Remove leading and trailing blanks + for I in Str_Str'Range loop + if not Grt.Values.Is_Whitespace (Str_Str (I)) then + Lit_Start := I; + exit; + end if; + end loop; + for I in reverse Lit_Start .. Str_Str'Last loop + if not Grt.Values.Is_Whitespace (Str_Str (I)) then + Lit_End := I; + exit; + end if; + end loop; + + -- Convert to lower case. + for I in Lit_Start .. Lit_End loop + Str_Str (I) := Grt.Values.To_LC (Str_Str (I)); + end loop; + + for I in Natural loop + Enum := Get_Nth_Element (Enums, I); + if Enum = Null_Iir then + Error_Msg_Exec ("incorrect unit name", Expr); + end if; + Enum_Id := Get_Identifier (Enum); + exit when (Get_Name_Length (Enum_Id) = + Natural (Lit_End - Lit_Start + 1)) + and then (Image (Enum_Id) = + String (Str_Str (Lit_Start .. Lit_End))); + end loop; + + return Create_Enum_Value + (Natural (Get_Enum_Pos (Enum)), Expr_Type); + end; + when others => + Error_Kind ("value_attribute", Expr_Type); + end case; + return Res; + end Execute_Value_Attribute; + + function Execute_Path_Instance_Name_Attribute + (Block : Block_Instance_Acc; Attr : Iir) + return Iir_Value_Literal_Acc + is + use Evaluation; + use Grt.Vstrings; + use Name_Table; + + Name : constant Path_Instance_Name_Type := + Get_Path_Instance_Name_Suffix (Attr); + Instance : Block_Instance_Acc; + Rstr : Rstring; + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + if Name.Path_Instance = Null_Iir then + return String_To_Iir_Value (Name.Suffix); + end if; + + Instance := Get_Instance_By_Scope_Level + (Block, Get_Info (Name.Path_Instance).Frame_Scope_Level); + + loop + case Get_Kind (Instance.Label) is + when Iir_Kind_Entity_Declaration => + if Instance.Parent = null then + Prepend (Rstr, Image (Get_Identifier (Instance.Label))); + exit; + end if; + when Iir_Kind_Architecture_Body => + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Image (Get_Identifier (Instance.Label))); + Prepend (Rstr, '('); + end if; + + if Is_Instance or else Instance.Parent = null then + Prepend + (Rstr, + Image (Get_Identifier (Get_Entity (Instance.Label)))); + end if; + if Instance.Parent = null then + Prepend (Rstr, ':'); + exit; + else + Instance := Instance.Parent; + end if; + when Iir_Kind_Block_Statement => + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when Iir_Kind_Iterator_Declaration => + declare + Val : Iir_Value_Literal_Acc; + begin + Val := Execute_Name (Instance, Instance.Label); + Prepend (Rstr, ')'); + Prepend (Rstr, Execute_Image_Attribute + (Val, Get_Type (Instance.Label))); + Prepend (Rstr, '('); + end; + Instance := Instance.Parent; + when Iir_Kind_Generate_Statement => + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when Iir_Kind_Component_Instantiation_Statement => + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, Image (Get_Label (Instance.Label))); + Prepend (Rstr, ':'); + Instance := Instance.Parent; + when others => + Error_Kind ("Execute_Path_Instance_Name_Attribute", + Instance.Label); + end case; + end loop; + declare + Str1 : String (1 .. Length (Rstr)); + Len1 : Natural; + begin + Copy (Rstr, Str1, Len1); + Free (Rstr); + return String_To_Iir_Value (Str1 & ':' & Name.Suffix); + end; + end Execute_Path_Instance_Name_Attribute; + + -- For 'Last_Event and 'Last_Active: convert the absolute last time to + -- a relative delay. + function To_Relative_Time (T : Ghdl_I64) return Iir_Value_Literal_Acc is + A : Ghdl_I64; + begin + if T = -Ghdl_I64'Last then + A := Ghdl_I64'Last; + else + A := Ghdl_I64 (Grt.Types.Current_Time) - T; + end if; + return Create_I64_Value (A); + end To_Relative_Time; + + -- Evaluate an expression. + function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Get_Kind (Expr) is + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Object_Alias_Declaration => + Res := Execute_Name (Block, Expr); + return Res; + + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + return Execute_Name (Block, Expr); + + when Iir_Kinds_Denoting_Name + | Iir_Kind_Attribute_Name => + return Execute_Expression (Block, Get_Named_Entity (Expr)); + + when Iir_Kind_Aggregate => + return Execute_Aggregate (Block, Expr, Get_Type (Expr)); + when Iir_Kind_Simple_Aggregate => + return Execute_Simple_Aggregate (Block, Expr); + + when Iir_Kinds_Dyadic_Operator + | Iir_Kinds_Monadic_Operator => + declare + Imp : Iir; + begin + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Function_Declaration then + return Execute_Function_Call (Block, Expr, Imp); + else + if Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator then + Res := Execute_Implicit_Function + (Block, Expr, Get_Left (Expr), Get_Right (Expr), + Get_Type (Expr)); + else + Res := Execute_Implicit_Function + (Block, Expr, Get_Operand (Expr), Null_Iir, + Get_Type (Expr)); + end if; + return Res; + end if; + end; + + when Iir_Kind_Function_Call => + declare + Imp : constant Iir := + Get_Named_Entity (Get_Implementation (Expr)); + Assoc : Iir; + Args : Iir_Array (0 .. 1); + begin + if Get_Kind (Imp) = Iir_Kind_Function_Declaration then + return Execute_Function_Call (Block, Expr, Imp); + else + Assoc := Get_Parameter_Association_Chain (Expr); + if Assoc /= Null_Iir then + Args (0) := Get_Actual (Assoc); + Assoc := Get_Chain (Assoc); + else + Args (0) := Null_Iir; + end if; + if Assoc /= Null_Iir then + Args (1) := Get_Actual (Assoc); + else + Args (1) := Null_Iir; + end if; + return Execute_Implicit_Function + (Block, Expr, Args (0), Args (1), Get_Type (Expr)); + end if; + end; + + when Iir_Kind_Integer_Literal => + declare + Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); + Lit : constant Iir_Int64 := Get_Value (Expr); + begin + case Get_Info (Lit_Type).Scalar_Mode is + when Iir_Value_I64 => + return Create_I64_Value (Ghdl_I64 (Lit)); + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Floating_Point_Literal => + return Create_F64_Value (Ghdl_F64 (Get_Fp_Value (Expr))); + + when Iir_Kind_Enumeration_Literal => + declare + Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); + Lit : constant Iir_Int32 := Get_Enum_Pos (Expr); + begin + case Get_Info (Lit_Type).Scalar_Mode is + when Iir_Value_B1 => + return Create_B1_Value (Ghdl_B1'Val (Lit)); + when Iir_Value_E32 => + return Create_E32_Value (Ghdl_E32 (Lit)); + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return Create_I64_Value + (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr))); + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return String_To_Enumeration_Array (Block, Expr); + + when Iir_Kind_Null_Literal => + return Null_Lit; + + when Iir_Kind_Overflow_Literal => + Error_Msg_Constraint (Expr); + return null; + + when Iir_Kind_Parenthesis_Expression => + return Execute_Expression (Block, Get_Expression (Expr)); + + when Iir_Kind_Type_Conversion => + return Execute_Type_Conversion + (Block, Expr, + Execute_Expression (Block, Get_Expression (Expr))); + + when Iir_Kind_Qualified_Expression => + Res := Execute_Expression_With_Type + (Block, Get_Expression (Expr), Get_Type (Get_Type_Mark (Expr))); + return Res; + + when Iir_Kind_Allocator_By_Expression => + Res := Execute_Expression (Block, Get_Expression (Expr)); + Res := Unshare_Heap (Res); + return Create_Access_Value (Res); + + when Iir_Kind_Allocator_By_Subtype => + Res := Create_Value_For_Type + (Block, + Get_Type_Of_Subtype_Indication (Get_Subtype_Indication (Expr)), + True); + Res := Unshare_Heap (Res); + return Create_Access_Value (Res); + + when Iir_Kind_Left_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Left_Limit (Res); + + when Iir_Kind_Right_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Right_Limit (Res); + + when Iir_Kind_High_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_High_Limit (Res); + + when Iir_Kind_Low_Type_Attribute => + Res := Execute_Bounds (Block, Get_Prefix (Expr)); + return Execute_Low_Limit (Res); + + when Iir_Kind_High_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_High_Limit (Res); + + when Iir_Kind_Low_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Low_Limit (Res); + + when Iir_Kind_Left_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Left_Limit (Res); + + when Iir_Kind_Right_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Right_Limit (Res); + + when Iir_Kind_Length_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Length (Res); + + when Iir_Kind_Ascending_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Boolean_To_Lit (Res.Dir = Iir_To); + + when Iir_Kind_Event_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Event_Attribute (Res)); + + when Iir_Kind_Active_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Active_Attribute (Res)); + + when Iir_Kind_Driving_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Boolean_To_Lit (Execute_Driving_Attribute (Res)); + + when Iir_Kind_Last_Value_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Execute_Last_Value_Attribute (Res); + + when Iir_Kind_Driving_Value_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return Execute_Driving_Value_Attribute (Res); + + when Iir_Kind_Last_Event_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return To_Relative_Time (Execute_Last_Event_Attribute (Res)); + + when Iir_Kind_Last_Active_Attribute => + Res := Execute_Name (Block, Get_Prefix (Expr), True); + return To_Relative_Time (Execute_Last_Active_Attribute (Res)); + + when Iir_Kind_Val_Attribute => + declare + Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Base_Type : constant Iir := Get_Base_Type (Prefix_Type); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + case Mode is + when Iir_Value_I64 => + null; + when Iir_Value_E32 => + Res := Create_E32_Value (Ghdl_E32 (Res.I64)); + when Iir_Value_B1 => + Res := Create_B1_Value (Ghdl_B1'Val (Res.I64)); + when others => + Error_Kind ("execute_expression(val attribute)", + Prefix_Type); + end case; + Check_Constraints (Block, Res, Prefix_Type, Expr); + return Res; + end; + + when Iir_Kind_Pos_Attribute => + declare + N_Res: Iir_Value_Literal_Acc; + Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); + Base_Type : constant Iir := Get_Base_Type (Prefix_Type); + Mode : constant Iir_Value_Kind := + Get_Info (Base_Type).Scalar_Mode; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + case Mode is + when Iir_Value_I64 => + null; + when Iir_Value_B1 => + N_Res := Create_I64_Value (Ghdl_B1'Pos (Res.B1)); + Res := N_Res; + when Iir_Value_E32 => + N_Res := Create_I64_Value (Ghdl_I64 (Res.E32)); + Res := N_Res; + when others => + Error_Kind ("execute_expression(pos attribute)", + Base_Type); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Succ_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Res := Execute_Inc (Res, Expr); + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + + when Iir_Kind_Pred_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Res := Execute_Dec (Res, Expr); + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + + when Iir_Kind_Leftof_Attribute => + declare + Bound : Iir_Value_Literal_Acc; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Bound := Execute_Bounds + (Block, Get_Type (Get_Prefix (Expr))); + case Bound.Dir is + when Iir_To => + Res := Execute_Dec (Res, Expr); + when Iir_Downto => + Res := Execute_Inc (Res, Expr); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Rightof_Attribute => + declare + Bound : Iir_Value_Literal_Acc; + begin + Res := Execute_Expression (Block, Get_Parameter (Expr)); + Bound := Execute_Bounds + (Block, Get_Type (Get_Prefix (Expr))); + case Bound.Dir is + when Iir_Downto => + Res := Execute_Dec (Res, Expr); + when Iir_To => + Res := Execute_Inc (Res, Expr); + end case; + Check_Constraints (Block, Res, Get_Type (Expr), Expr); + return Res; + end; + + when Iir_Kind_Image_Attribute => + return Execute_Image_Attribute (Block, Expr); + + when Iir_Kind_Value_Attribute => + Res := Execute_Expression (Block, Get_Parameter (Expr)); + return Execute_Value_Attribute (Block, Res, Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + return Execute_Path_Instance_Name_Attribute (Block, Expr); + + when others => + Error_Kind ("execute_expression", Expr); + end case; + end Execute_Expression; + + procedure Execute_Dyadic_Association + (Out_Block: Block_Instance_Acc; + In_Block: Block_Instance_Acc; + Expr : Iir; + Inter_Chain: Iir) + is + Inter: Iir; + Val: Iir_Value_Literal_Acc; + begin + Inter := Inter_Chain; + for I in 0 .. 1 loop + if I = 0 then + Val := Execute_Expression (Out_Block, Get_Left (Expr)); + else + Val := Execute_Expression (Out_Block, Get_Right (Expr)); + end if; + Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); + Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); + + Elaboration.Create_Object (In_Block, Inter); + In_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + Inter := Get_Chain (Inter); + end loop; + end Execute_Dyadic_Association; + + procedure Execute_Monadic_Association + (Out_Block: Block_Instance_Acc; + In_Block: Block_Instance_Acc; + Expr : Iir; + Inter: Iir) + is + Val: Iir_Value_Literal_Acc; + begin + Val := Execute_Expression (Out_Block, Get_Operand (Expr)); + Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); + Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); + + Elaboration.Create_Object (In_Block, Inter); + In_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + end Execute_Monadic_Association; + + -- Create a block instance for subprogram IMP. + function Create_Subprogram_Instance (Instance : Block_Instance_Acc; + Imp : Iir) + return Block_Instance_Acc + is + Func_Info : constant Sim_Info_Acc := Get_Info (Imp); + + subtype Block_Type is Block_Instance_Type (Func_Info.Nbr_Objects); + function To_Block_Instance_Acc is new + Ada.Unchecked_Conversion (System.Address, Block_Instance_Acc); + function Alloc_Block_Instance is new + Alloc_On_Pool_Addr (Block_Type); + + Up_Block: Block_Instance_Acc; + Res : Block_Instance_Acc; + begin + Up_Block := Get_Instance_By_Scope_Level + (Instance, Func_Info.Frame_Scope_Level - 1); + + Res := To_Block_Instance_Acc + (Alloc_Block_Instance + (Instance_Pool, + Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects, + Scope_Level => Func_Info.Frame_Scope_Level, + Up_Block => Up_Block, + Label => Imp, + Stmt => Null_Iir, + Parent => Instance, + Children => null, + Brother => null, + Marker => Empty_Marker, + Objects => (others => null), + Elab_Objects => 0, + In_Wait_Flag => False, + Actuals_Ref => null, + Result => null))); + return Res; + end Create_Subprogram_Instance; + + -- Destroy a dynamic block_instance. + procedure Execute_Subprogram_Call_Final (Instance : Block_Instance_Acc) + is + Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); + begin + Finalize_Declarative_Part + (Instance, Get_Declaration_Chain (Subprg_Body)); + end Execute_Subprogram_Call_Final; + + function Execute_Function_Body (Instance : Block_Instance_Acc; Func : Iir) + return Iir_Value_Literal_Acc + is + Subprg_Body : constant Iir := Get_Subprogram_Body (Func); + Res : Iir_Value_Literal_Acc; + begin + Current_Process.Instance := Instance; + + Elaborate_Declarative_Part + (Instance, Get_Declaration_Chain (Subprg_Body)); + + -- execute statements + Instance.Stmt := Get_Sequential_Statement_Chain (Subprg_Body); + Execute_Sequential_Statements (Current_Process); + pragma Assert (Current_Process.Instance = Instance); + + if Instance.Result = null then + Error_Msg_Exec + ("function scope exited without a return statement", Func); + end if; + + -- Free variables, slots... + -- Need to copy the return value, because it can contains values from + -- arguments. + Res := Instance.Result; + + Current_Process.Instance := Instance.Parent; + Execute_Subprogram_Call_Final (Instance); + + return Res; + end Execute_Function_Body; + + function Execute_Assoc_Function_Conversion + (Block : Block_Instance_Acc; Func : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Inter : Iir; + Instance : Block_Instance_Acc; + Res : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + Mark (Marker, Instance_Pool.all); + + -- Create an instance for this function. + Instance := Create_Subprogram_Instance (Block, Func); + + Inter := Get_Interface_Declaration_Chain (Func); + Elaboration.Create_Object (Instance, Inter); + -- FIXME: implicit conversion + Instance.Objects (Get_Info (Inter).Slot) := Val; + + Res := Execute_Function_Body (Instance, Func); + Res := Unshare (Res, Expr_Pool'Access); + Release (Marker, Instance_Pool.all); + return Res; + end Execute_Assoc_Function_Conversion; + + function Execute_Assoc_Conversion + (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Ent : Iir; + begin + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + -- FIXME: shouldn't CONV always be a denoting_name ? + return Execute_Assoc_Function_Conversion + (Block, Get_Named_Entity (Get_Implementation (Conv)), Val); + when Iir_Kind_Type_Conversion => + -- FIXME: shouldn't CONV always be a denoting_name ? + return Execute_Type_Conversion (Block, Conv, Val); + when Iir_Kinds_Denoting_Name => + Ent := Get_Named_Entity (Conv); + if Get_Kind (Ent) = Iir_Kind_Function_Declaration then + return Execute_Assoc_Function_Conversion (Block, Ent, Val); + elsif Get_Kind (Ent) in Iir_Kinds_Type_Declaration then + return Execute_Type_Conversion (Block, Ent, Val); + else + Error_Kind ("execute_assoc_conversion(1)", Ent); + end if; + when others => + Error_Kind ("execute_assoc_conversion(2)", Conv); + end case; + end Execute_Assoc_Conversion; + + -- Establish correspondance for association list ASSOC_LIST from block + -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK. + procedure Execute_Association + (Out_Block: Block_Instance_Acc; + Subprg_Block: Block_Instance_Acc; + Assoc_Chain: Iir) + is + Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain); + Assoc: Iir; + Actual : Iir; + Inter: Iir; + Formal : Iir; + Conv : Iir; + Val: Iir_Value_Literal_Acc; + Assoc_Idx : Iir_Index32; + Last_Individual : Iir_Value_Literal_Acc; + Mode : Iir_Mode; + Marker : Mark_Type; + begin + Subprg_Block.Actuals_Ref := null; + Mark (Marker, Expr_Pool); + + Assoc := Assoc_Chain; + Assoc_Idx := 1; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + Inter := Get_Association_Interface (Assoc); + + -- Extract the actual value. + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_Open => + -- Not allowed in individual association. + pragma Assert (Formal = Inter); + pragma Assert (Get_Whole_Association_Flag (Assoc)); + Actual := Get_Default_Value (Inter); + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + when Iir_Kind_Association_Element_By_Individual => + -- FIXME: signals ? + pragma Assert + (Get_Kind (Inter) /= Iir_Kind_Signal_Interface_Declaration); + Last_Individual := Create_Value_For_Type + (Out_Block, Get_Actual_Type (Assoc), False); + Last_Individual := Unshare (Last_Individual, Instance_Pool); + + Elaboration.Create_Object (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual; + goto Continue; + when others => + Error_Kind ("execute_association(1)", Assoc); + end case; + + -- Compute actual value. + case Get_Kind (Inter) is + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Val := Execute_Expression (Out_Block, Actual); + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + Check_Constraints (Subprg_Block, Val, Get_Type (Formal), Assoc); + when Iir_Kind_Signal_Interface_Declaration => + Val := Execute_Name (Out_Block, Actual, True); + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + when Iir_Kind_Variable_Interface_Declaration => + Mode := Get_Mode (Inter); + if Mode = Iir_In_Mode then + -- FIXME: Ref ? + Val := Execute_Expression (Out_Block, Actual); + else + Val := Execute_Name (Out_Block, Actual, False); + end if; + + -- FIXME: by value for scalars ? + + -- Keep ref for back-copy + if Mode /= Iir_In_Mode then + if Subprg_Block.Actuals_Ref = null then + declare + subtype Actuals_Ref_Type is + Value_Array (Iir_Index32 (Nbr_Assoc)); + function To_Value_Array_Acc is new + Ada.Unchecked_Conversion (System.Address, + Value_Array_Acc); + function Alloc_Actuals_Ref is new + Alloc_On_Pool_Addr (Actuals_Ref_Type); + + begin + Subprg_Block.Actuals_Ref := To_Value_Array_Acc + (Alloc_Actuals_Ref + (Instance_Pool, + Actuals_Ref_Type'(Len => Iir_Index32 (Nbr_Assoc), + V => (others => null)))); + end; + end if; + Subprg_Block.Actuals_Ref.V (Assoc_Idx) := + Unshare_Bounds (Val, Instance_Pool); + end if; + + if Mode = Iir_Out_Mode then + if Get_Out_Conversion (Assoc) /= Null_Iir then + -- For an OUT variable using an out conversion, don't + -- associate with the actual, create a temporary value. + Val := Create_Value_For_Type + (Out_Block, Get_Type (Formal), True); + elsif Get_Kind (Get_Type (Formal)) in + Iir_Kinds_Scalar_Type_Definition + then + -- These are passed by value. Must be reset. + Val := Create_Value_For_Type + (Out_Block, Get_Type (Formal), True); + end if; + else + if Get_Kind (Assoc) = + Iir_Kind_Association_Element_By_Expression + then + Conv := Get_In_Conversion (Assoc); + if Conv /= Null_Iir then + Val := Execute_Assoc_Conversion + (Subprg_Block, Conv, Val); + end if; + end if; + + -- FIXME: check constraints ? + end if; + + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + + when others => + Error_Kind ("execute_association(2)", Inter); + end case; + + if Get_Whole_Association_Flag (Assoc) then + case Get_Kind (Inter) is + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + -- FIXME: Arguments are passed by copy. + Elaboration.Create_Object (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := + Unshare (Val, Instance_Pool); + when Iir_Kind_Signal_Interface_Declaration => + Elaboration.Create_Signal (Subprg_Block, Inter); + Subprg_Block.Objects (Get_Info (Inter).Slot) := + Unshare_Bounds (Val, Instance_Pool); + when others => + Error_Kind ("execute_association", Inter); + end case; + else + declare + Targ : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base + (Subprg_Block, Formal, Last_Individual, Targ, Is_Sig); + Store (Targ, Val); + end; + end if; + + << Continue >> null; + Assoc := Get_Chain (Assoc); + Assoc_Idx := Assoc_Idx + 1; + end loop; + + Release (Marker, Expr_Pool); + end Execute_Association; + + procedure Execute_Back_Association (Instance : Block_Instance_Acc) + is + Proc : Iir; + Assoc: Iir; + Inter: Iir; + Formal : Iir; + Assoc_Idx : Iir_Index32; + begin + Proc := Get_Procedure_Call (Instance.Parent.Stmt); + Assoc := Get_Parameter_Association_Chain (Proc); + Assoc_Idx := 1; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then + Formal := Get_Formal (Assoc); + Inter := Get_Association_Interface (Assoc); + case Get_Kind (Inter) is + when Iir_Kind_Variable_Interface_Declaration => + if Get_Mode (Inter) /= Iir_In_Mode + and then Get_Kind (Get_Type (Inter)) /= + Iir_Kind_File_Type_Definition + then + -- For out/inout variable interface, the value must + -- be copied (FIXME: unless when passed by reference ?). + declare + Targ : constant Iir_Value_Literal_Acc := + Instance.Actuals_Ref.V (Assoc_Idx); + Base : constant Iir_Value_Literal_Acc := + Instance.Objects (Get_Info (Inter).Slot); + Val : Iir_Value_Literal_Acc; + Conv : Iir; + Is_Sig : Boolean; + Expr_Mark : Mark_Type; + begin + Mark (Expr_Mark, Expr_Pool); + + -- Extract for individual association. + Execute_Name_With_Base + (Instance, Formal, Base, Val, Is_Sig); + Conv := Get_Out_Conversion (Assoc); + if Conv /= Null_Iir then + Val := Execute_Assoc_Conversion + (Instance, Conv, Val); + -- FIXME: free val ? + end if; + Store (Targ, Val); + + Release (Expr_Mark, Expr_Pool); + end; + end if; + when Iir_Kind_File_Interface_Declaration => + null; + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration => + null; + when others => + Error_Kind ("execute_back_association", Inter); + end case; + end if; + Assoc := Get_Chain (Assoc); + Assoc_Idx := Assoc_Idx + 1; + end loop; + end Execute_Back_Association; + + -- When a subprogram of a protected type is called, a link to the object + -- must be passed. This procedure modifies the up_link of SUBPRG_BLOCK to + -- point to the block of the object (extracted from CALL and BLOCK). + -- This change doesn't modify the parent (so that the activation chain is + -- not changed). + procedure Adjust_Up_Link_For_Protected_Object + (Block: Block_Instance_Acc; Call: Iir; Subprg_Block : Block_Instance_Acc) + is + Meth_Obj : constant Iir := Get_Method_Object (Call); + Obj : Iir_Value_Literal_Acc; + Obj_Block : Block_Instance_Acc; + begin + if Meth_Obj /= Null_Iir then + Obj := Execute_Name (Block, Meth_Obj, True); + Obj_Block := Protected_Table.Table (Obj.Prot); + Subprg_Block.Up_Block := Obj_Block; + end if; + end Adjust_Up_Link_For_Protected_Object; + + function Execute_Foreign_Function_Call + (Block: Block_Instance_Acc; Expr : Iir; Imp : Iir) + return Iir_Value_Literal_Acc + is + pragma Unreferenced (Block); + begin + case Get_Identifier (Imp) is + when Std_Names.Name_Get_Resolution_Limit => + return Create_I64_Value + (Ghdl_I64 + (Evaluation.Get_Physical_Value (Std_Package.Time_Base))); + when others => + Error_Msg_Exec ("unsupported foreign function call", Expr); + end case; + return null; + end Execute_Foreign_Function_Call; + + -- BLOCK is the block instance in which the function call appears. + function Execute_Function_Call + (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) + return Iir_Value_Literal_Acc + is + Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); + Subprg_Block: Block_Instance_Acc; + Assoc_Chain: Iir; + Res : Iir_Value_Literal_Acc; + begin + Mark (Block.Marker, Instance_Pool.all); + + Subprg_Block := Create_Subprogram_Instance (Block, Imp); + + case Get_Kind (Expr) is + when Iir_Kind_Function_Call => + Adjust_Up_Link_For_Protected_Object (Block, Expr, Subprg_Block); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Execute_Association (Block, Subprg_Block, Assoc_Chain); + -- No out/inout interface for functions. + pragma Assert (Subprg_Block.Actuals_Ref = null); + when Iir_Kinds_Dyadic_Operator => + Execute_Dyadic_Association + (Block, Subprg_Block, Expr, Inter_Chain); + when Iir_Kinds_Monadic_Operator => + Execute_Monadic_Association + (Block, Subprg_Block, Expr, Inter_Chain); + when others => + Error_Kind ("execute_subprogram_call_init", Expr); + end case; + + if Get_Foreign_Flag (Imp) then + Res := Execute_Foreign_Function_Call (Subprg_Block, Expr, Imp); + else + Res := Execute_Function_Body (Subprg_Block, Imp); + end if; + + -- Unfortunately, we don't know where the result has been allocated, + -- so copy it before releasing the instance pool. + Res := Unshare (Res, Expr_Pool'Access); + + Release (Block.Marker, Instance_Pool.all); + + return Res; + end Execute_Function_Call; + + -- Slide an array VALUE using bounds from REF_VALUE. Do not modify + -- VALUE if not an array. + procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; + Ref_Value : Iir_Value_Literal_Acc; + Expr : Iir) + is + Res : Iir_Value_Literal_Acc; + begin + if Value.Kind /= Iir_Value_Array then + return; + end if; + Res := Create_Array_Value (Value.Bounds.Nbr_Dims); + Res.Val_Array := Value.Val_Array; + for I in Value.Bounds.D'Range loop + if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + return; + end if; + Res.Bounds.D (I) := Ref_Value.Bounds.D (I); + end loop; + Value := Res; + end Implicit_Array_Conversion; + + procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; + Value : in out Iir_Value_Literal_Acc; + Ref_Type : Iir; + Expr : Iir) + is + Ref_Value : Iir_Value_Literal_Acc; + begin + -- Do array conversion only if REF_TYPE is a constrained array type + -- definition. + if Value.Kind /= Iir_Value_Array then + return; + end if; + if Get_Constraint_State (Ref_Type) /= Fully_Constrained then + return; + end if; + Ref_Value := Create_Array_Bounds_From_Type (Instance, Ref_Type, True); + for I in Value.Bounds.D'Range loop + if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + return; + end if; + end loop; + Ref_Value.Val_Array.V := Value.Val_Array.V; + Value := Ref_Value; + end Implicit_Array_Conversion; + + procedure Check_Array_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; + Expr: Iir) + is + Index_List: Iir_List; + Element_Subtype: Iir; + New_Bounds : Iir_Value_Literal_Acc; + begin + -- Nothing to check for unconstrained arrays. + if not Get_Index_Constraint_Flag (Def) then + return; + end if; + + Index_List := Get_Index_Subtype_List (Def); + for I in Value.Bounds.D'Range loop + New_Bounds := Execute_Bounds + (Instance, Get_Nth_Element (Index_List, Natural (I - 1))); + if not Is_Equal (Value.Bounds.D (I), New_Bounds) then + Error_Msg_Constraint (Expr); + return; + end if; + end loop; + + if Boolean'(False) then + Index_List := Get_Index_List (Def); + Element_Subtype := Get_Element_Subtype (Def); + for I in Value.Val_Array.V'Range loop + Check_Constraints + (Instance, Value.Val_Array.V (I), Element_Subtype, Expr); + end loop; + end if; + end Check_Array_Constraints; + + -- Check DEST and SRC are array compatible. + procedure Check_Array_Match + (Instance: Block_Instance_Acc; + Dest: Iir_Value_Literal_Acc; + Src : Iir_Value_Literal_Acc; + Expr: Iir) + is + pragma Unreferenced (Instance); + begin + for I in Dest.Bounds.D'Range loop + if Dest.Bounds.D (I).Length /= Src.Bounds.D (I).Length then + Error_Msg_Constraint (Expr); + exit; + end if; + end loop; + end Check_Array_Match; + pragma Unreferenced (Check_Array_Match); + + procedure Check_Constraints + (Instance: Block_Instance_Acc; + Value: Iir_Value_Literal_Acc; + Def: Iir; + Expr: Iir) + is + Base_Type : constant Iir := Get_Base_Type (Def); + High, Low: Iir_Value_Literal_Acc; + Bound : Iir_Value_Literal_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + Bound := Execute_Bounds (Instance, Def); + if Bound.Dir = Iir_To then + High := Bound.Right; + Low := Bound.Left; + else + High := Bound.Left; + Low := Bound.Right; + end if; + case Get_Info (Base_Type).Scalar_Mode is + when Iir_Value_I64 => + if Value.I64 in Low.I64 .. High.I64 then + return; + end if; + when Iir_Value_E32 => + if Value.E32 in Low.E32 .. High.E32 then + return; + end if; + when Iir_Value_F64 => + if Value.F64 in Low.F64 .. High.F64 then + return; + end if; + when Iir_Value_B1 => + if Value.B1 in Low.B1 .. High.B1 then + return; + end if; + when others => + raise Internal_Error; + end case; + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + Check_Array_Constraints (Instance, Value, Def, Expr); + return; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El: Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Check_Constraints + (Instance, + Value.Val_Record.V (Get_Element_Position (El) + 1), + Get_Type (El), + Expr); + end loop; + end; + return; + when Iir_Kind_Integer_Type_Definition => + return; + when Iir_Kind_Floating_Type_Definition => + return; + when Iir_Kind_Physical_Type_Definition => + return; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return; + when Iir_Kind_File_Type_Definition => + return; + when others => + Error_Kind ("check_constraints", Def); + end case; + Error_Msg_Constraint (Expr); + end Check_Constraints; + + function Execute_Resolution_Function + (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Inter : Iir; + Instance : Block_Instance_Acc; + begin + -- Create a frame for this function. + Instance := Create_Subprogram_Instance (Block, Imp); + + Inter := Get_Interface_Declaration_Chain (Imp); + Elaboration.Create_Object (Instance, Inter); + Instance.Objects (Get_Info (Inter).Slot) := Arr; + + return Execute_Function_Body (Instance, Imp); + end Execute_Resolution_Function; + + procedure Execute_Signal_Assignment + (Instance: Block_Instance_Acc; + Stmt: Iir_Signal_Assignment_Statement) + is + Wf : constant Iir_Waveform_Element := Get_Waveform_Chain (Stmt); + Nbr_We : constant Natural := Get_Chain_Length (Wf); + + Transactions : Transaction_Type (Nbr_We); + + We: Iir_Waveform_Element; + Res: Iir_Value_Literal_Acc; + Rdest: Iir_Value_Literal_Acc; + Targ_Type : Iir; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + + Rdest := Execute_Name (Instance, Get_Target (Stmt), True); + Targ_Type := Get_Type (Get_Target (Stmt)); + + -- Disconnection statement. + if Wf = Null_Iir then + Disconnect_Signal (Rdest); + Release (Marker, Expr_Pool); + return; + end if; + + Transactions.Stmt := Stmt; + + -- LRM93 8.4.1 + -- Evaluation of a waveform consists of the evaluation of each waveform + -- elements in the waveform. + We := Wf; + for I in Transactions.Els'Range loop + declare + Trans : Transaction_El_Type renames Transactions.Els (I); + begin + if Get_Time (We) /= Null_Iir then + Res := Execute_Expression (Instance, Get_Time (We)); + -- LRM93 8.4.1 + -- It is an error if the time expression in a waveform element + -- evaluates to a negative value. + if Res.I64 < 0 then + Error_Msg_Exec ("time value is negative", Get_Time (We)); + end if; + Trans.After := Std_Time (Res.I64); + else + -- LRM93 8.4.1 + -- If the after clause of a waveform element is not present, + -- then an implicit "after 0 ns" is assumed. + Trans.After := 0; + end if; + + -- LRM93 8.4.1 + -- It is an error if the sequence of new transactions is not in + -- ascending order with respect to time. + if I > 1 + and then Trans.After <= Transactions.Els (I - 1).After + then + Error_Msg_Exec + ("sequence not in ascending order with respect to time", We); + end if; + + if Get_Kind (Get_We_Value (We)) = Iir_Kind_Null_Literal then + -- null transaction. + Trans.Value := null; + else + -- LRM93 8.4.1 + -- For the first form of waveform element, the value component + -- of the transaction is determined by the value expression in + -- the waveform element. + Trans.Value := Execute_Expression_With_Type + (Instance, Get_We_Value (We), Targ_Type); + end if; + end; + We := Get_Chain (We); + end loop; + pragma Assert (We = Null_Iir); + + case Get_Delay_Mechanism (Stmt) is + when Iir_Transport_Delay => + Transactions.Reject := 0; + when Iir_Inertial_Delay => + -- LRM93 8.4 + -- or, in the case that a pulse rejection limit is specified, + -- a pulse whose duration is shorter than that limit will not + -- be transmitted. + -- Every inertially delayed signal assignment has a pulse + -- rejection limit. + if Get_Reject_Time_Expression (Stmt) /= Null_Iir then + -- LRM93 8.4 + -- If the delay mechanism specifies inertial delay, and if the + -- reserved word reject followed by a time expression is + -- present, then the time expression specifies the pulse + -- rejection limit. + Res := Execute_Expression + (Instance, Get_Reject_Time_Expression (Stmt)); + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any + -- inertially delayed signal assignement statement is either + -- negative ... + if Res.I64 < 0 then + Error_Msg_Exec ("reject time negative", Stmt); + end if; + -- LRM93 8.4 + -- ... or greather than the time expression associated with + -- the first waveform element. + Transactions.Reject := Std_Time (Res.I64); + if Transactions.Reject > Transactions.Els (1).After then + Error_Msg_Exec + ("reject time greather than time expression", Stmt); + end if; + else + -- LRM93 8.4 + -- In all other cases, the pulse rejection limit is the time + -- expression associated ith the first waveform element. + Transactions.Reject := Transactions.Els (1).After; + end if; + end case; + + -- FIXME: slice Transactions to remove transactions after end of time. + Assign_Value_To_Signal (Instance, Rdest, Transactions); + + Release (Marker, Expr_Pool); + end Execute_Signal_Assignment; + + procedure Assign_Simple_Value_To_Object + (Instance: Block_Instance_Acc; + Dest: Iir_Value_Literal_Acc; + Dest_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + begin + if Dest.Kind /= Value.Kind then + raise Internal_Error; -- literal kind mismatch. + end if; + + Check_Constraints (Instance, Value, Dest_Type, Stmt); + + Store (Dest, Value); + end Assign_Simple_Value_To_Object; + + procedure Assign_Array_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Depth: Natural; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + Element_Type: Iir; + begin + if Target.Val_Array.Len /= Value.Val_Array.Len then + -- Dimension mismatch. + raise Program_Error; + end if; + if Depth = Get_Nbr_Elements (Get_Index_List (Target_Type)) then + Element_Type := Get_Element_Subtype (Target_Type); + for I in Target.Val_Array.V'Range loop + Assign_Value_To_Object (Instance, + Target.Val_Array.V (I), + Element_Type, + Value.Val_Array.V (I), + Stmt); + end loop; + else + for I in Target.Val_Array.V'Range loop + Assign_Array_Value_To_Object (Instance, + Target.Val_Array.V (I), + Target_Type, + Depth + 1, + Value.Val_Array.V (I), + Stmt); + end loop; + end if; + end Assign_Array_Value_To_Object; + + procedure Assign_Record_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + Element_Type: Iir; + List : Iir_List; + Element: Iir_Element_Declaration; + Pos : Iir_Index32; + begin + if Target.Val_Record.Len /= Value.Val_Record.Len then + -- Dimension mismatch. + raise Program_Error; + end if; + List := Get_Elements_Declaration_List (Target_Type); + for I in Natural loop + Element := Get_Nth_Element (List, I); + exit when Element = Null_Iir; + Element_Type := Get_Type (Element); + Pos := Get_Element_Position (Element); + Assign_Value_To_Object (Instance, + Target.Val_Record.V (1 + Pos), + Element_Type, + Value.Val_Record.V (1 + Pos), + Stmt); + end loop; + end Assign_Record_Value_To_Object; + + procedure Assign_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + begin + case Target.Kind is + when Iir_Value_Array => + Assign_Array_Value_To_Object + (Instance, Target, Target_Type, 1, Value, Stmt); + when Iir_Value_Record => + Assign_Record_Value_To_Object + (Instance, Target, Target_Type, Value, Stmt); + when Iir_Value_Scalars + | Iir_Value_Access => + Assign_Simple_Value_To_Object + (Instance, Target, Target_Type, Value, Stmt); + when Iir_Value_File + | Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Range + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Assign_Value_To_Object; + + -- Display a message when an assertion has failed. + -- REPORT is the value (string) to display, or null to use default message. + -- SEVERITY is the severity or null to use default (error). + -- STMT is used to display location. + procedure Execute_Failed_Assertion (Report : String; + Severity : Natural; + Stmt: Iir) is + begin + -- LRM93 8.2 + -- The error message consists of at least: + + -- 4: name of the design unit containing the assertion. + Disp_Iir_Location (Stmt); + + -- 1: an indication that this message is from an assertion. + Put (Standard_Error, "(assertion "); + + -- 2: the value of the severity level. + case Severity is + when 0 => + Put (Standard_Error, "note"); + when 1 => + Put (Standard_Error, "warning"); + when 2 => + Put (Standard_Error, "error"); + when 3 => + Put (Standard_Error, "failure"); + when others => + Error_Internal (Null_Iir, "execute_failed_assertion"); + end case; + if Disp_Time_Before_Values then + Put (Standard_Error, " at "); + Grt.Astdio.Put_Time (Grt.Stdio.stderr, Current_Time); + end if; + Put (Standard_Error, "): "); + + -- 3: the value of the message string. + Put_Line (Standard_Error, Report); + + -- Stop execution if the severity is too high. + if Severity >= Grt.Options.Severity_Level then + Debug (Reason_Assert); + Grt.Errors.Fatal_Error; + end if; + end Execute_Failed_Assertion; + + procedure Execute_Failed_Assertion (Report : Iir_Value_Literal_Acc; + Severity : Natural; + Stmt: Iir) is + begin + if Report /= null then + declare + Msg : String (1 .. Natural (Report.Val_Array.Len)); + begin + for I in Report.Val_Array.V'Range loop + Msg (Positive (I)) := + Character'Val (Report.Val_Array.V (I).E32); + end loop; + Execute_Failed_Assertion (Msg, Severity, Stmt); + end; + else + -- The default value for the message string is: + -- "Assertion violation.". + -- Does the message string include quotes ? + Execute_Failed_Assertion ("Assertion violation.", Severity, Stmt); + end if; + end Execute_Failed_Assertion; + + procedure Execute_Report_Statement + (Instance: Block_Instance_Acc; Stmt: Iir; Default_Severity : Natural) + is + Expr: Iir; + Report, Severity_Lit: Iir_Value_Literal_Acc; + Severity : Natural; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + Expr := Get_Report_Expression (Stmt); + if Expr /= Null_Iir then + Report := Execute_Expression (Instance, Expr); + else + Report := null; + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr /= Null_Iir then + Severity_Lit := Execute_Expression (Instance, Expr); + Severity := Natural'Val (Severity_Lit.E32); + else + Severity := Default_Severity; + end if; + Execute_Failed_Assertion (Report, Severity, Stmt); + Release (Marker, Expr_Pool); + end Execute_Report_Statement; + + function Is_In_Choice + (Instance: Block_Instance_Acc; + Choice: Iir; + Expr: Iir_Value_Literal_Acc) + return Boolean + is + Res : Boolean; + begin + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + return True; + when Iir_Kind_Choice_By_Expression => + declare + Expr1: Iir_Value_Literal_Acc; + begin + Expr1 := Execute_Expression + (Instance, Get_Choice_Expression (Choice)); + Res := Is_Equal (Expr, Expr1); + return Res; + end; + when Iir_Kind_Choice_By_Range => + declare + A_Range : Iir_Value_Literal_Acc; + begin + A_Range := Execute_Bounds + (Instance, Get_Choice_Range (Choice)); + Res := Is_In_Range (Expr, A_Range); + end; + return Res; + when others => + Error_Kind ("is_in_choice", Choice); + end case; + end Is_In_Choice; + + -- Return TRUE iff VAL is in the range defined by BOUNDS. + function Is_In_Range (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc) + return Boolean + is + Max, Min : Iir_Value_Literal_Acc; + begin + case Bounds.Dir is + when Iir_To => + Min := Bounds.Left; + Max := Bounds.Right; + when Iir_Downto => + Min := Bounds.Right; + Max := Bounds.Left; + end case; + + case Val.Kind is + when Iir_Value_E32 => + return Val.E32 >= Min.E32 and Val.E32 <= Max.E32; + when Iir_Value_B1 => + return Val.B1 >= Min.B1 and Val.B1 <= Max.B1; + when Iir_Value_I64 => + return Val.I64 >= Min.I64 and Val.I64 <= Max.I64; + when others => + raise Internal_Error; + return False; + end case; + end Is_In_Range; + + -- Increment or decrement VAL according to BOUNDS.DIR. + -- FIXME: use increment ? + procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; + Bounds : Iir_Value_Literal_Acc) + is + begin + case Val.Kind is + when Iir_Value_E32 => + case Bounds.Dir is + when Iir_To => + Val.E32 := Val.E32 + 1; + when Iir_Downto => + Val.E32 := Val.E32 - 1; + end case; + when Iir_Value_B1 => + case Bounds.Dir is + when Iir_To => + Val.B1 := True; + when Iir_Downto => + Val.B1 := False; + end case; + when Iir_Value_I64 => + case Bounds.Dir is + when Iir_To => + Val.I64 := Val.I64 + 1; + when Iir_Downto => + Val.I64 := Val.I64 - 1; + end case; + when others => + raise Internal_Error; + end case; + end Update_Loop_Index; + + procedure Finalize_For_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) + is + begin + Destroy_Iterator_Declaration + (Instance, Get_Parameter_Specification (Stmt)); + end Finalize_For_Loop_Statement; + + procedure Finalize_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) + is + begin + if Get_Kind (Stmt) = Iir_Kind_For_Loop_Statement then + Finalize_For_Loop_Statement (Instance, Stmt); + end if; + end Finalize_Loop_Statement; + + procedure Execute_For_Loop_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir_For_Loop_Statement := Instance.Stmt; + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Bounds : Iir_Value_Literal_Acc; + Index : Iir_Value_Literal_Acc; + Stmt_Chain : Iir; + Is_Nul : Boolean; + Marker : Mark_Type; + begin + -- Elaborate the iterator (and its type). + Elaborate_Declaration (Instance, Iterator); + + -- Extract bounds. + Mark (Marker, Expr_Pool); + Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); + Index := Instance.Objects (Get_Info (Iterator).Slot); + Store (Index, Bounds.Left); + Is_Nul := Is_Nul_Range (Bounds); + Release (Marker, Expr_Pool); + + if Is_Nul then + -- Loop is complete. + Finalize_For_Loop_Statement (Instance, Stmt); + Update_Next_Statement (Proc); + else + Stmt_Chain := Get_Sequential_Statement_Chain (Stmt); + if Stmt_Chain = Null_Iir then + -- Nothing to do for an empty loop. + Finalize_For_Loop_Statement (Instance, Stmt); + Update_Next_Statement (Proc); + else + Instance.Stmt := Stmt_Chain; + end if; + end if; + end Execute_For_Loop_Statement; + + -- This function is called when there is no more statements to execute + -- in the statement list of a for_loop. Returns FALSE in case of end of + -- loop. + function Finish_For_Loop_Statement (Instance : Block_Instance_Acc) + return Boolean + is + Iterator : constant Iir := Get_Parameter_Specification (Instance.Stmt); + Bounds : Iir_Value_Literal_Acc; + Index : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + -- FIXME: avoid allocation. + Mark (Marker, Expr_Pool); + Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); + Index := Instance.Objects (Get_Info (Iterator).Slot); + + if Is_Equal (Index, Bounds.Right) then + -- Loop is complete. + Release (Marker, Expr_Pool); + Finalize_For_Loop_Statement (Instance, Instance.Stmt); + return False; + else + -- Update the loop index. + Update_Loop_Index (Index, Bounds); + + Release (Marker, Expr_Pool); + + -- start the loop again. + Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); + return True; + end if; + end Finish_For_Loop_Statement; + + -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. + function Execute_Condition (Instance : Block_Instance_Acc; + Cond : Iir) return Boolean + is + V : Iir_Value_Literal_Acc; + Res : Boolean; + Marker : Mark_Type; + begin + if Cond = Null_Iir then + return True; + end if; + + Mark (Marker, Expr_Pool); + V := Execute_Expression (Instance, Cond); + Res := V.B1 = True; + Release (Marker, Expr_Pool); + return Res; + end Execute_Condition; + + -- Start a while loop statement, or return FALSE if the loop is not + -- executed. + procedure Execute_While_Loop_Statement (Proc : Process_State_Acc) + is + Instance: constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Cond : Boolean; + begin + Cond := Execute_Condition (Instance, Get_Condition (Stmt)); + if Cond then + Init_Sequential_Statements (Proc, Stmt); + else + Update_Next_Statement (Proc); + end if; + end Execute_While_Loop_Statement; + + -- This function is called when there is no more statements to execute + -- in the statement list of a while loop. Returns FALSE iff loop is + -- completed. + function Finish_While_Loop_Statement (Instance : Block_Instance_Acc) + return Boolean + is + Cond : Boolean; + begin + Cond := Execute_Condition (Instance, Get_Condition (Instance.Stmt)); + + if Cond then + -- start the loop again. + Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); + return True; + else + -- Loop is complete. + return False; + end if; + end Finish_While_Loop_Statement; + + -- Return TRUE if the loop must be executed again + function Finish_Loop_Statement (Instance : Block_Instance_Acc; + Stmt : Iir) return Boolean is + begin + Instance.Stmt := Stmt; + case Get_Kind (Stmt) is + when Iir_Kind_While_Loop_Statement => + return Finish_While_Loop_Statement (Instance); + when Iir_Kind_For_Loop_Statement => + return Finish_For_Loop_Statement (Instance); + when others => + Error_Kind ("finish_loop_statement", Stmt); + end case; + end Finish_Loop_Statement; + + -- Return FALSE if the next statement should be executed (possibly + -- updated). + procedure Execute_Exit_Next_Statement (Proc : Process_State_Acc; + Is_Exit : Boolean) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Label : constant Iir := Get_Named_Entity (Get_Loop_Label (Stmt)); + Cond : Boolean; + Parent : Iir; + begin + Cond := Execute_Condition (Instance, Get_Condition (Stmt)); + if not Cond then + Update_Next_Statement (Proc); + return; + end if; + + Parent := Stmt; + loop + Parent := Get_Parent (Parent); + case Get_Kind (Parent) is + when Iir_Kind_For_Loop_Statement + | Iir_Kind_While_Loop_Statement => + if Label = Null_Iir or else Label = Parent then + -- Target is this statement. + if Is_Exit then + Finalize_Loop_Statement (Instance, Parent); + Instance.Stmt := Parent; + Update_Next_Statement (Proc); + elsif not Finish_Loop_Statement (Instance, Parent) then + Update_Next_Statement (Proc); + else + Init_Sequential_Statements (Proc, Parent); + end if; + return; + else + Finalize_Loop_Statement (Instance, Parent); + end if; + when others => + null; + end case; + end loop; + end Execute_Exit_Next_Statement; + + procedure Execute_Case_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Value: Iir_Value_Literal_Acc; + Assoc: Iir; + Stmt_Chain : Iir; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + + Value := Execute_Expression (Instance, Get_Expression (Stmt)); + Assoc := Get_Case_Statement_Alternative_Chain (Stmt); + + while Assoc /= Null_Iir loop + if not Get_Same_Alternative_Flag (Assoc) then + Stmt_Chain := Get_Associated_Chain (Assoc); + end if; + + if Is_In_Choice (Instance, Assoc, Value) then + if Stmt_Chain = Null_Iir then + Update_Next_Statement (Proc); + else + Instance.Stmt := Stmt_Chain; + end if; + Release (Marker, Expr_Pool); + return; + end if; + + Assoc := Get_Chain (Assoc); + end loop; + -- FIXME: infinite loop??? + Error_Msg_Exec ("no choice for expression", Stmt); + raise Internal_Error; + end Execute_Case_Statement; + + procedure Execute_Call_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Named_Entity (Get_Implementation (Call)); + Subprg_Instance : Block_Instance_Acc; + Assoc_Chain: Iir; + Subprg_Body : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration then + Execute_Implicit_Procedure (Instance, Call); + Update_Next_Statement (Proc); + elsif Get_Foreign_Flag (Imp) then + Execute_Foreign_Procedure (Instance, Call); + Update_Next_Statement (Proc); + else + Mark (Instance.Marker, Instance_Pool.all); + Subprg_Instance := Create_Subprogram_Instance (Instance, Imp); + Adjust_Up_Link_For_Protected_Object + (Instance, Call, Subprg_Instance); + Assoc_Chain := Get_Parameter_Association_Chain (Call); + Execute_Association (Instance, Subprg_Instance, Assoc_Chain); + + Current_Process.Instance := Subprg_Instance; + Subprg_Body := Get_Subprogram_Body (Imp); + Elaborate_Declarative_Part + (Subprg_Instance, Get_Declaration_Chain (Subprg_Body)); + + Init_Sequential_Statements (Proc, Subprg_Body); + end if; + end Execute_Call_Statement; + + procedure Finish_Procedure_Frame (Proc : Process_State_Acc) + is + Old_Instance : constant Block_Instance_Acc := Proc.Instance; + begin + Execute_Back_Association (Old_Instance); + Proc.Instance := Old_Instance.Parent; + Execute_Subprogram_Call_Final (Old_Instance); + Release (Proc.Instance.Marker, Instance_Pool.all); + end Finish_Procedure_Frame; + + procedure Execute_If_Statement + (Proc : Process_State_Acc; Stmt: Iir_Wait_Statement) + is + Clause: Iir; + Cond: Boolean; + begin + Clause := Stmt; + loop + Cond := Execute_Condition (Proc.Instance, Get_Condition (Clause)); + if Cond then + Init_Sequential_Statements (Proc, Clause); + return; + end if; + Clause := Get_Else_Clause (Clause); + exit when Clause = Null_Iir; + end loop; + Update_Next_Statement (Proc); + end Execute_If_Statement; + + procedure Execute_Variable_Assignment + (Proc : Process_State_Acc; Stmt : Iir) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Target : constant Iir := Get_Target (Stmt); + Target_Type : constant Iir := Get_Type (Target); + Expr : constant Iir := Get_Expression (Stmt); + Expr_Type : constant Iir := Get_Type (Expr); + Target_Val: Iir_Value_Literal_Acc; + Res : Iir_Value_Literal_Acc; + Marker : Mark_Type; + begin + Mark (Marker, Expr_Pool); + Target_Val := Execute_Expression (Instance, Target); + + -- If the type of the target is not static and the value is + -- an aggregate, then the aggregate may be contrained by the + -- target. + if Get_Kind (Expr) = Iir_Kind_Aggregate + and then Get_Type_Staticness (Expr_Type) < Locally + and then Get_Kind (Expr_Type) + in Iir_Kinds_Array_Type_Definition + then + Res := Copy_Array_Bound (Target_Val); + Fill_Array_Aggregate (Instance, Expr, Res); + else + Res := Execute_Expression (Instance, Expr); + end if; + if Get_Kind (Target_Type) in Iir_Kinds_Array_Type_Definition then + -- Note: target_type may be dynamic (slice case), so + -- check_constraints is not called. + Implicit_Array_Conversion (Res, Target_Val, Stmt); + else + Check_Constraints (Instance, Res, Target_Type, Stmt); + end if; + + -- Note: we need to unshare before copying to avoid + -- overwrites (in assignments like: v (1 to 4) := v (3 to 6)). + -- FIXME: improve that handling (detect overlaps before). + Store (Target_Val, Unshare (Res, Expr_Pool'Access)); + + Release (Marker, Expr_Pool); + end Execute_Variable_Assignment; + + function Execute_Return_Statement (Proc : Process_State_Acc) + return Boolean + is + Res : Iir_Value_Literal_Acc; + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : constant Iir := Instance.Stmt; + Expr : constant Iir := Get_Expression (Stmt); + begin + if Expr /= Null_Iir then + Res := Execute_Expression (Instance, Expr); + Implicit_Array_Conversion (Instance, Res, Get_Type (Stmt), Stmt); + Check_Constraints (Instance, Res, Get_Type (Stmt), Stmt); + Instance.Result := Res; + end if; + + case Get_Kind (Instance.Label) is + when Iir_Kind_Procedure_Declaration => + Finish_Procedure_Frame (Proc); + Update_Next_Statement (Proc); + return False; + when Iir_Kind_Function_Declaration => + return True; + when others => + raise Internal_Error; + end case; + end Execute_Return_Statement; + + procedure Finish_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir) + is + Instance : Block_Instance_Acc := Proc.Instance; + Stmt : Iir; + begin + Stmt := Complex_Stmt; + loop + Instance.Stmt := Stmt; + case Get_Kind (Stmt) is + when Iir_Kind_For_Loop_Statement => + if Finish_For_Loop_Statement (Instance) then + return; + end if; + when Iir_Kind_While_Loop_Statement => + if Finish_While_Loop_Statement (Instance) then + return; + end if; + when Iir_Kind_Case_Statement + | Iir_Kind_If_Statement => + null; + when Iir_Kind_Sensitized_Process_Statement => + Instance.Stmt := Null_Iir; + return; + when Iir_Kind_Process_Statement => + -- Start again. + Instance.Stmt := Get_Sequential_Statement_Chain (Stmt); + return; + when Iir_Kind_Procedure_Body => + Finish_Procedure_Frame (Proc); + Instance := Proc.Instance; + when Iir_Kind_Function_Body => + Error_Msg_Exec ("missing return statement in function", Stmt); + when others => + Error_Kind ("execute_next_statement", Stmt); + end case; + Stmt := Get_Chain (Instance.Stmt); + if Stmt /= Null_Iir then + Instance.Stmt := Stmt; + return; + end if; + Stmt := Get_Parent (Instance.Stmt); + end loop; + end Finish_Sequential_Statements; + + procedure Init_Sequential_Statements + (Proc : Process_State_Acc; Complex_Stmt : Iir) + is + Stmt : Iir; + begin + Stmt := Get_Sequential_Statement_Chain (Complex_Stmt); + if Stmt /= Null_Iir then + Proc.Instance.Stmt := Stmt; + else + Finish_Sequential_Statements (Proc, Complex_Stmt); + end if; + end Init_Sequential_Statements; + + procedure Update_Next_Statement (Proc : Process_State_Acc) + is + Instance : constant Block_Instance_Acc := Proc.Instance; + Stmt : Iir; + begin + Stmt := Get_Chain (Instance.Stmt); + if Stmt /= Null_Iir then + Instance.Stmt := Stmt; + return; + end if; + Finish_Sequential_Statements (Proc, Get_Parent (Instance.Stmt)); + end Update_Next_Statement; + + procedure Execute_Sequential_Statements (Proc : Process_State_Acc) + is + Instance : Block_Instance_Acc; + Stmt: Iir; + begin + loop + Instance := Proc.Instance; + Stmt := Instance.Stmt; + + -- End of process or subprogram. + exit when Stmt = Null_Iir; + + if Trace_Statements then + declare + Name : Name_Id; + Line : Natural; + Col : Natural; + begin + Files_Map.Location_To_Position + (Get_Location (Stmt), Name, Line, Col); + Put_Line ("Execute statement at " + & Name_Table.Image (Name) + & Natural'Image (Line)); + end; + end if; + + if Flag_Need_Debug then + Debug (Reason_Break); + end if; + + -- execute statement STMT. + case Get_Kind (Stmt) is + when Iir_Kind_Null_Statement => + Update_Next_Statement (Proc); + + when Iir_Kind_If_Statement => + Execute_If_Statement (Proc, Stmt); + + when Iir_Kind_Signal_Assignment_Statement => + Execute_Signal_Assignment (Instance, Stmt); + Update_Next_Statement (Proc); + + when Iir_Kind_Assertion_Statement => + declare + Res : Boolean; + begin + Res := Execute_Condition + (Instance, Get_Assertion_Condition (Stmt)); + if not Res then + Execute_Report_Statement (Instance, Stmt, 2); + end if; + end; + Update_Next_Statement (Proc); + + when Iir_Kind_Report_Statement => + Execute_Report_Statement (Instance, Stmt, 0); + Update_Next_Statement (Proc); + + when Iir_Kind_Variable_Assignment_Statement => + Execute_Variable_Assignment (Proc, Stmt); + Update_Next_Statement (Proc); + + when Iir_Kind_Return_Statement => + if Execute_Return_Statement (Proc) then + return; + end if; + + when Iir_Kind_For_Loop_Statement => + Execute_For_Loop_Statement (Proc); + + when Iir_Kind_While_Loop_Statement => + Execute_While_Loop_Statement (Proc); + + when Iir_Kind_Case_Statement => + Execute_Case_Statement (Proc); + + when Iir_Kind_Wait_Statement => + if Execute_Wait_Statement (Instance, Stmt) then + return; + end if; + Update_Next_Statement (Proc); + + when Iir_Kind_Procedure_Call_Statement => + Execute_Call_Statement (Proc); + + when Iir_Kind_Exit_Statement => + Execute_Exit_Next_Statement (Proc, True); + when Iir_Kind_Next_Statement => + Execute_Exit_Next_Statement (Proc, False); + + when others => + Error_Kind ("execute_sequential_statements", Stmt); + end case; + end loop; + end Execute_Sequential_Statements; +end Execution; diff --git a/src/vhdl/simulate/execution.ads b/src/vhdl/simulate/execution.ads new file mode 100644 index 000000000..faed1111d --- /dev/null +++ b/src/vhdl/simulate/execution.ads @@ -0,0 +1,185 @@ +-- 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; + + Simulation_Finished : exception; + + -- Current process being executed. This is only for the debugger. + Current_Process : Process_State_Acc; + + -- Pseudo process used for resolution functions, ... + No_Process : Process_State_Acc := new Process_State_Type; + -- Execute a list of sequential statements. + -- Return when there is no more statements to execute. + procedure Execute_Sequential_Statements (Proc : Process_State_Acc); + + -- Evaluate an expression. + function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) + return Iir_Value_Literal_Acc; + + -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. + function Execute_Condition (Instance : Block_Instance_Acc; + Cond : Iir) return Boolean; + + -- Execute a name. Return the value if Ref is False, or the reference + -- (for a signal, a quantity or a terminal) if Ref is True. + function Execute_Name (Block: Block_Instance_Acc; + Expr: Iir; + Ref : Boolean := False) + return Iir_Value_Literal_Acc; + + procedure Execute_Name_With_Base (Block: Block_Instance_Acc; + Expr: Iir; + Base : Iir_Value_Literal_Acc; + Res : out Iir_Value_Literal_Acc; + Is_Sig : out Boolean); + + -- Return the initial value (default value) of signal name EXPR. To be + -- used only during (non-dynamic) elaboration. + function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) + return Iir_Value_Literal_Acc; + + function Execute_Expression_With_Type + (Block: Block_Instance_Acc; + Expr: Iir; + Expr_Type : Iir) + return Iir_Value_Literal_Acc; + + 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; + + function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; + Expr_Type : Iir) + return String; +end Execution; diff --git a/src/vhdl/simulate/file_operation.adb b/src/vhdl/simulate/file_operation.adb new file mode 100644 index 000000000..33700fd6c --- /dev/null +++ b/src/vhdl/simulate/file_operation.adb @@ -0,0 +1,341 @@ +-- 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_B1 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_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_B1 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_E32 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); + when Iir_Value_F64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); + when Iir_Value_Array => + for I in Value.Bounds.D'Range loop + declare + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + if Len /= Value.Bounds.D (I).Length then + Error_Msg_Constraint (Null_Iir); -- FIXME: loc + end if; + end; + end loop; + for I in Value.Val_Array.V'Range loop + Read_Binary (File, Value.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + Read_Binary (File, Value.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Read_Binary; + + procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + for I in 1 .. Len loop + if I <= Value.Bounds.D (1).Length then + Read_Binary (File, Value.Val_Array.V (I)); + else + -- FIXME: for empty arrays ?? + -- Lose_Binary (File, Value.Val_Array (0)); + raise Internal_Error; + end if; + end loop; + Length.I64 := Ghdl_I64 (Len); + end Read_Length_Binary; + + procedure Flush (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Flush (File.File); + end Flush; +end File_Operation; diff --git a/src/vhdl/simulate/file_operation.ads b/src/vhdl/simulate/file_operation.ads new file mode 100644 index 000000000..b66a06756 --- /dev/null +++ b/src/vhdl/simulate/file_operation.ads @@ -0,0 +1,81 @@ +-- 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); + + procedure Flush (File : 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/src/vhdl/simulate/grt_interface.adb b/src/vhdl/simulate/grt_interface.adb new file mode 100644 index 000000000..c4eab58c4 --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/grt_interface.ads b/src/vhdl/simulate/grt_interface.ads new file mode 100644 index 000000000..05f7abb69 --- /dev/null +++ b/src/vhdl/simulate/grt_interface.ads @@ -0,0 +1,27 @@ +-- Interpreted simulation +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Grt.Types; use Grt.Types; +with Iir_Values; use Iir_Values; + +package Grt_Interface is + procedure Set_Std_String_From_Iir_Value (Str : Std_String; + Val : Iir_Value_Literal_Acc); + + function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound; +end Grt_Interface; diff --git a/src/vhdl/simulate/iir_values.adb b/src/vhdl/simulate/iir_values.adb new file mode 100644 index 000000000..d80f3bf0a --- /dev/null +++ b/src/vhdl/simulate/iir_values.adb @@ -0,0 +1,1066 @@ +-- 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; +with Iirs_Utils; use Iirs_Utils; + +package body Iir_Values is + + -- Functions for iir_value_literal + function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean is + begin + if Left.Kind /= Right.Kind then + raise Internal_Error; + end if; + case Left.Kind is + when Iir_Value_B1 => + return Left.B1 = Right.B1; + when Iir_Value_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_B1 => + if Left.B1 < Right.B1 then + return Less; + elsif Left.B1 = Right.B1 then + return Equal; + else + return Greater; + end if; + when Iir_Value_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_B1 => + if Val.B1 = False then + Val.B1 := 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_B1 => + Dest.B1 := Src.B1; + 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_B1 + | 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_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc + is + subtype B1_Value is Iir_Value_Literal (Iir_Value_B1); + function Alloc is new Alloc_On_Pool_Addr (B1_Value); + begin + return To_Iir_Value_Literal_Acc + (Alloc (Current_Pool, (Kind => Iir_Value_B1, B1 => Val))); + end Create_B1_Value; + + function Create_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_B1 => + if High.B1 >= Low.B1 then + Len := Ghdl_B1'Pos (High.B1) - Ghdl_B1'Pos (Low.B1) + 1; + else + Len := 0; + end if; + when Iir_Value_E32 => + if High.E32 >= Low.E32 then + Len := Iir_Index32 (High.E32 - Low.E32 + 1); + else + Len := 0; + end if; + when Iir_Value_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_B1 => + return Create_B1_Value (Src.B1); + 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; + + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural is + begin + case Val.Kind is + when Iir_Value_E32 => + return Ghdl_E32'Pos (Val.E32); + when Iir_Value_B1 => + return Ghdl_B1'Pos (Val.B1); + when others => + raise Internal_Error; + end case; + end Get_Enum_Pos; + + procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; + Tab: Ada.Text_IO.Count) + is + use Ada.Text_IO; + use GNAT.Debug_Utilities; + begin + Set_Col (Tab); + if Value = null then + Put_Line ("*NULL*"); + return; + end if; + + if Boolean'(True) then + Put (Image (Value.all'Address) & ' '); + end if; + + case Value.Kind is + when Iir_Value_B1 => + Put_Line ("b1:" & Ghdl_B1'Image (Value.B1)); + when Iir_Value_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: Iir_Index32; + Off : in out Iir_Index32) + is + use Ada.Text_IO; + type Last_Enum_Type is (None, Char, Identifier); + Last_Enum: Last_Enum_Type; + El_Type: Iir; + Enum_List: Iir_List; + El_Id : Name_Id; + El_Pos : Natural; + begin + if Dim = Value.Bounds.Nbr_Dims then + -- Last dimension + El_Type := Get_Base_Type (Get_Element_Subtype (A_Type)); + + -- Pretty print vectors of enumerated types + if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition + and then not Is_Indirect (Value) + then + Last_Enum := None; + Enum_List := Get_Enumeration_Literal_List (El_Type); + for I in 1 .. Value.Bounds.D (Dim).Length loop + El_Pos := Get_Enum_Pos (Value.Val_Array.V (Off)); + Off := Off + 1; + El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); + if Name_Table.Is_Character (El_Id) then + case Last_Enum is + when None => + Put (""""); + when Identifier => + Put (" & """); + when Char => + null; + end case; + Put (Name_Table.Get_Character (El_Id)); + Last_Enum := Char; + else + case Last_Enum is + when None => + null; + when Identifier => + Put (" & "); + when Char => + Put (""" & "); + end case; + Put (Name_Table.Image (El_Id)); + Last_Enum := Identifier; + end if; + end loop; + case Last_Enum is + when None => + Put (""""); + when Identifier => + null; + when Char => + Put (""""); + end case; + else + Put ("("); + for I in 1 .. Value.Bounds.D (Dim).Length loop + if I /= 1 then + Put (", "); + end if; + Disp_Iir_Value (Value.Val_Array.V (Off), El_Type); + Off := Off + 1; + end loop; + Put (")"); + end if; + else + Put ("("); + for I in 1 .. Value.Bounds.D (Dim).Length loop + if I /= 1 then + Put (", "); + end if; + Disp_Iir_Value_Array (Value, A_Type, Dim + 1, Off); + end loop; + Put (")"); + end if; + end Disp_Iir_Value_Array; + + procedure Disp_Iir_Value_Record + (Value: Iir_Value_Literal_Acc; A_Type: Iir) + is + use Ada.Text_IO; + 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_B1 => + 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_B1'Pos (Value.B1); + 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 => + declare + Off : Iir_Index32; + begin + Off := 1; + Disp_Iir_Value_Array (Value, A_Type, 1, Off); + pragma Assert (Off = Value.Val_Array.Len + 1); + end; + when Iir_Value_File => + raise Internal_Error; + when Iir_Value_Record => + Disp_Iir_Value_Record (Value, A_Type); + when Iir_Value_Range => + -- FIXME. + raise Internal_Error; + when Iir_Value_Quantity => + Put ("[quantity]"); + when Iir_Value_Terminal => + Put ("[terminal]"); + when Iir_Value_Signal => + Put ("[signal]"); + when Iir_Value_Protected => + Put ("[protected]"); + end case; + end Disp_Iir_Value; +end Iir_Values; diff --git a/src/vhdl/simulate/iir_values.ads b/src/vhdl/simulate/iir_values.ads new file mode 100644 index 000000000..699ab883a --- /dev/null +++ b/src/vhdl/simulate/iir_values.ads @@ -0,0 +1,355 @@ +-- 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_B1, 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_B1 .. 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_B1 => + B1 : Ghdl_B1; + 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_B1_Value (Val : Ghdl_B1) 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; + + -- Return the position of an enumerated type value. + function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural; + + -- Well known values. + -- Boolean_to_lit can be used to convert a boolean value from Ada to a + -- boolean value for vhdl. + type Lit_Enum_Type is array (Boolean) of Iir_Value_Literal_Acc; + Lit_Enum_0 : constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_B1, + B1 => False); + Lit_Enum_1 : constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_B1, + B1 => True); + Boolean_To_Lit: constant Lit_Enum_Type := + (False => Lit_Enum_0, True => Lit_Enum_1); + Lit_Boolean_False: Iir_Value_Literal_Acc + renames Boolean_To_Lit (False); + Lit_Boolean_True: Iir_Value_Literal_Acc + renames Boolean_To_Lit (True); + + -- Literal NULL. + Null_Lit: constant Iir_Value_Literal_Acc := + new Iir_Value_Literal'(Kind => Iir_Value_Access, + Val_Access => null); + + -- Disp a value_literal in raw form. + procedure Disp_Value (Value: Iir_Value_Literal_Acc); + procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; + Tab: Ada.Text_IO.Count); + + -- Disp a value_literal in readable form. + procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir); +end Iir_Values; + diff --git a/src/vhdl/simulate/sim_be.adb b/src/vhdl/simulate/sim_be.adb new file mode 100644 index 000000000..49a146879 --- /dev/null +++ b/src/vhdl/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_Body 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/src/vhdl/simulate/sim_be.ads b/src/vhdl/simulate/sim_be.ads new file mode 100644 index 000000000..9256c4b68 --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/simulation-ams-debugger.adb b/src/vhdl/simulate/simulation-ams-debugger.adb new file mode 100644 index 000000000..9cdbc75b2 --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/simulation-ams-debugger.ads b/src/vhdl/simulate/simulation-ams-debugger.ads new file mode 100644 index 000000000..0cfcdedc7 --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/simulation-ams.adb b/src/vhdl/simulate/simulation-ams.adb new file mode 100644 index 000000000..31dd43e0e --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/simulation-ams.ads b/src/vhdl/simulate/simulation-ams.ads new file mode 100644 index 000000000..8ca513652 --- /dev/null +++ b/src/vhdl/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/src/vhdl/simulate/simulation.adb b/src/vhdl/simulate/simulation.adb new file mode 100644 index 000000000..3f3f8715b --- /dev/null +++ b/src/vhdl/simulate/simulation.adb @@ -0,0 +1,1669 @@ +-- 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 Iirs_Utils; use Iirs_Utils; +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_B1 => + return Create_B1_Value (Val.B1); + 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_B1 => + Dst.B1 := Src.B1; + 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, + + -- For conversion functions. + Read_Signal_Driving_Value, + Read_Signal_Effective_Value, + + -- 'Driving_Value + Read_Signal_Driver_Value); + + function Execute_Read_Signal_Value (Sig: Iir_Value_Literal_Acc; + Attr : Read_Signal_Value_Enum) + return Iir_Value_Literal_Acc + is + Res: Iir_Value_Literal_Acc; + begin + case Sig.Kind is + when Iir_Value_Array => + Res := Copy_Array_Bound (Sig); + for I in Sig.Val_Array.V'Range loop + Res.Val_Array.V (I) := + Execute_Read_Signal_Value (Sig.Val_Array.V (I), Attr); + end loop; + return Res; + when Iir_Value_Record => + Res := Create_Record_Value (Sig.Val_Record.Len); + for I in Sig.Val_Record.V'Range loop + Res.Val_Record.V (I) := + Execute_Read_Signal_Value (Sig.Val_Record.V (I), Attr); + end loop; + return Res; + when Iir_Value_Signal => + case Attr is + when Read_Signal_Last_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Last_Value); + when Read_Signal_Driver_Value => + case Sig.Sig.Mode is + when Mode_F64 => + return Create_F64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_F64 + (Sig.Sig)); + when Mode_I64 => + return Create_I64_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_I64 + (Sig.Sig)); + when Mode_E32 => + return Create_E32_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_E32 + (Sig.Sig)); + when Mode_B1 => + return Create_B1_Value + (Grt.Signals.Ghdl_Signal_Driving_Value_B1 + (Sig.Sig)); + when others => + raise Internal_Error; + end case; + when Read_Signal_Effective_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Value); + when Read_Signal_Driving_Value => + return Value_To_Iir_Value + (Sig.Sig.Mode, Sig.Sig.Driving_Value); + end case; + when others => + raise Internal_Error; + end case; + end Execute_Read_Signal_Value; + + 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_Driver_Value); + end Execute_Driving_Value_Attribute; + + type Signal_Read_Last_Type is + (Read_Last_Event, + Read_Last_Active); + + -- Return the Last_Event absolute time. + function Execute_Read_Signal_Last (Indirect: Iir_Value_Literal_Acc; + Kind : Signal_Read_Last_Type) + return Ghdl_I64 + is + Res: Ghdl_I64; + begin + case Indirect.Kind is + when Iir_Value_Array => + Res := Ghdl_I64'First; + for I in Indirect.Val_Array.V'Range loop + Res := Ghdl_I64'Max + (Res, Execute_Read_Signal_Last (Indirect.Val_Array.V (I), + Kind)); + end loop; + return Res; + when Iir_Value_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_B1 => + Ghdl_Signal_Start_Assign_B1 + (Target.Sig, Transactions.Reject, El.Value.B1, El.After); + when Iir_Value_E32 => + Ghdl_Signal_Start_Assign_E32 + (Target.Sig, Transactions.Reject, El.Value.E32, El.After); + when Iir_Value_I64 => + Ghdl_Signal_Start_Assign_I64 + (Target.Sig, Transactions.Reject, El.Value.I64, El.After); + when Iir_Value_F64 => + Ghdl_Signal_Start_Assign_F64 + (Target.Sig, Transactions.Reject, El.Value.F64, El.After); + end case; + end; + + for I in 2 .. Transactions.Els'Last loop + declare + El : Transaction_El_Type renames Transactions.Els (I); + begin + case Iir_Value_Scalars (El.Value.Kind) is + when Iir_Value_B1 => + Ghdl_Signal_Next_Assign_B1 + (Target.Sig, El.Value.B1, El.After); + when Iir_Value_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.Stmt = Null_Iir then + Process.Instance.Stmt := + Get_Sequential_Statement_Chain (Process.Proc); + end if; + when Iir_Kind_Process_Statement => + if not Process.Instance.In_Wait_Flag then + raise Internal_Error; + end if; + when others => + raise Internal_Error; + end case; + + Instance_Pool := null; + Current_Process := null; + end Process_Executer; + + type 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_B1 + is + Guard : Guard_Instance_Type; + pragma Import (Ada, Guard); + for Guard'Address use Data; + + Val : Boolean; + + Prev_Instance_Pool : Areapool_Acc; + begin + pragma Assert (Instance_Pool = null + or else Instance_Pool = Global_Pool'Access); + Prev_Instance_Pool := Instance_Pool; + + Instance_Pool := Global_Pool'Access; + Current_Process := No_Process; + + Val := Execute_Condition + (Guard.Instance, Get_Guard_Expression (Guard.Guard)); + + Instance_Pool := Prev_Instance_Pool; + + return Ghdl_B1'Val (Boolean'Pos (Val)); + end Guard_Func; + + -- 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.Label; + + Instance_Pool := Processes_State (I).Pool'Access; + Instance.Stmt := Get_Sequential_Statement_Chain (El); + + Processes_State (I).Top_Instance := Instance; + Processes_State (I).Proc := El; + Processes_State (I).Instance := Instance; + + Current_Process := Processes_State (I)'Access; + Instance_Grt := To_Instance_Acc (Processes_State (I)'Address); + case Get_Kind (El) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Postponed_Flag (El) then + Ghdl_Postponed_Sensitized_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + else + Ghdl_Sensitized_Process_Register + (Instance_Grt, + Process_Executer'Access, + null, System.Null_Address); + end if; + + -- Register sensitivity. + 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_B1 => + if Mode = Connect_Source then + raise Internal_Error; + end if; + Grt.Signals.Ghdl_Signal_Associate_B1 (Port.Sig, Sig.B1); + 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_B1 => + return Create_Signal_Value + (Grt.Signals.Ghdl_Create_Signal_B1 + (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_Association_Interface (Assoc); + begin + if False and Trace_Elaboration then + Put ("connect formal "); + Put (Iir_Mode'Image (Get_Mode (Inter))); + Put (" "); + Disp_Iir_Value (Formal_Expr, Get_Type (Formal)); + Put (" with actual "); + Disp_Iir_Value (Local_Expr, Get_Type (Get_Actual (Assoc))); + New_Line; + end if; + + case Get_Mode (Inter) is + when Iir_Out_Mode + | Iir_Inout_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + -- FORMAL_EXPR is a source for LOCAL_EXPR. + declare + Out_Conv : constant Iir := Get_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_B1 => + Sig.Sig := Grt.Signals.Ghdl_Create_Signal_B1 + (Lit.B1, 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 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 := Iirs_Utils.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; + when Simulation_Finished => + null; + end Simulation_Entity; + +end Simulation; diff --git a/src/vhdl/simulate/simulation.ads b/src/vhdl/simulate/simulation.ads new file mode 100644 index 000000000..b910b4306 --- /dev/null +++ b/src/vhdl/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_B1; + 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; diff --git a/src/vhdl/translate/Makefile b/src/vhdl/translate/Makefile new file mode 100644 index 000000000..b331b5728 --- /dev/null +++ b/src/vhdl/translate/Makefile @@ -0,0 +1,45 @@ +# -*- Makefile -*- for the GHDL translation back-end. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. + +BE=gcc +ortho_srcdir=../ortho +GNAT_FLAGS=-aI.. -aI../psl -gnaty3befhkmr -gnata -gnatf -gnatwael -gnat05 +#GNAT_FLAGS+=-O -gnatn +LN=ln -s + +compiler: force # ortho_nodes.ads ortho_$(BE)_front.ads + $(MAKE) -f $(ortho_srcdir)/$(BE)/Makefile \ + ortho_srcdir=$(ortho_srcdir) GNAT_FLAGS="$(GNAT_FLAGS)" \ + ortho_exec=ghdl1-$(BE) all + +all: + [ -d lib ] || mkdir lib + $(MAKE) -f $(ortho_srcdir)/gcc/Makefile \ + ortho_srcdir=$(ortho_srcdir) GNAT_FLAGS="$(GNAT_FLAGS)" \ + ortho_exec=ghdl1-gcc all + $(MAKE) -C ghdldrv + $(MAKE) -C grt all libdir=`pwd`/lib + $(MAKE) -C ghdldrv install.v87 install.v93 install.standard + +clean: + $(RM) *.o *.ali ghdl1-* gen_tree ortho_nodes-main b~*.ad? + $(RM) *~ ortho_nodes.ads ortho_nodes.tmp + +force: + +.PHONY: compiler clean force all diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb new file mode 100644 index 000000000..56c7e61dd --- /dev/null +++ b/src/vhdl/translate/ortho_front.adb @@ -0,0 +1,445 @@ +-- Ortho entry point for translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; 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 Name_Table; +with Std_Package; +with Back_End; +with Flags; +with Translation; +with Iirs; use Iirs; +with Libraries; use Libraries; +with Sem; +with Errorout; use Errorout; +with GNAT.OS_Lib; +with Canon; +with Disp_Vhdl; +with Bug; +with Trans_Be; +with Options; + +package body Ortho_Front is + -- The action to be performed by the compiler. + type Action_Type is + ( + -- Normal mode: compile a design file. + Action_Compile, + + -- Elaborate a design unit. + Action_Elaborate, + + -- Analyze files and elaborate unit. + Action_Anaelab, + + -- Generate code for std.package. + Action_Compile_Std_Package + ); + Action : Action_Type := Action_Compile; + + -- Name of the entity to elaborate. + Elab_Entity : String_Acc; + -- Name of the architecture to elaborate. + Elab_Architecture : String_Acc; + -- Filename for the list of files to link. + Elab_Filelist : String_Acc; + + Flag_Expect_Failure : Boolean; + + type Id_Link; + type Id_Link_Acc is access Id_Link; + type Id_Link is record + Id : Name_Id; + Link : Id_Link_Acc; + end record; + Anaelab_Files : Id_Link_Acc := null; + Anaelab_Files_Last : Id_Link_Acc := null; + + procedure Init is + begin + -- Initialize. + Trans_Be.Register_Translation_Back_End; + + Options.Initialize; + + Elab_Filelist := null; + Elab_Entity := null; + Elab_Architecture := null; + Flag_Expect_Failure := False; + end Init; + + function Decode_Elab_Option (Arg : String_Acc) return Natural + is + begin + Elab_Architecture := null; + -- Entity (+ architecture) to elaborate + if Arg = null then + Error_Msg_Option + ("entity or configuration name required after --elab"); + return 0; + end if; + if Arg (Arg.all'Last) = ')' then + -- Name is ENTITY(ARCH). + -- Split. + declare + P : Natural; + Len : Natural; + Is_Ext : Boolean; + begin + P := Arg.all'Last - 1; + Len := P - Arg.all'First + 1; + -- Must be at least 'e(a)'. + if Len < 4 then + Error_Msg_Option ("ill-formed name after --elab"); + return 0; + end if; + -- Handle extended name. + if Arg (P) = '\' then + P := P - 1; + Is_Ext := True; + else + Is_Ext := False; + end if; + loop + if P = Arg.all'First then + Error_Msg_Option ("ill-formed name after --elab"); + return 0; + end if; + exit when Arg (P) = '(' and Is_Ext = False; + if Arg (P) = '\' then + if Arg (P - 1) = '\' then + P := P - 2; + elsif Arg (P - 1) = '(' then + P := P - 1; + exit; + else + Error_Msg_Option ("ill-formed name after --elab"); + return 0; + end if; + else + P := P - 1; + end if; + end loop; + Elab_Architecture := new String'(Arg (P + 1 .. Arg'Last - 1)); + Elab_Entity := new String'(Arg (Arg'First .. P - 1)); + end; + else + Elab_Entity := new String'(Arg.all); + Elab_Architecture := new String'(""); + end if; + return 2; + end Decode_Elab_Option; + + function Decode_Option (Opt : String_Acc; Arg: String_Acc) return Natural + is + begin + if Opt.all = "--compile-standard" then + Action := Action_Compile_Std_Package; + Flags.Bootstrap := True; + return 1; + elsif Opt.all = "--elab" then + if Action /= Action_Compile then + Error_Msg_Option ("several --elab options"); + return 0; + end if; + Action := Action_Elaborate; + return Decode_Elab_Option (Arg); + elsif Opt.all = "--anaelab" then + if Action /= Action_Compile then + Error_Msg_Option ("several --anaelab options"); + return 0; + end if; + Action := Action_Anaelab; + return Decode_Elab_Option (Arg); + elsif Opt'Length > 14 + and then Opt (Opt'First .. Opt'First + 13) = "--ghdl-source=" + then + if Action /= Action_Anaelab then + Error_Msg_Option + ("--ghdl-source option allowed only after --anaelab options"); + return 0; + end if; + if Arg /= null then + Error_Msg_Option ("no argument allowed after --ghdl-source"); + return 0; + end if; + declare + L : Id_Link_Acc; + begin + L := new Id_Link'(Id => Name_Table.Get_Identifier + (Opt (Opt'First + 14 .. Opt'Last)), + Link => null); + if Anaelab_Files = null then + Anaelab_Files := L; + else + Anaelab_Files_Last.Link := L; + end if; + Anaelab_Files_Last := L; + end; + return 2; + elsif Opt.all = "-l" then + if Arg = null then + Error_Msg_Option ("filename required after -l"); + end if; + if Elab_Filelist /= null then + Error_Msg_Option ("several -l options"); + else + Elab_Filelist := new String'(Arg.all); + end if; + return 2; + elsif Opt.all = "--help" then + Options.Disp_Options_Help; + return 1; + elsif Opt.all = "--expect-failure" then + Flag_Expect_Failure := True; + return 1; + elsif Opt'Length > 7 and then Opt (1 .. 7) = "--ghdl-" then + if Options.Parse_Option (Opt (7 .. Opt'Last)) then + return 1; + else + return 0; + end if; + elsif Options.Parse_Option (Opt.all) then + return 1; + else + return 0; + end if; + end Decode_Option; + + + -- Lighter version of libraries.is_obselete, since DESIGN_UNIT must be in + -- the currently analyzed design file. + function Is_Obsolete (Design_Unit : Iir_Design_Unit) + return Boolean + is + List : Iir_List; + El : Iir; + begin + if Get_Date (Design_Unit) = Date_Obsolete then + return True; + end if; + List := Get_Dependence_List (Design_Unit); + if Is_Null_List (List) then + return False; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when Is_Null (El); + -- FIXME: there may be entity_aspect_entity... + if Get_Kind (El) = Iir_Kind_Design_Unit + and then Get_Date (El) = Date_Obsolete + then + return True; + end if; + end loop; + return False; + end Is_Obsolete; + + Nbr_Parse : Natural := 0; + + function Parse (Filename : String_Acc) return Boolean + is + Res : Iir_Design_File; + New_Design_File : Iir_Design_File; + Design : Iir_Design_Unit; + Next_Design : Iir_Design_Unit; + + -- The vhdl filename to compile. + Vhdl_File : Name_Id; + begin + if Nbr_Parse = 0 then + -- Initialize only once... + Libraries.Load_Std_Library; + + -- Here, time_base can be set. + Translation.Initialize; + Canon.Canon_Flag_Add_Labels := True; + + if Flags.List_All and then Flags.List_Annotate then + Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); + end if; + + if Action = Action_Anaelab and then Anaelab_Files /= null + then + Libraries.Load_Work_Library (True); + else + Libraries.Load_Work_Library (False); + end if; + end if; + Nbr_Parse := Nbr_Parse + 1; + + case Action is + when Action_Elaborate => + Flags.Flag_Elaborate := True; + Flags.Flag_Only_Elab_Warnings := True; + Translation.Chap12.Elaborate + (Elab_Entity.all, Elab_Architecture.all, + Elab_Filelist.all, False); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + when Action_Anaelab => + -- Parse files. + if Anaelab_Files = null then + Flags.Flag_Elaborate_With_Outdated := False; + else + Flags.Flag_Elaborate_With_Outdated := True; + declare + L : Id_Link_Acc; + begin + L := Anaelab_Files; + while L /= null loop + Res := Libraries.Load_File (L.Id); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Put units into library. + Design := Get_First_Design_Unit (Res); + while not Is_Null (Design) loop + Next_Design := Get_Chain (Design); + Set_Chain (Design, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Design); + Design := Next_Design; + end loop; + L := L.Link; + end loop; + end; + end if; + + Flags.Flag_Elaborate := True; + Flags.Flag_Only_Elab_Warnings := False; + Translation.Chap12.Elaborate + (Elab_Entity.all, Elab_Architecture.all, "", True); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + when Action_Compile_Std_Package => + if Filename /= null then + Error_Msg_Option + ("--compile-standard is not compatible with a filename"); + return False; + end if; + Translation.Translate_Standard (True); + + when Action_Compile => + if Filename = null then + Error_Msg_Option ("no input file"); + return False; + end if; + if Nbr_Parse > 1 then + Error_Msg_Option ("can compile only one file (file """ & + Filename.all & """ ignored)"); + return False; + end if; + Vhdl_File := Name_Table.Get_Identifier (Filename.all); + + Translation.Translate_Standard (False); + + Flags.Flag_Elaborate := False; + Res := Libraries.Load_File (Vhdl_File); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Semantize all design units. + -- FIXME: outdate the design file? + New_Design_File := Null_Iir; + Design := Get_First_Design_Unit (Res); + while not Is_Null (Design) loop + -- Sem, canon, annotate a design unit. + Back_End.Finish_Compilation (Design, True); + + Next_Design := Get_Chain (Design); + if Errorout.Nbr_Errors = 0 then + Set_Chain (Design, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Design); + New_Design_File := Get_Design_File (Design); + end if; + + Design := Next_Design; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Do late analysis checks. + Design := Get_First_Design_Unit (New_Design_File); + while not Is_Null (Design) loop + Sem.Sem_Analysis_Checks_List + (Design, Flags.Warn_Delayed_Checks); + Design := Get_Chain (Design); + end loop; + + -- Compile only now. + if not Is_Null (New_Design_File) then + -- Note: the order of design unit is kept. + Design := Get_First_Design_Unit (New_Design_File); + while not Is_Null (Design) loop + if not Is_Obsolete (Design) then + + if Get_Kind (Get_Library_Unit (Design)) + = Iir_Kind_Configuration_Declaration + then + -- Defer code generation of configuration declaration. + -- (default binding may change between analysis and + -- elaboration). + Translation.Translate (Design, False); + else + Translation.Translate (Design, True); + end if; + + if Errorout.Nbr_Errors > 0 then + -- This can happen (foreign attribute). + raise Compilation_Error; + end if; + end if; + + Design := Get_Chain (Design); + end loop; + end if; + + -- Save the working library. + Libraries.Save_Work_Library; + end case; + if Flag_Expect_Failure then + return False; + else + return True; + end if; + exception + --when File_Error => + -- Error_Msg_Option ("cannot open file '" & Filename.all & "'"); + -- return False; + when Compilation_Error + | Parse_Error => + if Flag_Expect_Failure then + -- Very brutal... + GNAT.OS_Lib.OS_Exit (0); + end if; + return False; + when Option_Error => + return False; + when E: others => + Bug.Disp_Bug_Box (E); + raise; + end Parse; +end Ortho_Front; diff --git a/src/vhdl/translate/trans_analyzes.adb b/src/vhdl/translate/trans_analyzes.adb new file mode 100644 index 000000000..8147e93bd --- /dev/null +++ b/src/vhdl/translate/trans_analyzes.adb @@ -0,0 +1,182 @@ +-- Analysis for translation. +-- Copyright (C) 2009 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Iirs_Utils; use Iirs_Utils; +with Iirs_Walk; use Iirs_Walk; +with Disp_Vhdl; +with Ada.Text_IO; +with Errorout; + +package body Trans_Analyzes is + Driver_List : Iir_List; + + Has_After : Boolean; + function Extract_Driver_Target (Target : Iir) return Walk_Status + is + Base : Iir; + Prefix : Iir; + begin + Base := Get_Object_Prefix (Target); + -- Assigment to subprogram interface does not create a driver. + if Get_Kind (Base) = Iir_Kind_Interface_Signal_Declaration + and then + Get_Kind (Get_Parent (Base)) = Iir_Kind_Procedure_Declaration + then + return Walk_Continue; + end if; + + Prefix := Get_Longuest_Static_Prefix (Target); + Add_Element (Driver_List, Prefix); + if Has_After then + Set_After_Drivers_Flag (Base, True); + end if; + return Walk_Continue; + end Extract_Driver_Target; + + function Extract_Driver_Stmt (Stmt : Iir) return Walk_Status + is + Status : Walk_Status; + pragma Unreferenced (Status); + We : Iir; + begin + case Get_Kind (Stmt) is + when Iir_Kind_Signal_Assignment_Statement => + We := Get_Waveform_Chain (Stmt); + if We /= Null_Iir + and then Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Kind (Get_We_Value (We)) /= Iir_Kind_Null_Literal + then + Has_After := False; + else + Has_After := True; + end if; + Status := Walk_Assignment_Target + (Get_Target (Stmt), Extract_Driver_Target'Access); + when Iir_Kind_Procedure_Call_Statement => + declare + Call : constant Iir := Get_Procedure_Call (Stmt); + Assoc : Iir; + Formal : Iir; + Inter : Iir; + begin + -- Very pessimist. + Has_After := True; + + Assoc := Get_Parameter_Association_Chain (Call); + Inter := Get_Interface_Declaration_Chain + (Get_Implementation (Call)); + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal = Null_Iir then + Formal := Inter; + Inter := Get_Chain (Inter); + else + Formal := Get_Association_Interface (Assoc); + end if; + if Get_Kind (Assoc) + = Iir_Kind_Association_Element_By_Expression + and then + Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Formal) /= Iir_In_Mode + then + Status := Extract_Driver_Target (Get_Actual (Assoc)); + end if; + Assoc := Get_Chain (Assoc); + end loop; + end; + when others => + null; + end case; + return Walk_Continue; + end Extract_Driver_Stmt; + + procedure Extract_Drivers_Sequential_Stmt_Chain (Chain : Iir) + is + Status : Walk_Status; + pragma Unreferenced (Status); + begin + Status := Walk_Sequential_Stmt_Chain (Chain, Extract_Driver_Stmt'Access); + end Extract_Drivers_Sequential_Stmt_Chain; + + procedure Extract_Drivers_Declaration_Chain (Chain : Iir) + is + Decl : Iir := Chain; + begin + while Decl /= Null_Iir loop + + -- Only procedures and impure functions may contain assignment. + if Get_Kind (Decl) = Iir_Kind_Procedure_Body + or else (Get_Kind (Decl) = Iir_Kind_Function_Body + and then + not Get_Pure_Flag (Get_Subprogram_Specification (Decl))) + then + Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Decl)); + Extract_Drivers_Sequential_Stmt_Chain + (Get_Sequential_Statement_Chain (Decl)); + end if; + + Decl := Get_Chain (Decl); + end loop; + end Extract_Drivers_Declaration_Chain; + + function Extract_Drivers (Proc : Iir) return Iir_List + is + begin + Driver_List := Create_Iir_List; + Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Proc)); + Extract_Drivers_Sequential_Stmt_Chain + (Get_Sequential_Statement_Chain (Proc)); + + return Driver_List; + end Extract_Drivers; + + procedure Free_Drivers_List (List : in out Iir_List) + is + El : Iir; + begin + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Set_After_Drivers_Flag (Get_Object_Prefix (El), False); + end loop; + Destroy_Iir_List (List); + end Free_Drivers_List; + + procedure Dump_Drivers (Proc : Iir; List : Iir_List) + is + use Ada.Text_IO; + use Errorout; + El : Iir; + begin + Put_Line ("List of drivers for " & Disp_Node (Proc) & ":"); + Put_Line (" (declared at " & Disp_Location (Proc) & ")"); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_After_Drivers_Flag (Get_Object_Prefix (El)) then + Put ("* "); + else + Put (" "); + end if; + Disp_Vhdl.Disp_Vhdl (El); + New_Line; + end loop; + end Dump_Drivers; + +end Trans_Analyzes; diff --git a/src/vhdl/translate/trans_analyzes.ads b/src/vhdl/translate/trans_analyzes.ads new file mode 100644 index 000000000..ecebb7597 --- /dev/null +++ b/src/vhdl/translate/trans_analyzes.ads @@ -0,0 +1,31 @@ +-- Analysis for translation. +-- Copyright (C) 2009 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 GCC; 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 Trans_Analyzes is + -- Extract a list of drivers from PROC. + function Extract_Drivers (Proc : Iir) return Iir_List; + + -- Free the list. + procedure Free_Drivers_List (List : in out Iir_List); + + -- Dump list of drivers (LIST) for process PROC. + procedure Dump_Drivers (Proc : Iir; List : Iir_List); + +end Trans_Analyzes; diff --git a/src/vhdl/translate/trans_be.adb b/src/vhdl/translate/trans_be.adb new file mode 100644 index 000000000..dd1b6c338 --- /dev/null +++ b/src/vhdl/translate/trans_be.adb @@ -0,0 +1,182 @@ +-- Back-end for translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; 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 Disp_Tree; +with Disp_Vhdl; +with Sem; +with Canon; +with Translation; +with Errorout; use Errorout; +with Post_Sems; +with Flags; +with Ada.Text_IO; +with Back_End; + +package body Trans_Be is + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False) + is + use Ada.Text_IO; + Lib : Iir; + begin + -- No need to semantize during elaboration. + --if Flags.Will_Elaborate then + -- return; + --end if; + + Lib := Get_Library_Unit (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Parse then + Disp_Tree.Disp_Tree (Unit); + end if; + + -- Semantic analysis. + if Flags.Verbose then + Put_Line ("semantize " & Disp_Node (Lib)); + 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; + + -- Canonalisation. + ------------------ + if Flags.Verbose then + Put_Line ("canonicalize " & Disp_Node (Lib)); + end if; + + Canon.Canonicalize (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Canon 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_Canon then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + if Flags.Flag_Elaborate then + if Get_Kind (Lib) = Iir_Kind_Architecture_Body then + declare + Config : Iir_Design_Unit; + begin + Config := Canon.Create_Default_Configuration_Declaration (Lib); + Set_Default_Configuration_Declaration (Lib, 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; + + -- Do not translate during elaboration. + -- This is done directly in Translation.Chap12. + return; + end if; + + -- Translation + --------------- + if not Main then + -- Main units (those from the analyzed design file) are translated + -- directly by ortho_front. + + Translation.Translate (Unit, Main); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + end if; + + end Finish_Compilation; + + procedure Sem_Foreign (Decl : Iir) + is + use Translation; + Fi : Foreign_Info_Type; + pragma Unreferenced (Fi); + begin + case Get_Kind (Decl) is + when Iir_Kind_Architecture_Body => + Error_Msg_Sem ("FOREIGN architectures are not yet handled", Decl); + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + null; + when others => + Error_Kind ("sem_foreign", Decl); + end case; + -- Let is generate error messages. + Fi := Translate_Foreign_Id (Decl); + end Sem_Foreign; + + function Parse_Option (Opt : String) return Boolean is + begin + if Opt = "--dump-drivers" then + Translation.Flag_Dump_Drivers := True; + elsif Opt = "--no-direct-drivers" then + Translation.Flag_Direct_Drivers := False; + elsif Opt = "--no-range-checks" then + Translation.Flag_Range_Checks := False; + elsif Opt = "--no-index-checks" then + Translation.Flag_Index_Checks := False; + elsif Opt = "--no-identifiers" then + Translation.Flag_Discard_Identifiers := True; + else + return False; + end if; + return True; + end Parse_Option; + + procedure Disp_Option + is + procedure P (Str : String) renames Ada.Text_IO.Put_Line; + begin + P (" --dump-drivers dump processes drivers"); + end Disp_Option; + + procedure Register_Translation_Back_End is + begin + Back_End.Finish_Compilation := Finish_Compilation'Access; + Back_End.Sem_Foreign := Sem_Foreign'Access; + Back_End.Parse_Option := Parse_Option'Access; + Back_End.Disp_Option := Disp_Option'Access; + end Register_Translation_Back_End; +end Trans_Be; diff --git a/src/vhdl/translate/trans_be.ads b/src/vhdl/translate/trans_be.ads new file mode 100644 index 000000000..9ff06031b --- /dev/null +++ b/src/vhdl/translate/trans_be.ads @@ -0,0 +1,21 @@ +-- Back-end for translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Trans_Be is + procedure Register_Translation_Back_End; +end Trans_Be; + diff --git a/src/vhdl/translate/trans_decls.ads b/src/vhdl/translate/trans_decls.ads new file mode 100644 index 000000000..e104c71c4 --- /dev/null +++ b/src/vhdl/translate/trans_decls.ads @@ -0,0 +1,257 @@ +-- Declarations for well-known nodes generated by translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ortho_Nodes; use Ortho_Nodes; + +package Trans_Decls is + -- Procedures called in case of assert failed. + Ghdl_Assert_Failed : O_Dnode; + Ghdl_Ieee_Assert_Failed : O_Dnode; + Ghdl_Psl_Assert_Failed : O_Dnode; + + Ghdl_Psl_Cover : O_Dnode; + Ghdl_Psl_Cover_Failed : O_Dnode; + -- Procedure for report statement. + Ghdl_Report : O_Dnode; + + -- Register a process. + Ghdl_Process_Register : O_Dnode; + Ghdl_Sensitized_Process_Register : O_Dnode; + Ghdl_Postponed_Process_Register : O_Dnode; + Ghdl_Postponed_Sensitized_Process_Register : O_Dnode; + + Ghdl_Finalize_Register : O_Dnode; + + -- Wait subprograms. + -- Short forms. + Ghdl_Process_Wait_Timeout : O_Dnode; + Ghdl_Process_Wait_Exit : O_Dnode; + -- Complete form: + Ghdl_Process_Wait_Set_Timeout : O_Dnode; + Ghdl_Process_Wait_Add_Sensitivity : O_Dnode; + Ghdl_Process_Wait_Suspend : O_Dnode; + Ghdl_Process_Wait_Close : O_Dnode; + + -- Register a sensitivity for a process. + Ghdl_Process_Add_Sensitivity : O_Dnode; + + -- Register a driver for a process. + Ghdl_Process_Add_Driver : O_Dnode; + Ghdl_Signal_Add_Direct_Driver : O_Dnode; + + -- NOW variable. + Ghdl_Now : O_Dnode; + + -- Protected variables. + Ghdl_Protected_Enter : O_Dnode; + Ghdl_Protected_Leave : O_Dnode; + Ghdl_Protected_Init : O_Dnode; + Ghdl_Protected_Fini : O_Dnode; + + Ghdl_Signal_Set_Disconnect : O_Dnode; + Ghdl_Signal_Disconnect : O_Dnode; + + Ghdl_Signal_Driving : O_Dnode; + + Ghdl_Signal_Direct_Assign : O_Dnode; + + Ghdl_Signal_Simple_Assign_Error : O_Dnode; + Ghdl_Signal_Start_Assign_Error : O_Dnode; + Ghdl_Signal_Next_Assign_Error : O_Dnode; + + Ghdl_Signal_Start_Assign_Null : O_Dnode; + Ghdl_Signal_Next_Assign_Null : O_Dnode; + + Ghdl_Create_Signal_E8 : O_Dnode; + Ghdl_Signal_Init_E8 : O_Dnode; + Ghdl_Signal_Simple_Assign_E8 : O_Dnode; + Ghdl_Signal_Start_Assign_E8 : O_Dnode; + Ghdl_Signal_Next_Assign_E8 : O_Dnode; + Ghdl_Signal_Associate_E8 : O_Dnode; + Ghdl_Signal_Driving_Value_E8 : O_Dnode; + + Ghdl_Create_Signal_E32 : O_Dnode; + Ghdl_Signal_Init_E32 : O_Dnode; + Ghdl_Signal_Simple_Assign_E32 : O_Dnode; + Ghdl_Signal_Start_Assign_E32 : O_Dnode; + Ghdl_Signal_Next_Assign_E32 : O_Dnode; + Ghdl_Signal_Associate_E32 : O_Dnode; + Ghdl_Signal_Driving_Value_E32 : O_Dnode; + + Ghdl_Create_Signal_B1 : O_Dnode; + Ghdl_Signal_Init_B1 : O_Dnode; + Ghdl_Signal_Simple_Assign_B1 : O_Dnode; + Ghdl_Signal_Start_Assign_B1 : O_Dnode; + Ghdl_Signal_Next_Assign_B1 : O_Dnode; + Ghdl_Signal_Associate_B1 : O_Dnode; + Ghdl_Signal_Driving_Value_B1 : O_Dnode; + + Ghdl_Create_Signal_I32 : O_Dnode; + Ghdl_Signal_Init_I32 : O_Dnode; + Ghdl_Signal_Simple_Assign_I32 : O_Dnode; + Ghdl_Signal_Start_Assign_I32 : O_Dnode; + Ghdl_Signal_Next_Assign_I32 : O_Dnode; + Ghdl_Signal_Associate_I32 : O_Dnode; + Ghdl_Signal_Driving_Value_I32 : O_Dnode; + + Ghdl_Create_Signal_F64 : O_Dnode; + Ghdl_Signal_Init_F64 : O_Dnode; + Ghdl_Signal_Simple_Assign_F64 : O_Dnode; + Ghdl_Signal_Start_Assign_F64 : O_Dnode; + Ghdl_Signal_Next_Assign_F64 : O_Dnode; + Ghdl_Signal_Associate_F64 : O_Dnode; + Ghdl_Signal_Driving_Value_F64 : O_Dnode; + + Ghdl_Create_Signal_I64 : O_Dnode; + Ghdl_Signal_Init_I64 : O_Dnode; + Ghdl_Signal_Simple_Assign_I64 : O_Dnode; + Ghdl_Signal_Start_Assign_I64 : O_Dnode; + Ghdl_Signal_Next_Assign_I64 : O_Dnode; + Ghdl_Signal_Associate_I64 : O_Dnode; + Ghdl_Signal_Driving_Value_I64 : O_Dnode; + + Ghdl_Signal_In_Conversion : O_Dnode; + Ghdl_Signal_Out_Conversion : O_Dnode; + + Ghdl_Signal_Add_Source : O_Dnode; + Ghdl_Signal_Effective_Value : O_Dnode; + + Ghdl_Signal_Create_Resolution : O_Dnode; + + Ghdl_Signal_Name_Rti : O_Dnode; + Ghdl_Signal_Merge_Rti : O_Dnode; + + Ghdl_Signal_Get_Nbr_Drivers : O_Dnode; + Ghdl_Signal_Get_Nbr_Ports: O_Dnode; + Ghdl_Signal_Read_Driver : O_Dnode; + Ghdl_Signal_Read_Port : O_Dnode; + + -- Signal attribute. + Ghdl_Create_Stable_Signal : O_Dnode; + Ghdl_Create_Quiet_Signal : O_Dnode; + Ghdl_Create_Transaction_Signal : O_Dnode; + Ghdl_Signal_Attribute_Register_Prefix : O_Dnode; + Ghdl_Create_Delayed_Signal : O_Dnode; + + -- Guard signal. + Ghdl_Signal_Create_Guard : O_Dnode; + Ghdl_Signal_Guard_Dependence : O_Dnode; + + -- Predefined subprograms. + Ghdl_Memcpy : O_Dnode; + Ghdl_Deallocate : O_Dnode; + Ghdl_Malloc : O_Dnode; + Ghdl_Malloc0 : O_Dnode; + Ghdl_Real_Exp : O_Dnode; + Ghdl_Integer_Exp : O_Dnode; + + -- Procedure called in case of check failed. + Ghdl_Program_Error : O_Dnode; + Ghdl_Bound_Check_Failed_L1 : O_Dnode; + + -- Stack 2. + Ghdl_Stack2_Allocate : O_Dnode; + Ghdl_Stack2_Mark : O_Dnode; + Ghdl_Stack2_Release : O_Dnode; + + Std_Standard_Boolean_Rti : O_Dnode; + Std_Standard_Bit_Rti : O_Dnode; + + -- Predefined file subprograms. + Ghdl_Text_File_Elaborate : O_Dnode; + Ghdl_File_Elaborate : O_Dnode; + + Ghdl_Text_File_Finalize : O_Dnode; + Ghdl_File_Finalize : O_Dnode; + + Ghdl_Text_File_Open : O_Dnode; + Ghdl_File_Open : O_Dnode; + + Ghdl_Text_File_Open_Status : O_Dnode; + Ghdl_File_Open_Status : O_Dnode; + + Ghdl_Text_Write : O_Dnode; + Ghdl_Write_Scalar : O_Dnode; + + Ghdl_Read_Scalar : O_Dnode; + + Ghdl_Text_Read_Length : O_Dnode; + + Ghdl_Text_File_Close : O_Dnode; + Ghdl_File_Close : O_Dnode; + Ghdl_File_Flush : O_Dnode; + + Ghdl_File_Endfile : O_Dnode; + + -- 'Image attributes. + Ghdl_Image_B1 : O_Dnode; + Ghdl_Image_E8 : O_Dnode; + Ghdl_Image_E32 : O_Dnode; + Ghdl_Image_I32 : O_Dnode; + Ghdl_Image_P32 : O_Dnode; + Ghdl_Image_P64 : O_Dnode; + Ghdl_Image_F64 : O_Dnode; + + -- 'Value attributes + Ghdl_Value_B1 : O_Dnode; + Ghdl_Value_E8 : O_Dnode; + Ghdl_Value_E32 : O_Dnode; + Ghdl_Value_I32 : O_Dnode; + Ghdl_Value_P32 : O_Dnode; + Ghdl_Value_P64 : O_Dnode; + Ghdl_Value_F64 : O_Dnode; + + -- 'Path_Name + Ghdl_Get_Path_Name : O_Dnode; + Ghdl_Get_Instance_Name : O_Dnode; + + -- For PSL. + Ghdl_Std_Ulogic_To_Boolean_Array : O_Dnode; + + -- For std_logic_1164 (vhdl 2008). + Ghdl_Std_Ulogic_Match_Eq : O_Dnode; + Ghdl_Std_Ulogic_Match_Ne : O_Dnode; + Ghdl_Std_Ulogic_Match_Lt : O_Dnode; + Ghdl_Std_Ulogic_Match_Le : O_Dnode; + Ghdl_Std_Ulogic_Array_Match_Eq : O_Dnode; + Ghdl_Std_Ulogic_Array_Match_Ne : O_Dnode; + + -- For To_String (vhdl 2008). + Ghdl_To_String_I32 : O_Dnode; + Ghdl_To_String_F64 : O_Dnode; + Ghdl_To_String_F64_Digits : O_Dnode; + Ghdl_To_String_F64_Format : O_Dnode; + Ghdl_To_String_B1 : O_Dnode; + Ghdl_To_String_E8 : O_Dnode; + Ghdl_To_String_E32 : O_Dnode; + Ghdl_To_String_Char : O_Dnode; + Ghdl_To_String_P32 : O_Dnode; + Ghdl_To_String_P64 : O_Dnode; + Ghdl_Time_To_String_Unit : O_Dnode; + Ghdl_Array_Char_To_String_B1 : O_Dnode; + Ghdl_Array_Char_To_String_E8 : O_Dnode; + Ghdl_Array_Char_To_String_E32 : O_Dnode; + Ghdl_BV_To_String : O_Dnode; + Ghdl_BV_To_Ostring : O_Dnode; + Ghdl_BV_To_Hstring : O_Dnode; + + -- Register a package + Ghdl_Rti_Add_Package : O_Dnode; + Ghdl_Rti_Add_Top : O_Dnode; + + Ghdl_Elaborate : O_Dnode; +end Trans_Decls; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb new file mode 100644 index 000000000..7c5fbe85c --- /dev/null +++ b/src/vhdl/translate/translation.adb @@ -0,0 +1,31355 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002, 2003, 2004, 2005, 2006 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 GCC; 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_Deallocation; +with Interfaces; use Interfaces; +with Ortho_Nodes; use Ortho_Nodes; +with Ortho_Ident; use Ortho_Ident; +with Evaluation; use Evaluation; +with Flags; use Flags; +with Ada.Text_IO; +with Types; use Types; +with Errorout; use Errorout; +with Name_Table; -- use Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Libraries; +with Files_Map; +with Std_Names; +with Configuration; +with Interfaces.C_Streams; +with Sem_Names; +with Sem_Inst; +with Sem; +with Iir_Chains; use Iir_Chains; +with Nodes; +with Nodes_Meta; +with GNAT.Table; +with Ieee.Std_Logic_1164; +with Canon; +with Canon_PSL; +with PSL.Nodes; +with PSL.NFAs; +with PSL.NFAs.Utils; +with Trans_Decls; use Trans_Decls; +with Trans_Analyzes; + +package body Translation is + + -- Ortho type node for STD.BOOLEAN. + Std_Boolean_Type_Node : O_Tnode; + Std_Boolean_True_Node : O_Cnode; + Std_Boolean_False_Node : O_Cnode; + -- Array of STD.BOOLEAN. + Std_Boolean_Array_Type : O_Tnode; + -- Std_ulogic indexed array of STD.Boolean. + Std_Ulogic_Boolean_Array_Type : O_Tnode; + -- Ortho type node for string template pointer. + Std_String_Ptr_Node : O_Tnode; + Std_String_Node : O_Tnode; + + -- Ortho type for std.standard.integer. + Std_Integer_Otype : O_Tnode; + + -- Ortho type for std.standard.real. + Std_Real_Otype : O_Tnode; + + -- Ortho type node for std.standard.time. + Std_Time_Otype : O_Tnode; + + -- Node for the variable containing the current filename. + Current_Filename_Node : O_Dnode := O_Dnode_Null; + Current_Library_Unit : Iir := Null_Iir; + + -- Global declarations. + Ghdl_Ptr_Type : O_Tnode; + Sizetype : O_Tnode; + Ghdl_I32_Type : O_Tnode; + Ghdl_I64_Type : O_Tnode; + Ghdl_Real_Type : O_Tnode; + -- Constant character. + Char_Type_Node : O_Tnode; + -- Array of char. + Chararray_Type : O_Tnode; + -- Pointer to array of char. + Char_Ptr_Type : O_Tnode; + -- Array of char ptr. + Char_Ptr_Array_Type : O_Tnode; + Char_Ptr_Array_Ptr_Type : O_Tnode; + + Ghdl_Index_Type : O_Tnode; + Ghdl_Index_0 : O_Cnode; + Ghdl_Index_1 : O_Cnode; + + -- Type for a file (this is in fact a index in a private table). + Ghdl_File_Index_Type : O_Tnode; + Ghdl_File_Index_Ptr_Type : O_Tnode; + + -- Record containing a len and string fields. + Ghdl_Str_Len_Type_Node : O_Tnode; + Ghdl_Str_Len_Type_Len_Field : O_Fnode; + Ghdl_Str_Len_Type_Str_Field : O_Fnode; + Ghdl_Str_Len_Ptr_Node : O_Tnode; + Ghdl_Str_Len_Array_Type_Node : O_Tnode; + + -- Location. + Ghdl_Location_Type_Node : O_Tnode; + Ghdl_Location_Filename_Node : O_Fnode; + Ghdl_Location_Line_Node : O_Fnode; + Ghdl_Location_Col_Node : O_Fnode; + Ghdl_Location_Ptr_Node : O_Tnode; + + -- Allocate memory for a block. + Ghdl_Alloc_Ptr : O_Dnode; + + -- bool type. + Ghdl_Bool_Type : O_Tnode; + type Enode_Boolean_Array is array (Boolean) of O_Cnode; + Ghdl_Bool_Nodes : Enode_Boolean_Array; + Ghdl_Bool_False_Node : O_Cnode renames Ghdl_Bool_Nodes (False); + Ghdl_Bool_True_Node : O_Cnode renames Ghdl_Bool_Nodes (True); + + Ghdl_Bool_Array_Type : O_Tnode; + Ghdl_Bool_Array_Ptr : O_Tnode; + + -- Comparaison type. + Ghdl_Compare_Type : O_Tnode; + Ghdl_Compare_Lt : O_Cnode; + Ghdl_Compare_Eq : O_Cnode; + Ghdl_Compare_Gt : O_Cnode; + + -- Dir type. + Ghdl_Dir_Type_Node : O_Tnode; + Ghdl_Dir_To_Node : O_Cnode; + Ghdl_Dir_Downto_Node : O_Cnode; + + -- Signals. + Ghdl_Scalar_Bytes : O_Tnode; + Ghdl_Signal_Type : O_Tnode; + Ghdl_Signal_Value_Field : O_Fnode; + Ghdl_Signal_Driving_Value_Field : O_Fnode; + Ghdl_Signal_Last_Value_Field : O_Fnode; + Ghdl_Signal_Last_Event_Field : O_Fnode; + Ghdl_Signal_Last_Active_Field : O_Fnode; + Ghdl_Signal_Event_Field : O_Fnode; + Ghdl_Signal_Active_Field : O_Fnode; + Ghdl_Signal_Has_Active_Field : O_Fnode; + + Ghdl_Signal_Ptr : O_Tnode; + Ghdl_Signal_Ptr_Ptr : O_Tnode; + + type Object_Kind_Type is (Mode_Value, Mode_Signal); + + -- Well known identifiers. + Wki_This : O_Ident; + Wki_Size : O_Ident; + Wki_Res : O_Ident; + Wki_Dir_To : O_Ident; + Wki_Dir_Downto : O_Ident; + Wki_Left : O_Ident; + Wki_Right : O_Ident; + Wki_Dir : O_Ident; + Wki_Length : O_Ident; + Wki_I : O_Ident; + Wki_Instance : O_Ident; + Wki_Arch_Instance : O_Ident; + Wki_Name : O_Ident; + Wki_Sig : O_Ident; + Wki_Obj : O_Ident; + Wki_Rti : O_Ident; + Wki_Parent : O_Ident; + Wki_Filename : O_Ident; + Wki_Line : O_Ident; + Wki_Lo : O_Ident; + Wki_Hi : O_Ident; + Wki_Mid : O_Ident; + Wki_Cmp : O_Ident; + Wki_Upframe : O_Ident; + Wki_Frame : O_Ident; + Wki_Val : O_Ident; + Wki_L_Len : O_Ident; + Wki_R_Len : O_Ident; + + -- ALLOCATION_KIND defines the type of memory storage. + -- ALLOC_STACK means the object is allocated on the local stack and + -- deallocated at the end of the function. + -- ALLOC_SYSTEM for object created during design elaboration and whose + -- life is infinite. + -- ALLOC_RETURN for unconstrained object returns by function. + -- ALLOC_HEAP for object created by new. + type Allocation_Kind is + (Alloc_Stack, Alloc_Return, Alloc_Heap, Alloc_System); + + package Chap10 is + -- There are three data storage kind: global, local or instance. + -- For example, a constant can have: + -- * a global storage when declared inside a package. This storage + -- can be accessed from any point. + -- * a local storage when declared in a subprogram. This storage + -- can be accessed from the subprogram, is created when the subprogram + -- is called and destroy when the subprogram exit. + -- * an instance storage when declared inside a process. This storage + -- can be accessed from the process via an instance pointer, is + -- created during elaboration. + --procedure Push_Global_Factory (Storage : O_Storage); + --procedure Pop_Global_Factory; + procedure Set_Global_Storage (Storage : O_Storage); + + -- Set the global scope handling. + Global_Storage : O_Storage; + + -- Scope for variables. This is used both to build instances (so it + -- contains the record type that contains objects declared in that + -- scope) and to use instances (it contains the path to access to these + -- objects). + type Var_Scope_Type is private; + + type Var_Scope_Acc is access all Var_Scope_Type; + for Var_Scope_Acc'Storage_Size use 0; + + Null_Var_Scope : constant Var_Scope_Type; + + type Var_Type is private; + Null_Var : constant Var_Type; + + -- Return the record type for SCOPE. + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode; + + -- Return the size for instances of SCOPE. + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode; + + -- Return True iff SCOPE is defined. + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean; + + -- Create an empty and incomplete scope type for SCOPE using NAME. + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident); + + -- Declare a pointer PTR_TYPE with NAME to scope type SCOPE. + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode); + + -- Start to build an instance. + -- If INSTANCE_TYPE is not O_TNODE_NULL, it must be an uncompleted + -- record type, that will be completed. + procedure Push_Instance_Factory (Scope : Var_Scope_Acc); + + -- Manually add a field to the current instance being built. + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode; + + -- In the scope being built, add a field NAME that contain sub-scope + -- CHILD. CHILD is modified so that accesses to CHILD objects is done + -- via SCOPE. + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type); + + -- Return the offset of field for CHILD in its parent scope. + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode; + + -- Finish the building of the current instance and return the type + -- built. + procedure Pop_Instance_Factory (Scope : Var_Scope_Acc); + + -- Create a new scope, in which variable are created locally + -- (ie, on the stack). Always created unlocked. + procedure Push_Local_Factory; + + -- Destroy a local scope. + procedure Pop_Local_Factory; + + -- Set_Scope defines how to access to variables of SCOPE. + -- Variables defined in SCOPE can be accessed via field SCOPE_FIELD + -- in scope SCOPE_PARENT. + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + + -- Variables defined in SCOPE can be accessed by dereferencing + -- field SCOPE_FIELD defined in SCOPE_PARENT. + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + + -- Variables/scopes defined in SCOPE can be accessed via + -- dereference of parameter SCOPE_PARAM. + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode); + + -- Variables/scopes defined in SCOPE can be accessed via DECL. + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode); + + -- Variables/scopes defined in SCOPE can be accessed by derefencing + -- VAR. + procedure Set_Scope_Via_Var_Ptr + (Scope : in out Var_Scope_Type; Var : Var_Type); + + -- No more accesses to SCOPE_TYPE are allowed. Scopes must be cleared + -- before being set. + procedure Clear_Scope (Scope : in out Var_Scope_Type); + + -- Reset the identifier. + type Id_Mark_Type is limited private; + type Local_Identifier_Type is private; + + procedure Reset_Identifier_Prefix; + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : Name_Id; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type); + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type); + + -- Save/restore the local identifier number; this is used by package + -- body, which has the same prefix as the package declaration, so it + -- must continue local identifiers numbers. + -- This is used by subprogram bodies too. + procedure Save_Local_Identifier (Id : out Local_Identifier_Type); + procedure Restore_Local_Identifier (Id : Local_Identifier_Type); + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) + return O_Ident; + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident; + + -- Create an identifier from the current prefix. + function Create_Identifier return O_Ident; + + -- Create an identifier from IIR node ID with prefix. + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident; + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident; + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident; + -- Create a prefixed identifier from a string. + function Create_Identifier (Str : String) return O_Ident; + + -- Create an identifier for a variable. + -- IE, if the variable is global, prepend the prefix, + -- if the variable belong to an instance, no prefix is added. + type Var_Ident_Type is private; + function Create_Var_Identifier (Id : Iir) return Var_Ident_Type; + function Create_Var_Identifier (Id : String) return Var_Ident_Type; + function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) + return Var_Ident_Type; + function Create_Uniq_Identifier return Var_Ident_Type; + + -- Create variable NAME of type VTYPE in the current scope. + -- If the current scope is the global scope, then a variable is + -- created at the top level (using decl_global_storage). + -- If the current scope is not the global scope, then a field is added + -- to the current scope. + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Type; + + -- Create a global variable. + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Type; + + -- Create a global constant and initialize it to INITIAL_VALUE. + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Type; + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode); + + -- Return the (real) reference to a variable created by Create_Var. + function Get_Var (Var : Var_Type) return O_Lnode; + + -- Return a reference to the instance of type ITYPE. + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode; + + -- Return the address of the instance for block BLOCK. + function Get_Instance_Access (Block : Iir) return O_Enode; + + -- Return the storage for the variable VAR. + function Get_Alloc_Kind_For_Var (Var : Var_Type) return Allocation_Kind; + + -- Return TRUE iff VAR is stable, ie get_var (VAR) can be referenced + -- several times. + function Is_Var_Stable (Var : Var_Type) return Boolean; + + -- Used only to generate RTI. + function Is_Var_Field (Var : Var_Type) return Boolean; + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode; + function Get_Var_Label (Var : Var_Type) return O_Dnode; + + -- For package instantiation. + + -- Associate INST_SCOPE as the instantiated scope for ORIG_SCOPE. + procedure Push_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc); + + -- Remove the association for INST_SCOPE. + procedure Pop_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc); + + -- Get the associated instantiated scope for SCOPE. + function Instantiated_Var_Scope (Scope : Var_Scope_Acc) + return Var_Scope_Acc; + + -- Create a copy of VAR using instantiated scope (if needed). + function Instantiate_Var (Var : Var_Type) return Var_Type; + + -- Create a copy of SCOPE using instantiated scope (if needed). + function Instantiate_Var_Scope (Scope : Var_Scope_Type) + return Var_Scope_Type; + private + type Local_Identifier_Type is new Natural; + type Id_Mark_Type is record + Len : Natural; + Local_Id : Local_Identifier_Type; + end record; + + type Var_Ident_Type is record + Id : O_Ident; + end record; + + -- An instance contains all the data (variable, signals, constant...) + -- which are declared by an entity and an architecture. + -- (An architecture inherits the data of its entity). + -- + -- The processes and implicit guard signals of an entity/architecture + -- are translated into functions. The first argument of these functions + -- is a pointer to the instance. + + type Inst_Build_Kind_Type is (Local, Global, Instance); + type Inst_Build_Type (Kind : Inst_Build_Kind_Type); + type Inst_Build_Acc is access Inst_Build_Type; + type Inst_Build_Type (Kind : Inst_Build_Kind_Type) is record + Prev : Inst_Build_Acc; + Prev_Id_Start : Natural; + case Kind is + when Local => + -- Previous global storage. + Prev_Global_Storage : O_Storage; + when Global => + null; + when Instance => + Scope : Var_Scope_Acc; + Elements : O_Element_List; + end case; + end record; + + -- Kind of variable: + -- VAR_NONE: the variable doesn't exist. + -- VAR_GLOBAL: the variable is a global variable (static or not). + -- VAR_LOCAL: the variable is on the stack. + -- VAR_SCOPE: the variable is in the instance record. + type Var_Kind is (Var_None, Var_Global, Var_Local, Var_Scope); + + type Var_Type (Kind : Var_Kind := Var_None) is record + case Kind is + when Var_None => + null; + when Var_Global + | Var_Local => + E : O_Dnode; + when Var_Scope => + I_Field : O_Fnode; + I_Scope : Var_Scope_Acc; + end case; + end record; + + Null_Var : constant Var_Type := (Kind => Var_None); + + type Var_Scope_Kind is (Var_Scope_None, + Var_Scope_Ptr, + Var_Scope_Decl, + Var_Scope_Field, + Var_Scope_Field_Ptr); + + type Var_Scope_Type (Kind : Var_Scope_Kind := Var_Scope_None) is record + Scope_Type : O_Tnode := O_Tnode_Null; + + case Kind is + when Var_Scope_None => + -- Not set, cannot be referenced. + null; + when Var_Scope_Ptr + | Var_Scope_Decl => + -- Instance for entity, architecture, component, subprogram, + -- resolver, process, guard function, PSL directive, PSL cover, + -- PSL assert, component instantiation elaborator + D : O_Dnode; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + -- For an entity: the architecture. + -- For an architecture: ptr to a generate subblock. + -- For a subprogram: parent frame + Field : O_Fnode; + Up_Link : Var_Scope_Acc; + end case; + end record; + + Null_Var_Scope : constant Var_Scope_Type := (Scope_Type => O_Tnode_Null, + Kind => Var_Scope_None); + + end Chap10; + use Chap10; + + package Chap1 is + -- Declare types for block BLK + procedure Start_Block_Decl (Blk : Iir); + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration); + + -- Generate code to initialize generics of instance INSTANCE of ENTITY + -- using the default values. + -- This is used when ENTITY is at the top of a design hierarchy. + procedure Translate_Entity_Init (Entity : Iir); + + procedure Translate_Architecture_Body (Arch : Iir); + + -- CONFIG may be one of: + -- * configuration_declaration + -- * component_configuration + procedure Translate_Configuration_Declaration (Config : Iir); + end Chap1; + + package Chap2 is + -- Subprogram specification being currently translated. This is used + -- for the return statement. + Current_Subprogram : Iir := Null_Iir; + + procedure Translate_Subprogram_Interfaces (Spec : Iir); + procedure Elab_Subprogram_Interfaces (Spec : Iir); + + procedure Translate_Subprogram_Declaration (Spec : Iir); + procedure Translate_Subprogram_Body (Subprg : Iir); + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type); + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration); + procedure Translate_Package_Body (Decl : Iir_Package_Body); + procedure Translate_Package_Instantiation_Declaration (Inst : Iir); + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir); + + -- Add info for an interface_package_declaration or a + -- package_instantiation_declaration + procedure Instantiate_Info_Package (Inst : Iir); + + -- Elaborate packages that DESIGN_UNIT depends on (except std.standard). + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit); + + -- Declare an incomplete record type DECL_TYPE and access PTR_TYPE to + -- it. The names are respectively INSTTYPE and INSTPTR. + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode); + + -- Subprograms instances. + -- + -- Subprograms declared inside entities, architecture, blocks + -- or processes (but not inside packages) may access to data declared + -- outside the subprogram (and this with a life longer than the + -- subprogram life). These data correspond to constants, variables, + -- files, signals or types. However these data are not shared between + -- instances of the same entity, architecture... Subprograms instances + -- is the way subprograms access to these data. + -- One subprogram instance corresponds to a record. + + -- Type to save an old instance builder. Subprograms may have at most + -- one instance. If they need severals (for example a protected + -- subprogram), the most recent one will have a reference to the + -- previous one. + type Subprg_Instance_Stack is limited private; + + -- Declare an instance to be added for subprograms. + -- DECL is the node for which the instance is created. This is used by + -- PUSH_SCOPE. + -- PTR_TYPE is a pointer to DECL_TYPE. + -- IDENT is an identifier for the interface. + -- The previous instance is stored to PREV. It must be restored with + -- Pop_Subprg_Instance. + -- Add_Subprg_Instance_Interfaces will add an interface of name IDENT + -- and type PTR_TYPE for every instance declared by + -- PUSH_SUBPRG_INSTANCE. + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + Prev : out Subprg_Instance_Stack); + + -- Since local subprograms has a direct access to its father interfaces, + -- they do not required instances interfaces. + -- These procedures are provided to temporarly disable the addition of + -- instances interfaces. Use Pop_Subpg_Instance to restore to the + -- previous state. + procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack); + + -- Revert of the previous subprogram. + -- Instances must be removed in opposite order they are added. + procedure Pop_Subprg_Instance (Ident : O_Ident; + Prev : Subprg_Instance_Stack); + + -- True iff there is currently a subprogram instance. + function Has_Current_Subprg_Instance return Boolean; + + -- Contains the subprogram interface for the instance. + type Subprg_Instance_Type is private; + Null_Subprg_Instance : constant Subprg_Instance_Type; + + -- Add interfaces during the creation of a subprogram. + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type); + + -- Add a field in the current factory that reference the current + -- instance. + procedure Add_Subprg_Instance_Field (Field : out O_Fnode); + + -- Associate values to the instance interface during invocation of a + -- subprogram. + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type); + + -- Get the value to be associated to the instance interface. + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode; + + -- True iff VARS is associated with an instance. + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean; + + -- Assign the instance field FIELD of VAR. + procedure Set_Subprg_Instance_Field + (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type); + + -- To be called at the beginning and end of a subprogram body creation. + -- Call PUSH_SCOPE for the subprogram intances. + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type); + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type); + + -- Call Push_Scope to reference instance from FIELD. + procedure Start_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode); + procedure Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode); + + -- Same as above, but for IIR. + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir); + + procedure Start_Subprg_Instance_Use (Subprg : Iir); + procedure Finish_Subprg_Instance_Use (Subprg : Iir); + + function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) + return Subprg_Instance_Type; + private + type Subprg_Instance_Type is record + Inter : O_Dnode; + Inter_Type : O_Tnode; + Scope : Var_Scope_Acc; + end record; + Null_Subprg_Instance : constant Subprg_Instance_Type := + (O_Dnode_Null, O_Tnode_Null, null); + + type Subprg_Instance_Stack is record + Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + end record; + + Null_Subprg_Instance_Stack : constant Subprg_Instance_Stack := + (null, O_Tnode_Null, O_Ident_Nul); + + Current_Subprg_Instance : Subprg_Instance_Stack := + Null_Subprg_Instance_Stack; + end Chap2; + + package Chap5 is + -- Attribute specification. + procedure Translate_Attribute_Specification + (Spec : Iir_Attribute_Specification); + procedure Elab_Attribute_Specification + (Spec : Iir_Attribute_Specification); + + -- Disconnection specification. + procedure Elab_Disconnection_Specification + (Spec : Iir_Disconnection_Specification); + + -- Elab an unconstrained port. + procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir); + + procedure Elab_Generic_Map_Aspect (Mapping : Iir); + + -- There are 4 cases of generic/port map: + -- 1) component instantiation + -- 2) component configuration (association of a component with an entity + -- / architecture) + -- 3) block header + -- 4) direct (entity + architecture or configuration) instantiation + -- + -- MAPPING is the node containing the generic/port map aspects. + procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir); + end Chap5; + + + package Chap8 is + procedure Translate_Statements_Chain (First : Iir); + + -- Return true if there is a return statement in the chain. + function Translate_Statements_Chain_Has_Return (First : Iir) + return Boolean; + + -- Create a case branch for CHOICE. + -- Used by case statement and aggregates. + procedure Translate_Case_Choice + (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block); + + -- Inc or dec by VAL ITERATOR according to DIR. + -- Used for loop statements. + procedure Gen_Update_Iterator (Iterator : O_Dnode; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir); + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir); + end Chap8; + + package Chap9 is + procedure Translate_Block_Declarations (Block : Iir; Origin : Iir); + procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir); + procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir); + + -- Generate code to instantiate an entity. + -- ASPECT must be an entity_aspect. + -- MAPPING must be a node with get_port/generic_map_aspect_list. + -- PARENT is the block in which the instantiation is done. + -- CONFIG_OVERRIDE, if set, is the configuration to use; if not set, the + -- configuration to use is determined from ASPECT. + procedure Translate_Entity_Instantiation + (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir); + + end Chap9; + + package Rtis is + -- Run-Time Information (RTI) Kind. + Ghdl_Rtik : O_Tnode; + Ghdl_Rtik_Top : O_Cnode; + Ghdl_Rtik_Library : O_Cnode; + Ghdl_Rtik_Package : O_Cnode; + Ghdl_Rtik_Package_Body : O_Cnode; + Ghdl_Rtik_Entity : O_Cnode; + Ghdl_Rtik_Architecture : O_Cnode; + Ghdl_Rtik_Process : O_Cnode; + Ghdl_Rtik_Block : O_Cnode; + Ghdl_Rtik_If_Generate : O_Cnode; + Ghdl_Rtik_For_Generate : O_Cnode; + Ghdl_Rtik_Instance : O_Cnode; + Ghdl_Rtik_Constant : O_Cnode; + Ghdl_Rtik_Iterator : O_Cnode; + Ghdl_Rtik_Variable : O_Cnode; + Ghdl_Rtik_Signal : O_Cnode; + Ghdl_Rtik_File : O_Cnode; + Ghdl_Rtik_Port : O_Cnode; + Ghdl_Rtik_Generic : O_Cnode; + Ghdl_Rtik_Alias : O_Cnode; + Ghdl_Rtik_Guard : O_Cnode; + Ghdl_Rtik_Component : O_Cnode; + Ghdl_Rtik_Attribute : O_Cnode; + Ghdl_Rtik_Type_B1 : O_Cnode; + Ghdl_Rtik_Type_E8 : O_Cnode; + Ghdl_Rtik_Type_E32 : O_Cnode; + Ghdl_Rtik_Type_I32 : O_Cnode; + Ghdl_Rtik_Type_I64 : O_Cnode; + Ghdl_Rtik_Type_F64 : O_Cnode; + Ghdl_Rtik_Type_P32 : O_Cnode; + Ghdl_Rtik_Type_P64 : O_Cnode; + Ghdl_Rtik_Type_Access : O_Cnode; + Ghdl_Rtik_Type_Array : O_Cnode; + Ghdl_Rtik_Type_Record : O_Cnode; + Ghdl_Rtik_Type_File : O_Cnode; + Ghdl_Rtik_Subtype_Scalar : O_Cnode; + Ghdl_Rtik_Subtype_Array : O_Cnode; + Ghdl_Rtik_Subtype_Unconstrained_Array : O_Cnode; + Ghdl_Rtik_Subtype_Record : O_Cnode; + Ghdl_Rtik_Subtype_Access : O_Cnode; + Ghdl_Rtik_Type_Protected : O_Cnode; + Ghdl_Rtik_Element : O_Cnode; + Ghdl_Rtik_Unit64 : O_Cnode; + Ghdl_Rtik_Unitptr : O_Cnode; + Ghdl_Rtik_Attribute_Transaction : O_Cnode; + Ghdl_Rtik_Attribute_Quiet : O_Cnode; + Ghdl_Rtik_Attribute_Stable : O_Cnode; + Ghdl_Rtik_Psl_Assert : O_Cnode; + Ghdl_Rtik_Error : O_Cnode; + + -- RTI types. + Ghdl_Rti_Depth : O_Tnode; + Ghdl_Rti_U8 : O_Tnode; + + -- Common node. + Ghdl_Rti_Common : O_Tnode; + Ghdl_Rti_Common_Kind : O_Fnode; + Ghdl_Rti_Common_Depth : O_Fnode; + Ghdl_Rti_Common_Mode : O_Fnode; + Ghdl_Rti_Common_Max_Depth : O_Fnode; + + -- Node accesses and arrays. + Ghdl_Rti_Access : O_Tnode; + Ghdl_Rti_Array : O_Tnode; + Ghdl_Rti_Arr_Acc : O_Tnode; + + -- Instance link. + -- This is a structure at the beginning of each entity/architecture + -- instance. This allow the run-time to find the parent of an instance. + Ghdl_Entity_Link_Type : O_Tnode; + -- RTI for this instance. + Ghdl_Entity_Link_Rti : O_Fnode; + -- RTI of the parent, which has instancied the instance. + Ghdl_Entity_Link_Parent : O_Fnode; + + Ghdl_Component_Link_Type : O_Tnode; + -- Pointer to a Ghdl_Entity_Link_Type, which is the entity instantiated. + Ghdl_Component_Link_Instance : O_Fnode; + -- RTI for the component instantiation statement. + Ghdl_Component_Link_Stmt : O_Fnode; + + -- Access to Ghdl_Entity_Link_Type. + Ghdl_Entity_Link_Acc : O_Tnode; + -- Access to a Ghdl_Component_Link_Type. + Ghdl_Component_Link_Acc : O_Tnode; + + -- Generate initial rti declarations. + procedure Rti_Initialize; + + -- Get address (as Ghdl_Rti_Access) of constant RTI. + function New_Rti_Address (Rti : O_Dnode) return O_Cnode; + + -- Generate rtis for a library unit. + procedure Generate_Unit (Lib_Unit : Iir); + + -- Generate a constant declaration for SIG; but do not set its value. + procedure Generate_Signal_Rti (Sig : Iir); + + -- Generate RTIs for subprogram body BOD. + procedure Generate_Subprogram_Body (Bod : Iir); + + -- Generate RTI for LIB. If PUBLIC is FALSE, only generate the + -- declaration as external. + procedure Generate_Library (Lib : Iir_Library_Declaration; + Public : Boolean); + + -- Generate RTI for the top of the hierarchy. Return the maximum number + -- of packages. + procedure Generate_Top (Nbr_Pkgs : out Natural); + + -- Add two associations to ASSOC to add an rti_context for NODE. + procedure Associate_Rti_Context + (Assoc : in out O_Assoc_List; Node : Iir); + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List); + + function Get_Context_Rti (Node : Iir) return O_Cnode; + function Get_Context_Addr (Node : Iir) return O_Enode; + end Rtis; + + type Ortho_Info_Kind is + ( + Kind_Type, + Kind_Incomplete_Type, + Kind_Index, + Kind_Expr, + Kind_Subprg, + Kind_Object, + Kind_Alias, + Kind_Iterator, + Kind_Interface, + Kind_Disconnect, + Kind_Process, + Kind_Psl_Directive, + Kind_Loop, + Kind_Block, + Kind_Component, + Kind_Field, + Kind_Package, + Kind_Package_Instance, + Kind_Config, + Kind_Assoc, + Kind_Str_Choice, + Kind_Design_File, + Kind_Library + ); + + type Ortho_Info_Type_Kind is + ( + Kind_Type_Scalar, + Kind_Type_Array, + Kind_Type_Record, + Kind_Type_File, + Kind_Type_Protected + ); + type O_Tnode_Array is array (Object_Kind_Type) of O_Tnode; + type O_Fnode_Array is array (Object_Kind_Type) of O_Fnode; + + type Rti_Depth_Type is new Natural range 0 .. 255; + + type Ortho_Info_Type_Type (Kind : Ortho_Info_Type_Kind := Kind_Type_Scalar) + is record + -- For all types: + -- This is the maximum depth of RTI, that is the max of the depth of + -- the type itself and every types it depends on. + Rti_Max_Depth : Rti_Depth_Type; + + case Kind is + when Kind_Type_Scalar => + -- For scalar types: + -- True if no need to check against low/high bound. + Nocheck_Low : Boolean := False; + Nocheck_Hi : Boolean := False; + + -- Ortho type for the range record type. + Range_Type : O_Tnode; + + -- Ortho type for an access to the range record type. + Range_Ptr_Type : O_Tnode; + + -- Tree for the range record declaration. + Range_Var : Var_Type; + + -- Fields of TYPE_RANGE_TYPE. + Range_Left : O_Fnode; + Range_Right : O_Fnode; + Range_Dir : O_Fnode; + Range_Length : O_Fnode; + + when Kind_Type_Array => + Base_Type : O_Tnode_Array; + Base_Ptr_Type : O_Tnode_Array; + Bounds_Type : O_Tnode; + Bounds_Ptr_Type : O_Tnode; + + Base_Field : O_Fnode_Array; + Bounds_Field : O_Fnode_Array; + + -- True if the array bounds are static. + Static_Bounds : Boolean; + + -- Variable containing the bounds for a constrained array. + Array_Bounds : Var_Type; + + -- Variable containing a 1 length bound for unidimensional + -- unconstrained arrays. + Array_1bound : Var_Type; + + -- Variable containing the description for each index. + Array_Index_Desc : Var_Type; + + when Kind_Type_Record => + -- Variable containing the description for each element. + Record_El_Desc : Var_Type; + + when Kind_Type_File => + -- Constant containing the signature of the file. + File_Signature : O_Dnode; + + when Kind_Type_Protected => + Prot_Scope : aliased Var_Scope_Type; + + -- Init procedure for the protected type. + Prot_Init_Subprg : O_Dnode; + Prot_Init_Instance : Chap2.Subprg_Instance_Type; + -- Final procedure. + Prot_Final_Subprg : O_Dnode; + Prot_Final_Instance : Chap2.Subprg_Instance_Type; + -- The outer instance, if any. + Prot_Subprg_Instance_Field : O_Fnode; + -- The LOCK field in the object type + Prot_Lock_Field : O_Fnode; + end case; + end record; + +-- Ortho_Info_Type_Scalar_Init : constant Ortho_Info_Type_Type := +-- (Kind => Kind_Type_Scalar, +-- Range_Type => O_Tnode_Null, +-- Range_Ptr_Type => O_Tnode_Null, +-- Range_Var => null, +-- Range_Left => O_Fnode_Null, +-- Range_Right => O_Fnode_Null, +-- Range_Dir => O_Fnode_Null, +-- Range_Length => O_Fnode_Null); + + Ortho_Info_Type_Array_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Array, + Rti_Max_Depth => 0, + Base_Type => (O_Tnode_Null, O_Tnode_Null), + Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null), + Bounds_Type => O_Tnode_Null, + Bounds_Ptr_Type => O_Tnode_Null, + Base_Field => (O_Fnode_Null, O_Fnode_Null), + Bounds_Field => (O_Fnode_Null, O_Fnode_Null), + Static_Bounds => False, + Array_Bounds => Null_Var, + Array_1bound => Null_Var, + Array_Index_Desc => Null_Var); + + Ortho_Info_Type_Record_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Record, + Rti_Max_Depth => 0, + Record_El_Desc => Null_Var); + + Ortho_Info_Type_File_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_File, + Rti_Max_Depth => 0, + File_Signature => O_Dnode_Null); + + Ortho_Info_Type_Prot_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Protected, + Rti_Max_Depth => 0, + Prot_Scope => Null_Var_Scope, + Prot_Init_Subprg => O_Dnode_Null, + Prot_Init_Instance => Chap2.Null_Subprg_Instance, + Prot_Final_Subprg => O_Dnode_Null, + Prot_Subprg_Instance_Field => O_Fnode_Null, + Prot_Final_Instance => Chap2.Null_Subprg_Instance, + Prot_Lock_Field => O_Fnode_Null); + + -- Mode of the type; roughly speaking, this corresponds to its size + -- (for scalars) or its layout (for composite types). + -- Used to select library subprograms for signals. + type Type_Mode_Type is + ( + -- Unknown mode. + Type_Mode_Unknown, + -- Boolean type, with 2 elements. + Type_Mode_B1, + -- Enumeration with at most 256 elements. + Type_Mode_E8, + -- Enumeration with more than 256 elements. + Type_Mode_E32, + -- Integer types. + Type_Mode_I32, + Type_Mode_I64, + -- Physical types. + Type_Mode_P32, + Type_Mode_P64, + -- Floating point type. + Type_Mode_F64, + -- File type. + Type_Mode_File, + -- Thin access. + Type_Mode_Acc, + + -- Fat access. + Type_Mode_Fat_Acc, + + -- Record. + Type_Mode_Record, + -- Protected type + Type_Mode_Protected, + -- Constrained array type (length is known at compile-time). + Type_Mode_Array, + -- Fat array type (used for unconstrained array). + Type_Mode_Fat_Array); + + subtype Type_Mode_Scalar is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_F64; + + subtype Type_Mode_Non_Composite is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Fat_Acc; + + -- Composite types, with the vhdl meaning: record and arrays. + subtype Type_Mode_Composite is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Array types. + subtype Type_Mode_Arrays is Type_Mode_Type range + Type_Mode_Array .. Type_Mode_Fat_Array; + + -- Thin types, ie types whose length is a scalar. + subtype Type_Mode_Thin is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Acc; + + -- Fat types, ie types whose length is longer than a scalar. + subtype Type_Mode_Fat is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Array; + + -- These parameters are passed by value, ie the argument of the subprogram + -- is the value of the object. + subtype Type_Mode_By_Value is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Acc; + + -- These parameters are passed by copy, ie a copy of the object is created + -- and the reference of the copy is passed. If the object is not + -- modified by the subprogram, the object could be passed by reference. + subtype Type_Mode_By_Copy is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Acc; + + -- The parameters are passed by reference, ie the argument of the + -- subprogram is an address to the object. + subtype Type_Mode_By_Ref is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Additional informations for a resolving function. + type Subprg_Resolv_Info is record + Resolv_Func : O_Dnode; + -- Parameter nodes. + Var_Instance : Chap2.Subprg_Instance_Type; + + -- Signals + Var_Vals : O_Dnode; + -- Driving vector. + Var_Vec : O_Dnode; + -- Length of Vector. + Var_Vlen : O_Dnode; + Var_Nbr_Drv : O_Dnode; + Var_Nbr_Ports : O_Dnode; + end record; + type Subprg_Resolv_Info_Acc is access Subprg_Resolv_Info; + + -- Complex types. + -- + -- A complex type is not a VHDL notion, but a translation notion. + -- A complex type is a composite type whose size is not known at compile + -- type. This happends in VHDL because a bound can be globally static. + -- Therefore, the length of an array may not be known at compile type, + -- and this propagates to composite types (record and array) if they + -- have such an element. This is different from unconstrained arrays. + -- + -- This occurs frequently in VHDL, and could even happen within + -- subprograms. + -- + -- Such types are always dynamically allocated (on the stack or on the + -- heap). They must be continuous in memory so that they could be copied + -- via memcpy/memmove. + -- + -- At runtime, the size of such type is computed. A builder procedure + -- is also created to setup inner pointers. This builder procedure should + -- be called at initialization, but also after a copy. + -- + -- Example: + -- 1) subtype bv_type is bit_vector (l to h); + -- variable a : bv_type + -- + -- This is represented by a pointer to an array of bit. No need for + -- builder procedure, as the element type is not complex. But there + -- is a size variable for the size of bv_type + -- + -- 2) type rec1_type is record + -- f1 : integer; + -- f2 : bv_type; + -- end record; + -- + -- This is represented by a pointer to a record. The 'f2' field is + -- an offset to an array of bit. The size of the object is the size + -- of the record (with f2 as a pointer) + the size of bv_type. + -- The alinment of the object is the maximum alignment of its sub- + -- objects: rec1 and bv_type. + -- A builder procedure is needed to initialize the 'f2' field. + -- The memory layout is: + -- +--------------+ + -- | rec1: f1 | + -- | f2 |---+ + -- +--------------+ | + -- | bv_type |<--+ + -- | ... | + -- +--------------+ + -- + -- 3) type rec2_type is record + -- g1: rec1_type; + -- g2: bv_type; + -- g3: bv_type; + -- end record; + -- + -- This is represented by a pointer to a record. All the three fields + -- are offset (relative to rec2). Alignment is the maximum alignment of + -- the sub-objects (rec2, rec1, bv_type x 3). + -- The memory layout is: + -- +--------------+ + -- | rec2: g1 |---+ + -- | g2 |---|---+ + -- | g3 |---|---|---+ + -- +--------------+ | | | + -- | rec1: f1 |<--+ | | + -- | f2 |---+ | | + -- +--------------+ | | | + -- | bv_type (f2) |<--+ | | + -- | ... | | | + -- +--------------+ | | + -- | bv_type (g2) |<------+ | + -- | ... | | + -- +--------------+ | + -- | bv_type (g3) |<----------+ + -- | ... | + -- +--------------+ + -- + -- 4) type bv_arr_type is array (natural range <>) of bv_type; + -- arr2 : bv_arr_type (1 to 4) + -- + -- This should be represented by a pointer to bv_type. + -- The memory layout is: + -- +--------------+ + -- | bv_type (1) | + -- | ... | + -- +--------------+ + -- | bv_type (2) | + -- | ... | + -- +--------------+ + -- | bv_type (3) | + -- | ... | + -- +--------------+ + -- | bv_type (4) | + -- | ... | + -- +--------------+ + + -- Additional info for complex types. + type Complex_Type_Info is record + -- Variable containing the size of the type. + -- This is defined only for types whose size is only known at + -- running time (and not a compile-time). + Size_Var : Var_Type; + + -- Variable containing the alignment of the type. + -- Only defined for recods and for Mode_Value. + -- Note: this is not optimal, because the alignment could be computed + -- at compile time, but there is no way to do that with ortho (no + -- operation on constants). Furthermore, the alignment is independent + -- of the instance, so there could be one global variable. But this + -- doesn't fit in the whole machinery (in particular, there is no + -- easy way to compute it once). As the overhead is very low, no need + -- to bother with this issue. + Align_Var : Var_Type; + + Builder_Need_Func : Boolean; + + -- Parameters for type builders. + -- NOTE: this is only set for types (and *not* for subtypes). + Builder_Instance : Chap2.Subprg_Instance_Type; + Builder_Base_Param : O_Dnode; + Builder_Bound_Param : O_Dnode; + Builder_Func : O_Dnode; + end record; + type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info; + type Complex_Type_Info_Acc is access Complex_Type_Arr_Info; + procedure Free_Complex_Type_Info is new Ada.Unchecked_Deallocation + (Complex_Type_Arr_Info, Complex_Type_Info_Acc); + + type Assoc_Conv_Info is record + -- The subprogram created to do the conversion. + Subprg : O_Dnode; + -- The local base block + Instance_Block : Iir; + -- and its address. + Instance_Field : O_Fnode; + -- The instantiated entity (if any). + Instantiated_Entity : Iir; + -- and its address. + Instantiated_Field : O_Fnode; + In_Field : O_Fnode; + Out_Field : O_Fnode; + Record_Type : O_Tnode; + Record_Ptr_Type : O_Tnode; + end record; + + type Direct_Driver_Type is record + Sig : Iir; + Var : Var_Type; + end record; + type Direct_Driver_Arr is array (Natural range <>) of Direct_Driver_Type; + type Direct_Drivers_Acc is access Direct_Driver_Arr; + + type Ortho_Info_Type; + type Ortho_Info_Acc is access Ortho_Info_Type; + + type Ortho_Info_Type (Kind : Ortho_Info_Kind) is record + case Kind is + when Kind_Type => + -- Mode of the type. + Type_Mode : Type_Mode_Type := Type_Mode_Unknown; + + -- If true, the type is (still) incomplete. + Type_Incomplete : Boolean := False; + + -- For array only. True if the type is constrained with locally + -- static bounds. May have non locally-static bounds in some + -- of its sub-element (ie being a complex type). + Type_Locally_Constrained : Boolean := False; + + -- Additionnal info for complex types. + C : Complex_Type_Info_Acc := null; + + -- Ortho node which represents the type. + -- Type -> Ortho type + -- scalar -> scalar + -- record (complex or not) -> record + -- constrained non-complex array -> constrained array + -- constrained complex array -> the element + -- unconstrained array -> fat pointer + -- access to unconstrained array -> fat pointer + -- access (others) -> access + -- file -> file_index_type + -- protected -> instance + Ortho_Type : O_Tnode_Array; + + -- Ortho pointer to the type. This is always an access to the + -- ortho_type. + Ortho_Ptr_Type : O_Tnode_Array; + + -- Chain of temporary types to be destroyed at end of scope. + Type_Transient_Chain : Iir := Null_Iir; + + -- More info according to the type. + T : Ortho_Info_Type_Type; + + -- Run-time information. + Type_Rti : O_Dnode := O_Dnode_Null; + + when Kind_Incomplete_Type => + -- The declaration of the incomplete type. + Incomplete_Type : Iir; + Incomplete_Array : Ortho_Info_Acc; + + when Kind_Index => + -- Field declaration for array dimension. + Index_Field : O_Fnode; + + when Kind_Expr => + -- Ortho tree which represents the expression, used for + -- enumeration literals. + Expr_Node : O_Cnode; + + when Kind_Subprg => + -- True if the function can return a value stored in the secondary + -- stack. In this case, the caller must deallocate the area + -- allocated by the callee when the value was used. + Use_Stack2 : Boolean := False; + + -- Subprogram declaration node. + Ortho_Func : O_Dnode; + + -- For a function: + -- If the return value is not composite, then this field + -- must be O_DNODE_NULL. + -- If the return value is a composite type, then the caller must + -- give to the callee an area to put the result. This area is + -- given via an (hidden to the user) interface. Furthermore, + -- the function is translated into a procedure. + -- For a procedure: + -- If there are copy-out interfaces, they are gathered in a + -- record and a pointer to the record is passed to the + -- procedure. RES_INTERFACE is the interface for this pointer. + Res_Interface : O_Dnode := O_Dnode_Null; + + -- Field in the frame for a pointer to the RESULT structure. + Res_Record_Var : Var_Type := Null_Var; + + -- For a subprogram with a result interface: + -- Type definition for the record. + Res_Record_Type : O_Tnode := O_Tnode_Null; + -- Type definition for access to the record. + Res_Record_Ptr : O_Tnode := O_Tnode_Null; + + -- Access to the declarations within this subprogram. + Subprg_Frame_Scope : aliased Var_Scope_Type; + + -- Instances for the subprograms. + Subprg_Instance : Chap2.Subprg_Instance_Type := + Chap2.Null_Subprg_Instance; + + Subprg_Resolv : Subprg_Resolv_Info_Acc := null; + + -- Local identifier number, set by spec, continued by body. + Subprg_Local_Id : Local_Identifier_Type; + + -- If set, return should be converted into exit out of the + -- SUBPRG_EXIT loop and the value should be assigned to + -- SUBPRG_RESULT, if any. + Subprg_Exit : O_Snode := O_Snode_Null; + Subprg_Result : O_Dnode := O_Dnode_Null; + + when Kind_Object => + -- For constants: set when the object is defined as a constant. + Object_Static : Boolean; + -- The object itself. + Object_Var : Var_Type; + -- Direct driver for signal (if any). + Object_Driver : Var_Type := Null_Var; + -- RTI constant for the object. + Object_Rti : O_Dnode := O_Dnode_Null; + -- Function to compute the value of object (used for implicit + -- guard signal declaration). + Object_Function : O_Dnode := O_Dnode_Null; + + when Kind_Alias => + Alias_Var : Var_Type; + Alias_Kind : Object_Kind_Type; + + when Kind_Iterator => + Iterator_Var : Var_Type; + + when Kind_Interface => + -- Ortho declaration for the interface. If not null, there is + -- a corresponding ortho parameter for the interface. While + -- translating nested subprograms (that are unnested), + -- Interface_Field may be set to the corresponding field in the + -- FRAME record. So: + -- Node: not null, Field: null: parameter + -- Node: not null, Field: not null: parameter with a copy in + -- the FRAME record. + -- Node: null, Field: null: not possible + -- Node: null, Field: not null: field in RESULT record + Interface_Node : O_Dnode := O_Dnode_Null; + -- Field of the result record for copy-out arguments of procedure. + -- In that case, Interface_Node must be null. + Interface_Field : O_Fnode; + -- Type of the interface. + Interface_Type : O_Tnode; + + when Kind_Disconnect => + -- Variable which contains the time_expression of the + -- disconnection specification + Disconnect_Var : Var_Type; + + when Kind_Process => + Process_Scope : aliased Var_Scope_Type; + + -- Subprogram for the process. + Process_Subprg : O_Dnode; + + -- List of drivers if Flag_Direct_Drivers. + Process_Drivers : Direct_Drivers_Acc := null; + + -- RTI for the process. + Process_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Psl_Directive => + Psl_Scope : aliased Var_Scope_Type; + + -- Procedure for the state machine. + Psl_Proc_Subprg : O_Dnode; + -- Procedure for finalization. Handles EOS. + Psl_Proc_Final_Subprg : O_Dnode; + + -- Length of the state vector. + Psl_Vect_Len : Natural; + + -- Type of the state vector. + Psl_Vect_Type : O_Tnode; + + -- State vector variable. + Psl_Vect_Var : Var_Type; + + -- Boolean variable (for cover) + Psl_Bool_Var : Var_Type; + + -- RTI for the process. + Psl_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Loop => + -- Labels for the loop. + -- Used for exit/next from while-loop, and to exit from for-loop. + Label_Exit : O_Snode; + -- Used to next from for-loop, with an exit statment. + Label_Next : O_Snode; + + when Kind_Block => + -- Access to declarations of this block. + Block_Scope : aliased Var_Scope_Type; + + -- Instance type (ortho record) for declarations contained in the + -- block/entity/architecture. + Block_Decls_Ptr_Type : O_Tnode; + + -- For Entity: field in the instance type containing link to + -- parent. + -- For an instantiation: link in the parent block to the instance. + Block_Link_Field : O_Fnode; + + -- For an entity: must be o_fnode_null. + -- For an architecture: the entity field. + -- For a block, a component or a generate block: field in the + -- parent instance which contains the declarations for this + -- block. + Block_Parent_Field : O_Fnode; + + -- For a generate block: field in the block providing a chain to + -- the previous block (note: this may not be the parent, but + -- is a parent). + Block_Origin_Field : O_Fnode; + -- For an iterative block: boolean field set when the block + -- is configured. This is used to check if the block was already + -- configured since index and slice are not compelled to be + -- locally static. + Block_Configured_Field : O_Fnode; + + -- For iterative generate block: array of instances. + Block_Decls_Array_Type : O_Tnode; + Block_Decls_Array_Ptr_Type : O_Tnode; + + -- Subprogram which elaborates the block (for entity or arch). + Block_Elab_Subprg : O_Dnode; + -- Size of the block instance. + Block_Instance_Size : O_Dnode; + + -- Only for an entity: procedure that elaborate the packages this + -- units depend on. That must be done before elaborating the + -- entity and before evaluating default expressions in generics. + Block_Elab_Pkg_Subprg : O_Dnode; + + -- RTI constant for the block. + Block_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Component => + -- How to access to component interfaces. + Comp_Scope : aliased Var_Scope_Type; + + -- Instance for the component. + Comp_Ptr_Type : O_Tnode; + -- Field containing a pointer to the instance link. + Comp_Link : O_Fnode; + -- RTI for the component. + Comp_Rti_Const : O_Dnode; + + when Kind_Config => + -- Subprogram that configure the block. + Config_Subprg : O_Dnode; + + when Kind_Field => + -- Node for a record element declaration. + Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null); + + when Kind_Package => + -- Subprogram which elaborate the package spec/body. + -- External units should call the body elaborator. + -- The spec elaborator is called only from the body elaborator. + Package_Elab_Spec_Subprg : O_Dnode; + Package_Elab_Body_Subprg : O_Dnode; + + -- Instance for the elaborators. + Package_Elab_Spec_Instance : Chap2.Subprg_Instance_Type; + Package_Elab_Body_Instance : Chap2.Subprg_Instance_Type; + + -- Variable set to true when the package is elaborated. + Package_Elab_Var : Var_Type; + + -- RTI constant for the package. + Package_Rti_Const : O_Dnode; + + -- Access to declarations of the spec. + Package_Spec_Scope : aliased Var_Scope_Type; + + -- Instance type for uninstantiated package + Package_Spec_Ptr_Type : O_Tnode; + + Package_Body_Scope : aliased Var_Scope_Type; + Package_Body_Ptr_Type : O_Tnode; + + -- Field to the spec within the body. + Package_Spec_Field : O_Fnode; + + -- Local id, set by package declaration, continued by package + -- body. + Package_Local_Id : Local_Identifier_Type; + + when Kind_Package_Instance => + -- The variables containing the instance. There are two variables + -- for interface package: one for the spec, one for the body. + -- For package instantiation, only the variable for the body is + -- used. The variable for spec is added so that packages with + -- package interfaces don't need to know the body of their + -- interfaces. + Package_Instance_Spec_Var : Var_Type; + Package_Instance_Body_Var : Var_Type; + + -- Elaboration procedure for the instance. + Package_Instance_Elab_Subprg : O_Dnode; + + Package_Instance_Spec_Scope : aliased Var_Scope_Type; + Package_Instance_Body_Scope : aliased Var_Scope_Type; + + when Kind_Assoc => + -- Association informations. + Assoc_In : Assoc_Conv_Info; + Assoc_Out : Assoc_Conv_Info; + + when Kind_Str_Choice => + -- List of choices, used to sort them. + Choice_Chain : Ortho_Info_Acc; + -- Association index. + Choice_Assoc : Natural; + -- Corresponding choice simple expression. + Choice_Expr : Iir; + -- Corresponding choice. + Choice_Parent : Iir; + + when Kind_Design_File => + Design_Filename : O_Dnode; + + when Kind_Library => + Library_Rti_Const : O_Dnode; + end case; + end record; + + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => Ortho_Info_Acc, Object => Ortho_Info_Type); + + subtype Type_Info_Acc is Ortho_Info_Acc (Kind_Type); + subtype Incomplete_Type_Info_Acc is Ortho_Info_Acc (Kind_Incomplete_Type); + subtype Index_Info_Acc is Ortho_Info_Acc (Kind_Index); + subtype Subprg_Info_Acc is Ortho_Info_Acc (Kind_Subprg); + subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object); + subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias); + subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process); + subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Directive); + subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop); + subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block); + subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component); + subtype Field_Info_Acc is Ortho_Info_Acc (Kind_Field); + subtype Config_Info_Acc is Ortho_Info_Acc (Kind_Config); + subtype Assoc_Info_Acc is Ortho_Info_Acc (Kind_Assoc); + subtype Inter_Info_Acc is Ortho_Info_Acc (Kind_Interface); + subtype Design_File_Info_Acc is Ortho_Info_Acc (Kind_Design_File); + subtype Library_Info_Acc is Ortho_Info_Acc (Kind_Library); + + package Node_Infos is new GNAT.Table + (Table_Component_Type => Ortho_Info_Acc, + Table_Index_Type => Iir, + Table_Low_Bound => 0, + Table_Initial => 1024, + Table_Increment => 100); + + procedure Update_Node_Infos + is + use Nodes; + F, L : Iir; + begin + F := Node_Infos.Last; + L := Nodes.Get_Last_Node; + Node_Infos.Set_Last (L); + Node_Infos.Table (F + 1 .. L) := (others => null); + end Update_Node_Infos; + + procedure Set_Info (Target : Iir; Info : Ortho_Info_Acc) is + begin + if Node_Infos.Table (Target) /= null then + raise Internal_Error; + end if; + Node_Infos.Table (Target) := Info; + end Set_Info; + + procedure Clear_Info (Target : Iir) is + begin + Node_Infos.Table (Target) := null; + end Clear_Info; + + function Get_Info (Target : Iir) return Ortho_Info_Acc is + begin + return Node_Infos.Table (Target); + end Get_Info; + + -- Create an ortho_info field of kind KIND for iir node TARGET, and + -- return it. + function Add_Info (Target : Iir; Kind : Ortho_Info_Kind) + return Ortho_Info_Acc + is + Res : Ortho_Info_Acc; + begin + Res := new Ortho_Info_Type (Kind); + Set_Info (Target, Res); + return Res; + end Add_Info; + + procedure Free_Info (Target : Iir) + is + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Target); + if Info /= null then + Unchecked_Deallocation (Info); + Clear_Info (Target); + end if; + end Free_Info; + + procedure Free_Type_Info (Info : in out Type_Info_Acc) is + begin + if Info.C /= null then + Free_Complex_Type_Info (Info.C); + end if; + Unchecked_Deallocation (Info); + end Free_Type_Info; + + procedure Set_Ortho_Expr (Target : Iir; Expr : O_Cnode) + is + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Target, Kind_Expr); + Info.Expr_Node := Expr; + end Set_Ortho_Expr; + + function Get_Ortho_Expr (Target : Iir) return O_Cnode is + begin + return Get_Info (Target).Expr_Node; + end Get_Ortho_Expr; + + function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type) + return O_Tnode is + begin + return Get_Info (Target).Ortho_Type (Is_Sig); + end Get_Ortho_Type; + + function Get_Ortho_Decl (Subprg : Iir) return O_Dnode + is + begin + return Get_Info (Subprg).Ortho_Func; + end Get_Ortho_Decl; + + function Get_Resolv_Ortho_Decl (Func : Iir) return O_Dnode + is + Info : Subprg_Resolv_Info_Acc; + begin + Info := Get_Info (Func).Subprg_Resolv; + if Info = null then + -- Maybe the resolver is not used. + return O_Dnode_Null; + else + return Info.Resolv_Func; + end if; + end Get_Resolv_Ortho_Decl; + + -- Return true is INFO is a type info for a composite type, ie: + -- * a record + -- * an array (fat or thin) + -- * a fat pointer. + function Is_Composite (Info : Type_Info_Acc) return Boolean; + pragma Inline (Is_Composite); + + function Is_Composite (Info : Type_Info_Acc) return Boolean is + begin + return Info.Type_Mode in Type_Mode_Fat; + end Is_Composite; + + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean; + pragma Inline (Is_Complex_Type); + + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is + begin + return Tinfo.C /= null; + end Is_Complex_Type; + + -- In order to simplify the handling of Enode/Lnode, let's introduce + -- Mnode (yes, another node). + -- An Mnode is a typed union, containing either an Lnode or a Enode. + -- See Mstate for a description of the union. + -- The real data is contained insisde a record, so that the discriminant + -- can be changed. + type Mnode; + + -- State of an Mmode. + type Mstate is + ( + -- The Mnode contains an Enode, which can be either a value or a + -- pointer. + -- This Mnode can be used only once. + Mstate_E, + + -- The Mnode contains an Lnode representing a value. + -- This Lnode can be used only once. + Mstate_Lv, + + -- The Mnode contains an Lnode representing a pointer. + -- This Lnode can be used only once. + Mstate_Lp, + + -- The Mnode contains an Dnode for a variable representing a value. + -- This Dnode may be used several times. + Mstate_Dv, + + -- The Mnode contains an Dnode for a variable representing a pointer. + -- This Dnode may be used several times. + Mstate_Dp, + + -- Null Mnode. + Mstate_Null, + + -- The Mnode is invalid (such as already used). + Mstate_Bad); + + type Mnode1 (State : Mstate := Mstate_Bad) is record + -- True if the object is composite (its value cannot be read directly). + Comp : Boolean; + + -- Additionnal informations about the objects: kind and type. + K : Object_Kind_Type; + T : Type_Info_Acc; + + -- Ortho type of the object. + Vtype : O_Tnode; + + -- Type for a pointer to the object. + Ptype : O_Tnode; + + case State is + when Mstate_E => + E : O_Enode; + when Mstate_Lv => + Lv : O_Lnode; + when Mstate_Lp => + Lp : O_Lnode; + when Mstate_Dv => + Dv : O_Dnode; + when Mstate_Dp => + Dp : O_Dnode; + when Mstate_Bad + | Mstate_Null => + null; + end case; + end record; + --pragma Pack (Mnode1); + + type Mnode is record + M1 : Mnode1; + end record; + + -- Null Mnode. + Mnode_Null : constant Mnode := Mnode'(M1 => (State => Mstate_Null, + Comp => False, + K => Mode_Value, + Ptype => O_Tnode_Null, + Vtype => O_Tnode_Null, + T => null)); + + + -- Object kind of a Mnode + function Get_Object_Kind (M : Mnode) return Object_Kind_Type; + + -- Transform VAR to Mnode. + function Get_Var + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode; + + -- Return a stabilized node for M. + -- The former M is not usuable anymore. + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode; + + -- Stabilize M. + procedure Stabilize (M : in out Mnode); + + -- If M is not stable, create a variable containing the value of M. + -- M must be scalar (or access). + function Stabilize_Value (M : Mnode) return Mnode; + + -- Create a temporary of type INFO and kind KIND. + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode; + + package Chap3 is + -- Translate the subtype of an object, since an object can define + -- a subtype. + -- This can be done only for a declaration. + -- DECL must have an identifier and a type. + procedure Translate_Object_Subtype + (Decl : Iir; With_Vars : Boolean := True); + procedure Elab_Object_Subtype (Def : Iir); + + -- Translate the subtype of a literal. + -- This can be done not at declaration time, ie no variables are created + -- for this subtype. + --procedure Translate_Literal_Subtype (Def : Iir); + + -- Translation of a type definition or subtype indication. + -- 1. Create corresponding Ortho type. + -- 2. Create bounds type + -- 3. Create bounds declaration + -- 4. Create bounds constructor + -- 5. Create type descriptor declaration + -- 6. Create type descriptor constructor + procedure Translate_Type_Definition + (Def : Iir; With_Vars : Boolean := True); + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id); + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean); + + -- Some expressions may be evaluated several times in different + -- contexts. Type info created for these expressions may not be + -- shared between these contexts. + procedure Destroy_Type_Info (Atype : Iir); + + -- Translate subprograms for types. + procedure Translate_Type_Subprograms (Decl : Iir); + + procedure Create_Type_Definition_Type_Range (Def : Iir); + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode; + + -- Same as Translate_type_definition only for std.standard.boolean and + -- std.standard.bit. + procedure Translate_Bool_Type_Definition (Def : Iir); + + -- Call lock or unlock on a protected object. + procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode); + + procedure Translate_Protected_Type_Body (Bod : Iir); + procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir); + + -- Translate_type_definition_Elab do 4 and 6. + -- It generates code to do type elaboration. + procedure Elab_Type_Declaration (Decl : Iir); + procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration); + + -- Builders. + -- A complex type is a type whose size is not locally static. + -- + -- The most simple example is an unidimensionnl array whose range + -- depends on generics. + -- + -- We call first order complex type any array whose bounds are not + -- locally static and whose sub-element size is locally static. + -- + -- First order complex type objects are represented by a pointer to an + -- array of sub-element, and the storage area for the array is + -- allocated at run-time. + -- + -- Since a sub-element type may be a complex type, a type may be + -- complex because one of its sub-element type is complex. + -- EG, a record type whose one element is a complex array. + -- + -- A type may be complex either because it is a first order complex + -- type (ie an array whose bounds are not locally static) or because + -- one of its sub-element type is such a type (this is recursive). + -- + -- We call second order complex type a complex type that is not of first + -- order. + -- We call third order complex type a second order complex type which is + -- an array whose bounds are not locally static. + -- + -- In a complex type, sub-element of first order complex type are + -- represented by a pointer. + -- Any complex type object (constant, signal, variable, port, generic) + -- is represented by a pointer. + -- + -- Creation of a second or third order complex type object consists in + -- allocating the memory and building the object. + -- Building a object consists in setting internal pointers. + -- + -- A complex type has always a non-null INFO.C, and its size is computed + -- during elaboration. + -- + -- For a second or third order complex type, INFO.C.BUILDER_NEED_FUNC + -- is set to TRUE. + + -- Call builder for variable pointed VAR of type VAR_TYPE. + procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir); + + -- Functions for fat array. + -- Fat array are array whose size is not known at compilation time. + -- This corresponds to an unconstrained array or a non locally static + -- constrained array. + -- A fat array is a structure containing 2 fields: + -- * base: a pointer to the data of the array. + -- * bounds: a pointer to a structure containing as many fields as + -- number of dimensions; these fields are a structure describing the + -- range of the dimension. + + -- Index array BASE of type ATYPE with INDEX. + -- INDEX must be of type ghdl_index_type, thus no bounds checks are + -- performed. + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode; + + -- Same for for slicing. + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode; + + -- Get the length of the array (the number of elements). + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode; + + -- Get the number of elements for bounds BOUNDS. BOUNDS are + -- automatically stabilized if necessary. + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode; + + -- Get the number of elements in array ATYPE. + function Get_Array_Type_Length (Atype : Iir) return O_Enode; + + -- Get the base of array ARR. + function Get_Array_Base (Arr : Mnode) return Mnode; + + -- Get the bounds of array ARR. + function Get_Array_Bounds (Arr : Mnode) return Mnode; + + -- Get the range ot ATYPE. + function Type_To_Range (Atype : Iir) return Mnode; + + -- Get length of range R. + function Range_To_Length (R : Mnode) return Mnode; + + -- Get direction of range R. + function Range_To_Dir (R : Mnode) return Mnode; + + -- Get left/right bounds for range R. + function Range_To_Left (R : Mnode) return Mnode; + function Range_To_Right (R : Mnode) return Mnode; + + -- Get range for dimension DIM (1 based) of array bounds B or type + -- ATYPE. + function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) + return Mnode; + + -- Get the range of dimension DIM (1 based) of array ARR of type ATYPE. + function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) + return Mnode; + + -- Get array bounds for type ATYPE. + function Get_Array_Type_Bounds (Atype : Iir) return Mnode; + + -- Deallocate OBJ. + procedure Gen_Deallocate (Obj : O_Enode); + + -- Performs deallocation of PARAM (the parameter of a deallocate call). + procedure Translate_Object_Deallocation (Param : Iir); + + -- Allocate an object of type OBJ_TYPE and set RES. + -- RES must be a stable access of type ortho_ptr_type. + -- For an unconstrained array, BOUNDS is a pointer to the boundaries of + -- the object, which are copied. + procedure Translate_Object_Allocation + (Res : in out Mnode; + Alloc_Kind : Allocation_Kind; + Obj_Type : Iir; + Bounds : Mnode); + + -- Copy SRC to DEST. + -- Both have the same type, OTYPE. + -- Furthermore, arrays are of the same length. + procedure Translate_Object_Copy + (Dest : Mnode; Src : O_Enode; Obj_Type : Iir); + + -- Get size (in bytes with type ghdl_index_type) of object OBJ. + -- For an unconstrained array, OBJ must be really an object, otherwise, + -- it may be a null_mnode, created by T2M. + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode; + + -- Allocate the base of a fat array, whose length is determined from + -- the bounds. + -- RES_PTR is a pointer to the fat pointer (must be a variable that + -- can be referenced several times). + -- ARR_TYPE is the type of the array. + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; + Res : Mnode; + Arr_Type : Iir); + + -- Create the bounds for SUB_TYPE. + -- SUB_TYPE is expected to be a non-static, anonymous array type. + procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean); + + -- Return TRUE if VALUE is not is the range specified by ATYPE. + -- VALUE must be stable. + function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode; + + -- Return TRUE if base type of ATYPE is larger than its bounds, ie + -- if a value of type ATYPE may be out of range. + function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean; + + -- Generate an error if VALUE (computed from EXPR which may be NULL_IIR + -- if not from a tree) is not in range specified by ATYPE. + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir); + + -- Insert a scalar check for VALUE of type ATYPE. EXPR may be NULL_IIR. + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode; + + -- The base type of EXPR and the base type of ATYPE must be the same. + -- If the type is a scalar type, and if a range check is needed, this + -- function inserts the check. Otherwise, it returns VALUE. + function Maybe_Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir) + return O_Enode; + + -- Return True iff all indexes of L_TYPE and R_TYPE have the same + -- length. They must be locally static. + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean; + + -- Check bounds length of L match bounds length of R. + -- If L_TYPE (resp. R_TYPE) is not a thin array, then L_NODE + -- (resp. R_NODE) are not used (and may be Mnode_Null). + -- If L_TYPE (resp. T_TYPE) is a fat array, then L_NODE (resp. R_NODE) + -- must designate the array. + procedure Check_Array_Match (L_Type : Iir; + L_Node : Mnode; + R_Type : Iir; + R_Node : Mnode; + Loc : Iir); + + -- Create a subtype range to be stored into the location pointed by + -- RANGE_PTR from length LENGTH, which is of type INDEX_TYPE. + -- This is done according to rules 7.2.4 of LRM93, ie: + -- direction and left bound of the range is the same of INDEX_TYPE. + -- LENGTH and RANGE_PTR are variables. LOC is the location in case of + -- error. + procedure Create_Range_From_Length + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir); + + end Chap3; + + package Chap4 is + -- Translate of a type declaration corresponds to the translation of + -- its definition. + procedure Translate_Type_Declaration (Decl : Iir); + procedure Translate_Anonymous_Type_Declaration (Decl : Iir); + procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration); + procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration); + + -- Translate declaration DECL, which must not be a subprogram + -- specification. + procedure Translate_Declaration (Decl : Iir); + + -- Translate declarations, except subprograms spec and bodies. + procedure Translate_Declaration_Chain (Parent : Iir); + + -- Translate subprograms in declaration chain of PARENT. + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir); + + -- Create subprograms for type/function conversion of signal + -- associations. + -- ENTITY is the entity instantiated, which can be either + -- an entity_declaration (for component configuration or direct + -- component instantiation), a component declaration (for a component + -- instantiation) or Null_Iir (for a block header). + -- BLOCK is the block/architecture containing the instantiation stmt. + -- STMT is either the instantiation stmt or the block header. + procedure Translate_Association_Subprograms + (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir); + + -- Elaborate In/Out_Conversion for ASSOC (signals only). + -- NDEST is the data structure to be registered. + procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode); + procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode); + + -- Create code to elaborate declarations. + -- NEED_FINAL is set when at least one declaration needs to be + -- finalized (eg: file declaration, protected objects). + procedure Elab_Declaration_Chain + (Parent : Iir; Need_Final : out Boolean); + + -- Finalize declarations. + procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean); + + -- Translate port or generic declarations of PARENT. + procedure Translate_Port_Chain (Parent : Iir); + procedure Translate_Generic_Chain (Parent : Iir); + + -- Elaborate signal subtypes and allocate the storage for the object. + procedure Elab_Signal_Declaration_Storage (Decl : Iir); + + -- Create signal object. + -- Note: SIG can be a signal sub-element (used when signals are + -- collapsed). + -- If CHECK_NULL is TRUE, create the signal only if it was not yet + -- created. + -- PARENT is used to link the signal to its parent by rti. + procedure Elab_Signal_Declaration_Object + (Sig : Iir; Parent : Iir; Check_Null : Boolean); + + -- True of SIG has a direct driver. + function Has_Direct_Driver (Sig : Iir) return Boolean; + + -- Allocate memory for direct driver if necessary. + procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir); + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Value (Obj : Iir; Value : Iir); + + -- Allocate the storage for OBJ, if necessary. + procedure Elab_Object_Storage (Obj : Iir); + + -- Initialize NAME/OBJ with VALUE. + procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir); + + -- Get the ortho type for an object of type TINFO. + function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) + return O_Tnode; + + -- Allocate (and build) a complex object of type OBJ_TYPE. + -- VAR is the object to be allocated. + procedure Allocate_Complex_Object (Obj_Type : Iir; + Alloc_Kind : Allocation_Kind; + Var : in out Mnode); + + --function Translate_Interface_Declaration + -- (Decl : Iir; Subprg : Iir) return Tree; + + -- Create a record that describe thes location of an IIR node and + -- returns the address of it. + function Get_Location (N : Iir) return O_Dnode; + + -- Set default value to OBJ. + procedure Init_Object (Obj : Mnode; Obj_Type : Iir); + end Chap4; + + package Chap6 is + -- Translate NAME. + -- RES contains a lnode for the result. This is the object. + -- RES can be a tree, so it may be referenced only once. + -- SIG is true if RES is a signal object. + function Translate_Name (Name : Iir) return Mnode; + + -- Translate signal NAME into its node (SIG) and its direct driver + -- node (DRV). + procedure Translate_Direct_Driver + (Name : Iir; Sig : out Mnode; Drv : out Mnode); + + -- Same as Translate_Name, but only for formal names. + -- If SCOPE_TYPE and SCOPE_PARAM are not null, use them for the scope + -- of the base name. + -- Indeed, for recursive instantiation, NAME can designates the actual + -- and the formal. +-- function Translate_Formal_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir) +-- return Mnode; + + -- Get record element EL of PREFIX. + function Translate_Selected_Element (Prefix : Mnode; + El : Iir_Element_Declaration) + return Mnode; + + function Get_Array_Bound_Length (Arr : Mnode; + Arr_Type : Iir; + Dim : Natural) + return O_Enode; + + procedure Gen_Bound_Error (Loc : Iir); + + -- Generate code to emit a program error. + Prg_Err_Missing_Return : constant Natural := 1; + Prg_Err_Block_Configured : constant Natural := 2; + Prg_Err_Dummy_Config : constant Natural := 3; + Prg_Err_No_Choice : constant Natural := 4; + Prg_Err_Bad_Choice : constant Natural := 5; + procedure Gen_Program_Error (Loc : Iir; Code : Natural); + + -- Generate code to emit a failure if COND is TRUE, indicating an + -- index violation for dimension DIM of an array. LOC is usually + -- the expression which has computed the index and is used only for + -- its location. + procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural); + + -- Get the deepest range_expression of ATYPE. + -- This follows 'range and 'reverse_range. + -- Set IS_REVERSE to true if the range must be reversed. + procedure Get_Deep_Range_Expression + (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean); + + -- Get the offset of INDEX in the range RNG. + -- This checks INDEX belongs to the range. + -- RANGE_TYPE is the subtype of the array index (or the subtype of RNG). + -- For unconstrained ranges, INDEX_EXPR must be NULL_IIR and RANGE_TYPE + -- must be set. + function Translate_Index_To_Offset (Rng : Mnode; + Index : O_Enode; + Index_Expr : Iir; + Range_Type : Iir; + Loc : Iir) + return O_Enode; + end Chap6; + + package Chap7 is + -- Generic function to extract a value from a signal. + generic + with function Read_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + + -- Extract the effective value of SIG. + function Translate_Signal_Effective_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + function Translate_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + + -- Directly set the effective value of SIG with VAL. + -- Used only by conversion. + procedure Set_Effective_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode); + + procedure Set_Driving_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode); + + -- Translate expression EXPR into ortho tree. + function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) + return O_Enode; + + -- Translate call to function IMP. + -- ASSOC_CHAIN is the chain of a associations for this call. + -- OBJ, if not NULL_IIR is the protected object. + function Translate_Function_Call + (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) + return O_Enode; + + -- Translate range and return an lvalue containing the range. + -- The node returned can be used only one time. + function Translate_Range (Arange : Iir; Range_Type : Iir) + return O_Lnode; + + -- Translate range expression EXPR and store the result into the node + -- pointed by RES_PTR, of type RANGE_TYPE. + procedure Translate_Range_Ptr + (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir); + function Translate_Static_Range (Arange : Iir; Range_Type : Iir) + return O_Cnode; + + -- Same as Translate_Range_Ptr, but for a discrete range (ie: ARANGE + -- can be a discrete subtype indication). + procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir); + + -- Return TRUE iff constant declaration DECL can be staticly defined. + -- This is of course true if its expression is a locally static literal, + -- but can be true in a few cases for aggregates. + -- This function belongs to Translation, since it is defined along + -- with the translate_static_aggregate procedure. + function Is_Static_Constant (Decl : Iir_Constant_Declaration) + return Boolean; + + -- Translate the static expression EXPR into an ortho expression whose + -- type must be RES_TYPE. Therefore, an implicite conversion might + -- occurs. + function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) + return O_Cnode; + function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) + return O_Cnode; + + -- Convert (if necessary) EXPR of type EXPR_TYPE to type ATYPE. + function Translate_Implicit_Conv + (Expr : O_Enode; + Expr_Type : Iir; + Atype : Iir; + Is_Sig : Object_Kind_Type; + Loc : Iir) + return O_Enode; + + function Translate_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode; + + -- Convert range EXPR into ortho tree. + -- If RANGE_TYPE /= NULL_IIR, convert bounds to RANGE_TYPE. + --function Translate_Range (Expr : Iir; Range_Type : Iir) return O_Enode; + function Translate_Static_Range_Left + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode; + function Translate_Static_Range_Right + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode; + function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode; + function Translate_Static_Range_Length (Expr : Iir) return O_Cnode; + + -- These functions evaluates left bound/right bound/length of the + -- range expression EXPR. + function Translate_Range_Expression_Left (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode; + function Translate_Range_Expression_Right (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode; + function Translate_Range_Expression_Length (Expr : Iir) return O_Enode; + + -- Get the length of any range expression (ie maybe an attribute). + function Translate_Range_Length (Expr : Iir) return O_Enode; + + -- Assign AGGR to TARGET of type TARGET_TYPE. + procedure Translate_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir); + + -- Translate implicit functions defined by a type. + type Implicit_Subprogram_Infos is private; + procedure Init_Implicit_Subprogram_Infos + (Infos : out Implicit_Subprogram_Infos); + procedure Translate_Implicit_Subprogram + (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos); + + -- Assign EXPR to TARGET. LOC is the location used to report errors. + -- FIXME: do the checks. + procedure Translate_Assign + (Target : Mnode; Expr : Iir; Target_Type : Iir); + procedure Translate_Assign + (Target : Mnode; + Val: O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir); + + -- Find the declaration of the predefined function IMP in type + -- definition BASE_TYPE. + function Find_Predefined_Function + (Base_Type : Iir; Imp : Iir_Predefined_Functions) + return Iir; + + function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) + return O_Enode; + private + type Implicit_Subprogram_Infos is record + Arr_Eq_Info : Subprg_Info_Acc; + Rec_Eq_Info : Subprg_Info_Acc; + Arr_Cmp_Info : Subprg_Info_Acc; + Arr_Concat_Info : Subprg_Info_Acc; + Arr_Shl_Info : Subprg_Info_Acc; + Arr_Sha_Info : Subprg_Info_Acc; + Arr_Rot_Info : Subprg_Info_Acc; + end record; + end Chap7; + + package Chap14 is + function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode; + + -- Read signal value FIELD of signal SIG. + function Get_Signal_Value_Field + (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) + return O_Lnode; + + function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) return O_Lnode; + + function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) + return O_Enode; + function Translate_Low_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_High_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Range_Array_Attribute (Expr : Iir) return O_Lnode; + function Translate_Right_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Left_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Ascending_Array_Attribute (Expr : Iir) return O_Enode; + + function Translate_High_Low_Type_Attribute + (Atype : Iir; Is_High : Boolean) return O_Enode; + + -- Return the value of the left bound/right bound/direction of scalar + -- type ATYPE. + function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode; + function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode; + function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode; + + function Translate_Val_Attribute (Attr : Iir) return O_Enode; + function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) + return O_Enode; + + function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode; + + function Translate_Image_Attribute (Attr : Iir) return O_Enode; + function Translate_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Event_Attribute (Attr : Iir) return O_Enode; + function Translate_Active_Attribute (Attr : Iir) return O_Enode; + function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) + return O_Enode; + + function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Driving_Attribute (Attr : Iir) return O_Enode; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode; + end Chap14; + + package Helpers is + -- Return the value of field FIELD of lnode L that is contains + -- a pointer to a record. + -- This is equivalent to: + -- new_value (new_selected_element (new_access_element (new_value (l)), + -- field)) + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode; + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode; + + -- Equivalent to new_access_element (new_value (l)) + function New_Acc_Value (L : O_Lnode) return O_Lnode; + + -- Copy a fat pointer. + -- D and S are stabilized fat pointers. + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); + + -- Generate code to initialize a ghdl_index_type variable V to 0. + procedure Init_Var (V : O_Dnode); + + -- Generate code to increment/decrement a ghdl_index_type variable V. + procedure Inc_Var (V : O_Dnode); + procedure Dec_Var (V : O_Dnode); + + -- Generate code to exit from loop LABEL iff COND is true. + procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode); + + -- Create a uniq identifier. + subtype Uniq_Identifier_String is String (1 .. 11); + function Create_Uniq_Identifier return Uniq_Identifier_String; + function Create_Uniq_Identifier return O_Ident; + + -- Create a region for temporary variables. + procedure Open_Temp; + -- Create a temporary variable. + function Create_Temp (Atype : O_Tnode) return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with VALUE. + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with the + -- address of NAME. + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode; + -- Create a mark in the temporary region for the stack2. + -- FIXME: maybe a flag must be added to CLOSE_TEMP where it is known + -- stack2 can be released. + procedure Create_Temp_Stack2_Mark; + -- Add ATYPE in the chain of types to be destroyed at the end of the + -- temp scope. + procedure Add_Transient_Type_In_Temp (Atype : Iir); + -- Close the temporary region. + procedure Close_Temp; + + -- Like Open_Temp, but will never create a declare region. To be used + -- only within a subprogram, to use the declare region of the + -- subprogram. + procedure Open_Local_Temp; + -- Destroy transient types created in a temporary region. + procedure Destroy_Local_Transient_Types; + procedure Close_Local_Temp; + + -- Return TRUE if stack2 will be released. Used for fine-tuning only + -- (return statement). + function Has_Stack2_Mark return Boolean; + -- Manually release stack2. Used for fine-tuning only. + procedure Stack2_Release; + + -- Free all old temp. + -- Used only to free memory. + procedure Free_Old_Temp; + + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode; + + -- Create a constant (of name ID) for string STR. + -- Append a NUL terminator (to make interfaces with C easier). + function Create_String (Str : String; Id : O_Ident) return O_Dnode; + + function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode; + + procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode); + + -- Allocate SIZE bytes aligned on the biggest alignment and return a + -- pointer of type PTYPE. + function Gen_Alloc + (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) + return O_Enode; + + -- Allocate on the heap LENGTH bytes aligned on the biggest alignment, + -- and returns a pointer of type PTYPE. + --function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode; + + -- Handle a composite type TARG/TARG_TYPE and apply DO_NON_COMPOSITE + -- on each non composite type. + -- There is a generic parameter DATA which may be updated + -- before indexing an array by UPDATE_DATA_ARRAY. + generic + type Data_Type is private; + type Composite_Data_Type is private; + with procedure Do_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- This function should extract the base of DATA. + with function Prepare_Data_Array (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should index DATA. + with function Update_Data_Array (Data : Composite_Data_Type; + Targ_Type : Iir; + Index : O_Dnode) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Array (Data : in out Composite_Data_Type); + + -- This function should stabilize DATA. + with function Prepare_Data_Record (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should extract field EL of DATA. + with function Update_Data_Record (Data : Composite_Data_Type; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Record (Data : in out Composite_Data_Type); + + procedure Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- Call a procedure (DATA_TYPE) for each signal of TARG. + procedure Register_Signal + (Targ : Mnode; Targ_Type : Iir; Proc : O_Dnode); + + -- Call PROC for each scalar signal of list LIST. + procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode); + + -- Often used subprograms for Foreach_non_composite + -- when DATA_TYPE is o_enode. + function Gen_Oenode_Prepare_Data_Composite + (Targ: Mnode; Targ_Type : Iir; Val : O_Enode) + return Mnode; + function Gen_Oenode_Update_Data_Array (Val : Mnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Enode; + function Gen_Oenode_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Enode; + procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode); + + type Hexstr_Type is array (Integer range 0 .. 15) of Character; + N2hex : constant Hexstr_Type := "0123456789abcdef"; + + function Get_Line_Number (Target: Iir) return Natural; + + procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; + Line : Natural); + private + end Helpers; + use Helpers; + + function Get_Type_Info (M : Mnode) return Type_Info_Acc is + begin + return M.M1.T; + end Get_Type_Info; + + function Get_Object_Kind (M : Mnode) return Object_Kind_Type is + begin + return M.M1.K; + end Get_Object_Kind; + + function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_E, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, E => E, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end E2M; + + function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lv2M; + + function Lv2M (L : O_Lnode; + Comp : Boolean; + Vtype : O_Tnode; + Ptype : O_Tnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => Comp, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lp2M; + + function Lp2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => Vtype, Ptype => Ptype)); + end Lp2M; + + function Lv2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => Vtype, + Ptype => Ptype)); + end Dv2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => Vtype, Ptype => Ptype)); + end Dp2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dp2M; + + function M2Lv (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + case Get_Type_Info (M).Type_Mode is + when Type_Mode_Thin => + -- Scalar to var is not possible. + -- FIXME: This is not coherent with the fact that this + -- conversion is possible when M is stabilized. + raise Internal_Error; + when Type_Mode_Fat => + return New_Access_Element (M.M1.E); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + when Mstate_Lp => + return New_Acc_Value (M.M1.Lp); + when Mstate_Lv => + return M.M1.Lv; + when Mstate_Dp => + return New_Acc_Value (New_Obj (M.M1.Dp)); + when Mstate_Dv => + return New_Obj (M.M1.Dv); + when Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lv; + + function M2Lp (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + raise Internal_Error; + when Mstate_Lp => + return M.M1.Lp; + when Mstate_Dp => + return New_Obj (M.M1.Dp); + when Mstate_Lv => + if Get_Type_Info (M).Type_Mode in Type_Mode_Fat then + return New_Obj + (Create_Temp_Init (M.M1.Ptype, + New_Address (M.M1.Lv, M.M1.Ptype))); + else + raise Internal_Error; + end if; + when Mstate_Dv + | Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lp; + + function M2Dp (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dp => + return M.M1.Dp; + when Mstate_Dv => + return Create_Temp_Init + (M.M1.Ptype, New_Address (New_Obj (M.M1.Dv), M.M1.Ptype)); + + when others => + raise Internal_Error; + end case; + end M2Dp; + + function M2Dv (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dv => + return M.M1.Dv; + when others => + raise Internal_Error; + end case; + end M2Dv; + + function T2M (Atype : Iir; Kind : Object_Kind_Type) return Mnode + is + T : Type_Info_Acc; + begin + T := Get_Info (Atype); + return Mnode'(M1 => (State => Mstate_Null, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end T2M; + + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode + is + D : O_Dnode; + K : Object_Kind_Type; + begin + K := M.M1.K; + case M.M1.State is + when Mstate_E => + if M.M1.Comp then + D := Create_Temp_Init (M.M1.Ptype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + else + D := Create_Temp_Init (M.M1.Vtype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Lp => + D := Create_Temp_Init (M.M1.Ptype, New_Value (M.M1.Lp)); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + when Mstate_Lv => + if M.M1.Ptype = O_Tnode_Null then + if not Can_Copy then + raise Internal_Error; + end if; + D := Create_Temp_Init (M.M1.Vtype, New_Value (M.M1.Lv)); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + + else + D := Create_Temp_Ptr (M.M1.Ptype, M.M1.Lv); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end Stabilize; + + procedure Stabilize (M : in out Mnode) is + begin + M := Stabilize (M); + end Stabilize; + + function Stabilize_Value (M : Mnode) return Mnode + is + D : O_Dnode; + E : O_Enode; + begin + -- M must be scalar or access. + if M.M1.Comp then + raise Internal_Error; + end if; + case M.M1.State is + when Mstate_E => + E := M.M1.E; + when Mstate_Lp => + E := New_Value (New_Acc_Value (M.M1.Lp)); + when Mstate_Lv => + E := New_Value (M.M1.Lv); + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + + D := Create_Temp_Init (M.M1.Vtype, E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => M.M1.K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end Stabilize_Value; + + function M2E (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_E => + return M.M1.E; + when Mstate_Lp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (M.M1.Lp)); + when Type_Mode_Fat => + return New_Value (M.M1.Lp); + end case; + when Mstate_Dp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (New_Obj (M.M1.Dp))); + when Type_Mode_Fat => + return New_Value (New_Obj (M.M1.Dp)); + end case; + when Mstate_Lv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (M.M1.Lv); + when Type_Mode_Fat => + return New_Address (M.M1.Lv, M.M1.Ptype); + end case; + when Mstate_Dv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Obj (M.M1.Dv)); + when Type_Mode_Fat => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + end case; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2E; + + function M2Addr (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_Lp => + return New_Value (M.M1.Lp); + when Mstate_Dp => + return New_Value (New_Obj (M.M1.Dp)); + when Mstate_Lv => + return New_Address (M.M1.Lv, M.M1.Ptype); + when Mstate_Dv => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + when Mstate_E => + if M.M1.Comp then + return M.M1.E; + else + raise Internal_Error; + end if; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2Addr; + +-- function Is_Null (M : Mnode) return Boolean is +-- begin +-- return M.M1.State = Mstate_Null; +-- end Is_Null; + + function Is_Stable (M : Mnode) return Boolean is + begin + case M.M1.State is + when Mstate_Dp + | Mstate_Dv => + return True; + when others => + return False; + end case; + end Is_Stable; + +-- function Varv2M +-- (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) +-- return Mnode is +-- begin +-- return Lv2M (Get_Var (Var), Vtype, Mode); +-- end Varv2M; + + function Varv2M (Var : Var_Type; + Var_Type : Type_Info_Acc; + Mode : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype); + end Varv2M; + + -- Convert a Lnode for a sub object to an MNODE. + function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Lv2M (L, Vtype, Mode); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + return Lp2M (L, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Dv2M (D, Vtype, Mode); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + return Dp2M (D, Vtype, Mode); + else + return Dv2M (D, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Get_Var + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode + is + L : O_Lnode; + D : O_Dnode; + Stable : Boolean; + begin + -- FIXME: there may be Vv2M and Vp2M. + Stable := Is_Var_Stable (Var); + if Stable then + D := Get_Var_Label (Var); + else + L := Get_Var (Var); + end if; + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + if Stable then + return Dp2M (D, Vtype, Mode); + else + return Lp2M (L, Vtype, Mode); + end if; + else + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Get_Var; + + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode is + begin + if Is_Complex_Type (Info) + and then Info.Type_Mode /= Type_Mode_Fat_Array + then + -- For a complex and constrained object, we just allocate + -- a pointer to the object. + return Dp2M (Create_Temp (Info.Ortho_Ptr_Type (Kind)), Info, Kind); + else + return Dv2M (Create_Temp (Info.Ortho_Type (Kind)), Info, Kind); + end if; + end Create_Temp; + + function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type + is + use Name_Table; + Attr : Iir_Attribute_Value; + Spec : Iir_Attribute_Specification; + Attr_Decl : Iir; + Expr : Iir; + begin + -- Look for 'FOREIGN. + Attr := Get_Attribute_Value_Chain (Decl); + while Attr /= Null_Iir loop + Spec := Get_Attribute_Specification (Attr); + Attr_Decl := Get_Attribute_Designator (Spec); + exit when Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign; + Attr := Get_Chain (Attr); + end loop; + if Attr = Null_Iir then + -- Not found. + raise Internal_Error; + end if; + Spec := Get_Attribute_Specification (Attr); + Expr := Get_Expression (Spec); + case Get_Kind (Expr) is + when Iir_Kind_String_Literal => + declare + Ptr : String_Fat_Acc; + begin + Ptr := Get_String_Fat_Acc (Expr); + Name_Length := Natural (Get_String_Length (Expr)); + for I in 1 .. Name_Length loop + Name_Buffer (I) := Ptr (Nat32 (I)); + end loop; + end; + when Iir_Kind_Simple_Aggregate => + declare + List : Iir_List; + El : Iir; + begin + List := Get_Simple_Aggregate_List (Expr); + Name_Length := 0; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Kind (El) /= Iir_Kind_Enumeration_Literal then + raise Internal_Error; + end if; + Name_Length := Name_Length + 1; + Name_Buffer (Name_Length) := + Character'Val (Get_Enum_Pos (El)); + end loop; + end; + when Iir_Kind_Bit_String_Literal => + Error_Msg_Sem + ("value of FOREIGN attribute cannot be a bit string", Expr); + Name_Length := 0; + when others => + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem + ("value of FOREIGN attribute must be locally static", Expr); + Name_Length := 0; + else + raise Internal_Error; + end if; + end case; + + if Name_Length = 0 then + return Foreign_Bad; + end if; + + -- Only 'VHPIDIRECT' is recognized. + if Name_Length >= 10 + and then Name_Buffer (1 .. 10) = "VHPIDIRECT" + then + declare + P : Natural; + Sf, Sl : Natural; + Lf, Ll : Natural; + begin + P := 11; + + -- Skip spaces. + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + if P > Name_Length then + Error_Msg_Sem + ("missing subprogram/library name after VHPIDIRECT", Spec); + end if; + -- Extract library. + Lf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Ll := P; + -- Extract subprogram. + P := P + 1; + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + Sf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Sl := P; + if P < Name_Length then + Error_Msg_Sem ("garbage at end of VHPIDIRECT", Spec); + end if; + + -- Accept empty library. + if Sf > Name_Length then + Sf := Lf; + Sl := Ll; + Lf := 0; + Ll := 0; + end if; + + return Foreign_Info_Type' + (Kind => Foreign_Vhpidirect, + Lib_First => Lf, + Lib_Last => Ll, + Subprg_First => Sf, + Subprg_Last => Sl); + end; + elsif Name_Length = 14 + and then Name_Buffer (1 .. 14) = "GHDL intrinsic" + then + return Foreign_Info_Type'(Kind => Foreign_Intrinsic); + else + Error_Msg_Sem + ("value of 'FOREIGN attribute does not begin with VHPIDIRECT", + Spec); + return Foreign_Bad; + end if; + end Translate_Foreign_Id; + + package body Helpers is + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode is + begin + return New_Value + (New_Selected_Element (New_Access_Element (New_Value (L)), Field)); + end New_Value_Selected_Acc_Value; + + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode is + begin + return New_Selected_Element + (New_Access_Element (New_Value (L)), Field); + end New_Selected_Acc_Value; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode + is + begin + return New_Indexed_Element (New_Access_Element (New_Value (L)), I); + end New_Indexed_Acc_Value; + + function New_Acc_Value (L : O_Lnode) return O_Lnode is + begin + return New_Access_Element (New_Value (L)); + end New_Acc_Value; + + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) + is + begin + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)), + M2Addr (Chap3.Get_Array_Base (S))); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (D)), + M2Addr (Chap3.Get_Array_Bounds (S))); + end Copy_Fat_Pointer; + + procedure Inc_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (V), + New_Lit (Ghdl_Index_1))); + end Inc_Var; + + procedure Dec_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (V), + New_Lit (Ghdl_Index_1))); + end Dec_Var; + + procedure Init_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), New_Lit (Ghdl_Index_0)); + end Init_Var; + + procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode) + is + If_Blk : O_If_Block; + begin + Start_If_Stmt (If_Blk, Cond); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk); + end Gen_Exit_When; + + Uniq_Id : Natural := 0; + + function Create_Uniq_Identifier return Uniq_Identifier_String + is + Str : Uniq_Identifier_String; + Val : Natural; + begin + Str (1 .. 3) := "_UI"; + Val := Uniq_Id; + Uniq_Id := Uniq_Id + 1; + for I in reverse 4 .. 11 loop + Str (I) := N2hex (Val mod 16); + Val := Val / 16; + end loop; + return Str; + end Create_Uniq_Identifier; + + function Create_Uniq_Identifier return O_Ident is + begin + return Get_Identifier (Create_Uniq_Identifier); + end Create_Uniq_Identifier; + + -- Create a temporary variable. + type Temp_Level_Type; + type Temp_Level_Acc is access Temp_Level_Type; + type Temp_Level_Type is record + Prev : Temp_Level_Acc; + Level : Natural; + Id : Natural; + Emitted : Boolean; + Stack2_Mark : O_Dnode; + Transient_Types : Iir; + end record; + -- Current level. + Temp_Level : Temp_Level_Acc := null; + + -- List of unused temp_level_type structures. To be faster, they are + -- never deallocated. + Old_Level : Temp_Level_Acc := null; + + -- If set, emit comments for open_temp/close_temp. + Flag_Debug_Temp : constant Boolean := False; + + procedure Open_Temp + is + L : Temp_Level_Acc; + begin + if Old_Level /= null then + L := Old_Level; + Old_Level := L.Prev; + else + L := new Temp_Level_Type; + end if; + L.all := (Prev => Temp_Level, + Level => 0, + Id => 0, + Emitted => False, + Stack2_Mark => O_Dnode_Null, + Transient_Types => Null_Iir); + if Temp_Level /= null then + L.Level := Temp_Level.Level + 1; + end if; + Temp_Level := L; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Open_Temp level " & Natural'Image (L.Level)); + end if; + end Open_Temp; + + procedure Open_Local_Temp is + begin + Open_Temp; + Temp_Level.Emitted := True; + end Open_Local_Temp; + + procedure Add_Transient_Type_In_Temp (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Type_Info.Type_Transient_Chain := Temp_Level.Transient_Types; + Temp_Level.Transient_Types := Atype; + end Add_Transient_Type_In_Temp; + + procedure Release_Transient_Types (Chain : in out Iir) is + N_Atype : Iir; + begin + while Chain /= Null_Iir loop + N_Atype := Get_Info (Chain).Type_Transient_Chain; + Chap3.Destroy_Type_Info (Chain); + Chain := N_Atype; + end loop; + end Release_Transient_Types; + + procedure Destroy_Local_Transient_Types is + begin + Release_Transient_Types (Temp_Level.Transient_Types); + end Destroy_Local_Transient_Types; + + function Has_Stack2_Mark return Boolean is + begin + return Temp_Level.Stack2_Mark /= O_Dnode_Null; + end Has_Stack2_Mark; + + procedure Stack2_Release + is + Constr : O_Assoc_List; + begin + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Stack2_Release); + New_Association (Constr, + New_Value (New_Obj (Temp_Level.Stack2_Mark))); + New_Procedure_Call (Constr); + Temp_Level.Stack2_Mark := O_Dnode_Null; + end if; + end Stack2_Release; + + procedure Close_Temp + is + L : Temp_Level_Acc; + begin + if Temp_Level = null then + -- OPEN_TEMP was not called. + raise Internal_Error; + end if; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Close_Temp level " & Natural'Image (Temp_Level.Level)); + end if; + + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + Stack2_Release; + end if; + if Temp_Level.Emitted then + Finish_Declare_Stmt; + end if; + + -- Destroy transcient types. + Release_Transient_Types (Temp_Level.Transient_Types); + + -- Unlink temp_level. + L := Temp_Level; + Temp_Level := L.Prev; + L.Prev := Old_Level; + Old_Level := L; + end Close_Temp; + + procedure Close_Local_Temp is + begin + Temp_Level.Emitted := False; + Close_Temp; + end Close_Local_Temp; + + procedure Free_Old_Temp + is + procedure Free is new Ada.Unchecked_Deallocation + (Temp_Level_Type, Temp_Level_Acc); + T : Temp_Level_Acc; + begin + if Temp_Level /= null then + raise Internal_Error; + end if; + loop + T := Old_Level; + exit when T = null; + Old_Level := Old_Level.Prev; + Free (T); + end loop; + end Free_Old_Temp; + + procedure Create_Temp_Stack2_Mark + is + Constr : O_Assoc_List; + begin + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + -- Only the first mark in a region is registred. + -- The release operation frees the memory allocated after the + -- first mark. + return; + end if; + Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type); + Start_Association (Constr, Ghdl_Stack2_Mark); + New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark), + New_Function_Call (Constr)); + end Create_Temp_Stack2_Mark; + + function Create_Temp (Atype : O_Tnode) return O_Dnode + is + Str : String (1 .. 12); + Val : Natural; + Res : O_Dnode; + P : Natural; + begin + if Temp_Level = null then + -- OPEN_TEMP was never called. + raise Internal_Error; + -- This is an hack, just to allow array subtype to array type + -- conversion. + --New_Var_Decl + -- (Res, Create_Uniq_Identifier, O_Storage_Private, Atype); + --return Res; + else + if not Temp_Level.Emitted then + Temp_Level.Emitted := True; + Start_Declare_Stmt; + end if; + end if; + Val := Temp_Level.Id; + Temp_Level.Id := Temp_Level.Id + 1; + P := Str'Last; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := '_'; + P := P - 1; + Val := Temp_Level.Level; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := 'T'; + --Str (12) := Nul; + New_Var_Decl + (Res, Get_Identifier (Str (P .. Str'Last)), O_Storage_Local, Atype); + return Res; + end Create_Temp; + + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode + is + Res : O_Dnode; + begin + Res := Create_Temp (Atype); + New_Assign_Stmt (New_Obj (Res), Value); + return Res; + end Create_Temp_Init; + + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode is + begin + return Create_Temp_Init (Atype, New_Address (Name, Atype)); + end Create_Temp_Ptr; + + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode is + begin + return New_Unsigned_Literal (Ghdl_Index_Type, Num); + end New_Index_Lit; + + -- Convert NAME into a STRING_CST. + -- Append a NUL terminator (to make interfaces with C easier). + function Create_String_Type (Str : String) return O_Tnode is + begin + return New_Constrained_Array_Type + (Chararray_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Str'Length + 1))); + end Create_String_Type; + + procedure Create_String_Value + (Const : in out O_Dnode; Const_Type : O_Tnode; Str : String) + is + Res : O_Cnode; + List : O_Array_Aggr_List; + begin + Start_Const_Value (Const); + Start_Array_Aggr (List, Const_Type); + for I in Str'Range loop + New_Array_Aggr_El + (List, + New_Unsigned_Literal (Char_Type_Node, Character'Pos (Str (I)))); + end loop; + New_Array_Aggr_El (List, New_Unsigned_Literal (Char_Type_Node, 0)); + Finish_Array_Aggr (List, Res); + Finish_Const_Value (Const, Res); + end Create_String_Value; + + function Create_String (Str : String; Id : O_Ident) return O_Dnode + is + Atype : O_Tnode; + Const : O_Dnode; + begin + Atype := Create_String_Type (Str); + New_Const_Decl (Const, Id, O_Storage_Private, Atype); + Create_String_Value (Const, Atype, Str); + return Const; + end Create_String; + + function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) + return O_Dnode + is + Atype : O_Tnode; + Const : O_Dnode; + begin + Atype := Create_String_Type (Str); + New_Const_Decl (Const, Id, Storage, Atype); + if Storage /= O_Storage_External then + Create_String_Value (Const, Atype, Str); + end if; + return Const; + end Create_String; + + function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) + return O_Dnode + is + use Name_Table; + begin + if Name_Table.Is_Character (Str) then + raise Internal_Error; + end if; + Image (Str); + return Create_String (Name_Buffer (1 .. Name_Length), Id, Storage); + end Create_String; + + function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode + is + Str_Cst : O_Dnode; + Str_Len : O_Cnode; + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Str_Cst := Create_String (Str, Id); + Str_Len := New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Str'Length)); + Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node); + New_Record_Aggr_El (List, Str_Len); + New_Record_Aggr_El (List, New_Global_Address (Str_Cst, + Char_Ptr_Type)); + Finish_Record_Aggr (List, Res); + return Res; + end Create_String_Len; + + procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode) + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Memcpy); + New_Association (Constr, New_Convert_Ov (Dest, Ghdl_Ptr_Type)); + New_Association (Constr, New_Convert_Ov (Src, Ghdl_Ptr_Type)); + New_Association (Constr, Length); + New_Procedure_Call (Constr); + end Gen_Memcpy; + +-- function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode +-- is +-- Constr : O_Assoc_List; +-- begin +-- Start_Association (Constr, Ghdl_Malloc); +-- New_Association (Constr, Length); +-- return New_Convert_Ov (New_Function_Call (Constr), Ptype); +-- end Gen_Malloc; + + function Gen_Alloc + (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + case Kind is + when Alloc_Heap => + Start_Association (Constr, Ghdl_Malloc); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + when Alloc_System => + Start_Association (Constr, Ghdl_Malloc0); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + when Alloc_Stack => + return New_Alloca (Ptype, Size); + when Alloc_Return => + Start_Association (Constr, Ghdl_Stack2_Allocate); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + end case; + end Gen_Alloc; + + procedure Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_Scalar => + Do_Non_Composite (Targ, Targ_Type, Data); + when Type_Mode_Fat_Array + | Type_Mode_Array => + declare + Var_Array : Mnode; + Var_Base : Mnode; + Var_Length : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + Sub_Data : Data_Type; + Composite_Data : Composite_Data_Type; + begin + Open_Temp; + Var_Array := Stabilize (Targ); + Var_Length := Create_Temp (Ghdl_Index_Type); + Var_Base := Stabilize (Chap3.Get_Array_Base (Var_Array)); + New_Assign_Stmt + (New_Obj (Var_Length), + Chap3.Get_Array_Length (Var_Array, Targ_Type)); + Composite_Data := + Prepare_Data_Array (Var_Array, Targ_Type, Data); + if True then + Var_I := Create_Temp (Ghdl_Index_Type); + else + New_Var_Decl + (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + end if; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Ge, + New_Value (New_Obj (Var_I)), + New_Value (New_Obj (Var_Length)), + Ghdl_Bool_Type)); + Sub_Data := Update_Data_Array + (Composite_Data, Targ_Type, Var_I); + Foreach_Non_Composite + (Chap3.Index_Base (Var_Base, Targ_Type, + New_Value (New_Obj (Var_I))), + Get_Element_Subtype (Targ_Type), + Sub_Data); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Data_Array (Composite_Data); + Close_Temp; + end; + when Type_Mode_Record => + declare + Var_Record : Mnode; + Sub_Data : Data_Type; + Composite_Data : Composite_Data_Type; + List : Iir_List; + El : Iir_Element_Declaration; + begin + Open_Temp; + Var_Record := Stabilize (Targ); + Composite_Data := + Prepare_Data_Record (Var_Record, Targ_Type, Data); + List := Get_Elements_Declaration_List + (Get_Base_Type (Targ_Type)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Sub_Data := Update_Data_Record + (Composite_Data, Targ_Type, El); + Foreach_Non_Composite + (Chap6.Translate_Selected_Element (Var_Record, El), + Get_Type (El), + Sub_Data); + end loop; + Finish_Data_Record (Composite_Data); + Close_Temp; + end; + when others => + Error_Kind ("foreach_non_composite/" + & Type_Mode_Type'Image (Type_Info.Type_Mode), + Targ_Type); + end case; + end Foreach_Non_Composite; + + procedure Register_Non_Composite_Signal (Targ : Mnode; + Targ_Type : Iir; + Proc : O_Dnode) + is + pragma Unreferenced (Targ_Type); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Proc); + New_Association + (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end Register_Non_Composite_Signal; + + function Register_Update_Data_Array + (Data : O_Dnode; Targ_Type : Iir; Index : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ_Type); + pragma Unreferenced (Index); + begin + return Data; + end Register_Update_Data_Array; + + function Register_Prepare_Data_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ); + pragma Unreferenced (Targ_Type); + begin + return Data; + end Register_Prepare_Data_Composite; + + function Register_Update_Data_Record + (Data : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Dnode + is + pragma Unreferenced (Targ_Type); + pragma Unreferenced (El); + begin + return Data; + end Register_Update_Data_Record; + + procedure Register_Finish_Data_Composite (D : in out O_Dnode) + is + pragma Unreferenced (D); + begin + null; + end Register_Finish_Data_Composite; + + procedure Register_Signal_1 is new Foreach_Non_Composite + (Data_Type => O_Dnode, + Composite_Data_Type => O_Dnode, + Do_Non_Composite => Register_Non_Composite_Signal, + Prepare_Data_Array => Register_Prepare_Data_Composite, + Update_Data_Array => Register_Update_Data_Array, + Finish_Data_Array => Register_Finish_Data_Composite, + Prepare_Data_Record => Register_Prepare_Data_Composite, + Update_Data_Record => Register_Update_Data_Record, + Finish_Data_Record => Register_Finish_Data_Composite); + + procedure Register_Signal (Targ : Mnode; + Targ_Type : Iir; + Proc : O_Dnode) + renames Register_Signal_1; + + procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode) + is + El : Iir; + Sig : Mnode; + begin + if List = Null_Iir_List then + return; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Open_Temp; + Sig := Chap6.Translate_Name (El); + Register_Signal (Sig, Get_Type (El), Proc); + Close_Temp; + end loop; + end Register_Signal_List; + + function Gen_Oenode_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : O_Enode) + return Mnode + is + pragma Unreferenced (Targ); + Res : Mnode; + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Targ_Type); + Res := E2M (Val, Type_Info, Mode_Value); + case Type_Info.Type_Mode is + when Type_Mode_Array + | Type_Mode_Fat_Array => + Res := Chap3.Get_Array_Base (Res); + when Type_Mode_Record => + Res := Stabilize (Res); + when others => + -- Not a composite type! + raise Internal_Error; + end case; + return Res; + end Gen_Oenode_Prepare_Data_Composite; + + function Gen_Oenode_Update_Data_Array (Val : Mnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Enode + is + begin + return M2E (Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index))); + end Gen_Oenode_Update_Data_Array; + + function Gen_Oenode_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Enode + is + pragma Unreferenced (Targ_Type); + begin + return M2E (Chap6.Translate_Selected_Element (Val, El)); + end Gen_Oenode_Update_Data_Record; + + procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Oenode_Finish_Data_Composite; + + function Get_Line_Number (Target: Iir) return Natural + is + Line, Col: Natural; + Name : Name_Id; + begin + Files_Map.Location_To_Position + (Get_Location (Target), Name, Line, Col); + return Line; + end Get_Line_Number; + + procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; + Line : Natural) is + begin + New_Association (Assoc, + New_Lit (New_Global_Address (Current_Filename_Node, + Char_Ptr_Type))); + New_Association (Assoc, New_Lit (New_Signed_Literal + (Ghdl_I32_Type, Integer_64 (Line)))); + end Assoc_Filename_Line; + end Helpers; + + package body Chap1 is + procedure Start_Block_Decl (Blk : Iir) + is + Info : constant Block_Info_Acc := Get_Info (Blk); + begin + Chap2.Declare_Inst_Type_And_Ptr + (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type); + end Start_Block_Decl; + + procedure Translate_Entity_Init (Entity : Iir) + is + El : Iir; + El_Type : Iir; + begin + Push_Local_Factory; + + -- Generics. + El := Get_Generic_Chain (Entity); + while El /= Null_Iir loop + Open_Temp; + Chap4.Elab_Object_Value (El, Get_Default_Value (El)); + Close_Temp; + El := Get_Chain (El); + end loop; + + -- Ports. + El := Get_Port_Chain (Entity); + while El /= Null_Iir loop + Open_Temp; + El_Type := Get_Type (El); + if not Is_Fully_Constrained_Type (El_Type) then + Chap5.Elab_Unconstrained_Port (El, Get_Default_Value (El)); + end if; + Chap4.Elab_Signal_Declaration_Storage (El); + Chap4.Elab_Signal_Declaration_Object (El, Entity, False); + Close_Temp; + + El := Get_Chain (El); + end loop; + + Pop_Local_Factory; + end Translate_Entity_Init; + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration) + is + Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Instance : Chap2.Subprg_Instance_Type; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Info := Add_Info (Entity, Kind_Block); + Chap1.Start_Block_Decl (Entity); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Entity link (RTI and pointer to parent). + Info.Block_Link_Field := Add_Instance_Factory_Field + (Wki_Rti, Rtis.Ghdl_Entity_Link_Type); + + -- generics, ports. + Chap4.Translate_Generic_Chain (Entity); + Chap4.Translate_Port_Chain (Entity); + + Chap9.Translate_Block_Declarations (Entity, Entity); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + + -- Entity elaborator. + Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); + + -- Entity dependences elaborator. + Start_Procedure_Decl (Interface_List, Create_Identifier ("PKG_ELAB"), + Global_Storage); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Pkg_Subprg); + + -- Generate RTI. + if Flag_Rti then + Rtis.Generate_Unit (Entity); + end if; + + if Global_Storage = O_Storage_External then + -- Entity declaration subprograms. + Chap4.Translate_Declaration_Chain_Subprograms (Entity); + else + -- Entity declaration and process subprograms. + Chap9.Translate_Block_Subprograms (Entity, Entity); + + -- Package elaborator Body. + Start_Subprogram_Body (Info.Block_Elab_Pkg_Subprg); + Push_Local_Factory; + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + Chap2.Elab_Dependence (Get_Design_Unit (Entity)); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- Elaborator Body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Instance); + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + + Chap9.Elab_Block_Declarations (Entity, Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- Default value if any. + if False then --Is_Entity_Declaration_Top (Entity) then + declare + Init_Subprg : O_Dnode; + begin + Start_Procedure_Decl + (Interface_List, Create_Identifier ("_INIT"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Init_Subprg); + + Start_Subprogram_Body (Init_Subprg); + Chap2.Start_Subprg_Instance_Use (Instance); + Translate_Entity_Init (Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Finish_Subprogram_Body; + end; + end if; + end if; + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end Translate_Entity_Declaration; + + -- Push scope for architecture ARCH via INSTANCE, and for its + -- entity via the entity field of the instance. + procedure Push_Architecture_Scope (Arch : Iir; Instance : O_Dnode) + is + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + begin + Set_Scope_Via_Param_Ptr (Arch_Info.Block_Scope, Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Arch_Info.Block_Parent_Field, + Arch_Info.Block_Scope'Access); + end Push_Architecture_Scope; + + -- Pop scopes created by Push_Architecture_Scope. + procedure Pop_Architecture_Scope (Arch : Iir) + is + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + begin + Clear_Scope (Entity_Info.Block_Scope); + Clear_Scope (Arch_Info.Block_Scope); + end Pop_Architecture_Scope; + + procedure Translate_Architecture_Body (Arch : Iir) + is + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + Instance : O_Dnode; + Var_Arch_Instance : O_Dnode; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + if Get_Foreign_Flag (Arch) then + Error_Msg_Sem ("FOREIGN architectures are not yet handled", Arch); + end if; + + Info := Add_Info (Arch, Kind_Block); + Start_Block_Decl (Arch); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- We cannot use Add_Scope_Field here, because the entity is not a + -- child scope of the architecture. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Get_Identifier ("ENTITY"), + Get_Scope_Type (Entity_Info.Block_Scope)); + + Chap9.Translate_Block_Declarations (Arch, Arch); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + -- Declare the constant containing the size of the instance. + New_Const_Decl + (Info.Block_Instance_Size, Create_Identifier ("INSTSIZE"), + Global_Storage, Ghdl_Index_Type); + if Global_Storage /= O_Storage_External then + Start_Const_Value (Info.Block_Instance_Size); + Finish_Const_Value + (Info.Block_Instance_Size, Get_Scope_Size (Info.Block_Scope)); + end if; + + -- Elaborator. + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB"), Global_Storage); + New_Interface_Decl + (Interface_List, Instance, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); + + -- Generate RTI. + if Flag_Rti then + Rtis.Generate_Unit (Arch); + end if; + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Create process subprograms. + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Info.Block_Parent_Field, + Info.Block_Scope'Access); + + Chap9.Translate_Block_Subprograms (Arch, Arch); + + Clear_Scope (Entity_Info.Block_Scope); + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + + -- Elaborator body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + + -- Create a variable for the architecture instance (with the right + -- type, instead of the entity instance type). + New_Var_Decl (Var_Arch_Instance, Wki_Arch_Instance, + O_Storage_Local, Info.Block_Decls_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Arch_Instance), + New_Convert_Ov (New_Value (New_Obj (Instance)), + Info.Block_Decls_Ptr_Type)); + + -- Set RTI. + if Flag_Rti then + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Instance), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Rti), + New_Unchecked_Address (New_Obj (Info.Block_Rti_Const), + Rtis.Ghdl_Rti_Access)); + end if; + + -- Call entity elaborators. + Start_Association (Constr, Entity_Info.Block_Elab_Subprg); + New_Association (Constr, New_Value (New_Obj (Instance))); + New_Procedure_Call (Constr); + + Push_Architecture_Scope (Arch, Var_Arch_Instance); + + New_Debug_Line_Stmt (Get_Line_Number (Arch)); + Chap2.Elab_Dependence (Get_Design_Unit (Arch)); + + Chap9.Elab_Block_Declarations (Arch, Arch); + --Chap6.Leave_Simple_Name (Ghdl_Leave_Architecture); + + Pop_Architecture_Scope (Arch); + + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Architecture_Body; + + procedure Translate_Component_Configuration_Decl + (Cfg : Iir; Blk : Iir; Base_Block : Iir; Num : in out Iir_Int32) + is + Inter_List : O_Inter_List; + Comp : Iir_Component_Declaration; + Comp_Info : Comp_Info_Acc; + Info : Config_Info_Acc; + Instance : O_Dnode; + Mark, Mark2 : Id_Mark_Type; + + Base_Info : Block_Info_Acc; + Base_Instance : O_Dnode; + + Block : Iir_Block_Configuration; + Binding : Iir_Binding_Indication; + Entity_Aspect : Iir; + Conf_Override : Iir; + Conf_Info : Config_Info_Acc; + begin + -- Incremental binding. + if Get_Nbr_Elements (Get_Instantiation_List (Cfg)) = 0 then + -- This component configuration applies to no component + -- instantiation, so it is not translated. + return; + end if; + + Binding := Get_Binding_Indication (Cfg); + if Binding = Null_Iir then + -- This is an unbound component configuration, since this is a + -- no-op, it is not translated. + return; + end if; + + Entity_Aspect := Get_Entity_Aspect (Binding); + + Comp := Get_Named_Entity (Get_Component_Name (Cfg)); + Comp_Info := Get_Info (Comp); + + if Get_Kind (Cfg) = Iir_Kind_Component_Configuration then + Block := Get_Block_Configuration (Cfg); + else + Block := Null_Iir; + end if; + + Push_Identifier_Prefix (Mark, Get_Identifier (Comp), Num); + Num := Num + 1; + + if Block /= Null_Iir then + Push_Identifier_Prefix (Mark2, "CONFIG"); + Translate_Configuration_Declaration (Cfg); + Pop_Identifier_Prefix (Mark2); + Conf_Override := Cfg; + Conf_Info := Get_Info (Cfg); + Clear_Info (Cfg); + else + Conf_Info := null; + Conf_Override := Null_Iir; + end if; + Info := Add_Info (Cfg, Kind_Config); + + Base_Info := Get_Info (Base_Block); + + Chap4.Translate_Association_Subprograms + (Binding, Blk, Base_Block, + Get_Entity_From_Entity_Aspect (Entity_Aspect)); + + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Comp_Info.Comp_Ptr_Type); + New_Interface_Decl (Inter_List, Base_Instance, Get_Identifier ("BLK"), + Base_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Config_Subprg); + + -- Extract the entity/architecture. + + Start_Subprogram_Body (Info.Config_Subprg); + Push_Local_Factory; + + if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then + Push_Architecture_Scope (Base_Block, Base_Instance); + else + Set_Scope_Via_Param_Ptr (Base_Info.Block_Scope, Base_Instance); + end if; + + Set_Scope_Via_Param_Ptr (Comp_Info.Comp_Scope, Instance); + + if Conf_Info /= null then + Clear_Info (Cfg); + Set_Info (Cfg, Conf_Info); + end if; + Chap9.Translate_Entity_Instantiation + (Entity_Aspect, Binding, Comp, Conf_Override); + if Conf_Info /= null then + Clear_Info (Cfg); + Set_Info (Cfg, Info); + end if; + + Clear_Scope (Comp_Info.Comp_Scope); + + if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then + Pop_Architecture_Scope (Base_Block); + else + Clear_Scope (Base_Info.Block_Scope); + end if; + + Pop_Local_Factory; + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark); + end Translate_Component_Configuration_Decl; + + -- Create subprogram specifications for each configuration_specification + -- in BLOCK_CONFIG and its sub-blocks. + -- BLOCK is the block being configured (initially the architecture), + -- BASE_BLOCK is the root block giving the instance (initially the + -- architecture) + -- NUM is an integer used to generate uniq names. + procedure Translate_Block_Configuration_Decls + (Block_Config : Iir_Block_Configuration; + Block : Iir; + Base_Block : Iir; + Num : in out Iir_Int32) + is + El : Iir; + begin + El := Get_Configuration_Item_Chain (Block_Config); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + Translate_Component_Configuration_Decl + (El, Block, Base_Block, Num); + when Iir_Kind_Block_Configuration => + declare + Mark : Id_Mark_Type; + Base_Info : constant Block_Info_Acc := + Get_Info (Base_Block); + Blk : constant Iir := Get_Block_From_Block_Specification + (Get_Block_Specification (El)); + Blk_Info : constant Block_Info_Acc := Get_Info (Blk); + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Blk)); + case Get_Kind (Blk) is + when Iir_Kind_Generate_Statement => + Set_Scope_Via_Field_Ptr + (Base_Info.Block_Scope, + Blk_Info.Block_Origin_Field, + Blk_Info.Block_Scope'Access); + Translate_Block_Configuration_Decls + (El, Blk, Blk, Num); + Clear_Scope (Base_Info.Block_Scope); + when Iir_Kind_Block_Statement => + Translate_Block_Configuration_Decls + (El, Blk, Base_Block, Num); + when others => + Error_Kind + ("translate_block_configuration_decls(2)", Blk); + end case; + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("translate_block_configuration_decls(1)", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Configuration_Decls; + + procedure Translate_Component_Configuration_Call + (Cfg : Iir; Base_Block : Iir; Block_Info : Block_Info_Acc) + is + Cfg_Info : Config_Info_Acc; + Base_Info : Block_Info_Acc; + begin + if Get_Binding_Indication (Cfg) = Null_Iir then + -- Unbound component configuration, nothing to do. + return; + end if; + + Cfg_Info := Get_Info (Cfg); + Base_Info := Get_Info (Base_Block); + + -- Call the subprogram for the instantiation list. + declare + List : Iir_List; + El : Iir; + begin + List := Get_Instantiation_List (Cfg); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El := Get_Named_Entity (El); + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + declare + Assoc : O_Assoc_List; + Info : constant Block_Info_Acc := Get_Info (El); + Comp_Info : constant Comp_Info_Acc := + Get_Info (Get_Named_Entity + (Get_Instantiated_Unit (El))); + V : O_Lnode; + begin + -- The component is really a component and not a + -- direct instance. + Start_Association (Assoc, Cfg_Info.Config_Subprg); + V := Get_Instance_Ref (Block_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Link_Field); + New_Association + (Assoc, New_Address (V, Comp_Info.Comp_Ptr_Type)); + V := Get_Instance_Ref (Base_Info.Block_Scope); + New_Association + (Assoc, + New_Address (V, Base_Info.Block_Decls_Ptr_Type)); + New_Procedure_Call (Assoc); + end; + when others => + Error_Kind ("translate_component_configuration", El); + end case; + end loop; + end; + end Translate_Component_Configuration_Call; + + procedure Translate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Base_Block : Iir; + Base_Info : Block_Info_Acc); + + procedure Translate_Generate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Parent_Info : Block_Info_Acc) + is + Spec : constant Iir := Get_Block_Specification (Block_Config); + Block : constant Iir := Get_Block_From_Block_Specification (Spec); + Info : constant Block_Info_Acc := Get_Info (Block); + Scheme : constant Iir := Get_Generation_Scheme (Block); + + Type_Info : Type_Info_Acc; + Iter_Type : Iir; + + -- Generate a call for a iterative generate block whose index is + -- INDEX. + -- FAILS is true if it is an error if the block is already + -- configured. + procedure Gen_Subblock_Call (Index : O_Enode; Fails : Boolean) + is + Var_Inst : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + Var_Inst := Create_Temp (Info.Block_Decls_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Inst), + New_Address (New_Indexed_Element + (New_Acc_Value + (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Info.Block_Parent_Field)), + Index), + Info.Block_Decls_Ptr_Type)); + -- Configure only if not yet configured. + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Value_Selected_Acc_Value + (New_Obj (Var_Inst), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_False_Node), + Ghdl_Bool_Type)); + -- Mark the block as configured. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Inst), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_True_Node)); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var_Inst); + Translate_Block_Configuration_Calls (Block_Config, Block, Info); + Clear_Scope (Info.Block_Scope); + + if Fails then + New_Else_Stmt (If_Blk); + -- Already configured. + Chap6.Gen_Program_Error + (Block_Config, Chap6.Prg_Err_Block_Configured); + end if; + + Finish_If_Stmt (If_Blk); + Close_Temp; + end Gen_Subblock_Call; + + procedure Apply_To_All_Others_Blocks (Is_All : Boolean) + is + Var_I : O_Dnode; + Label : O_Snode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op + (ON_Eq, + New_Value (New_Obj (Var_I)), + New_Value + (New_Selected_Element + (Get_Var (Get_Info (Iter_Type).T.Range_Var), + Type_Info.T.Range_Length)), + Ghdl_Bool_Type)); + -- Selected_name is for default configurations, so + -- program should not fail if a block is already + -- configured but continue silently. + Gen_Subblock_Call (New_Value (New_Obj (Var_I)), Is_All); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + end Apply_To_All_Others_Blocks; + begin + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Type_Info := Get_Info (Get_Base_Type (Iter_Type)); + case Get_Kind (Spec) is + when Iir_Kind_Generate_Statement + | Iir_Kind_Simple_Name => + Apply_To_All_Others_Blocks (True); + when Iir_Kind_Indexed_Name => + declare + Index_List : constant Iir_List := Get_Index_List (Spec); + Rng : Mnode; + begin + if Index_List = Iir_List_Others then + Apply_To_All_Others_Blocks (False); + else + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); + Gen_Subblock_Call + (Chap6.Translate_Index_To_Offset + (Rng, + Chap7.Translate_Expression + (Get_Nth_Element (Index_List, 0), Iter_Type), + Scheme, Iter_Type, Spec), + True); + Close_Temp; + end if; + end; + when Iir_Kind_Slice_Name => + declare + Rng : Mnode; + Slice : O_Dnode; + Slice_Ptr : O_Dnode; + Left, Right : O_Dnode; + Index : O_Dnode; + High : O_Dnode; + If_Blk : O_If_Block; + Label : O_Snode; + begin + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); + Slice := Create_Temp (Type_Info.T.Range_Type); + Slice_Ptr := Create_Temp_Ptr + (Type_Info.T.Range_Ptr_Type, New_Obj (Slice)); + Chap7.Translate_Discrete_Range_Ptr + (Slice_Ptr, Get_Suffix (Spec)); + Left := Create_Temp_Init + (Ghdl_Index_Type, + Chap6.Translate_Index_To_Offset + (Rng, + New_Value (New_Selected_Element + (New_Obj (Slice), Type_Info.T.Range_Left)), + Spec, Iter_Type, Spec)); + Right := Create_Temp_Init + (Ghdl_Index_Type, + Chap6.Translate_Index_To_Offset + (Rng, + New_Value (New_Selected_Element + (New_Obj (Slice), + Type_Info.T.Range_Right)), + Spec, Iter_Type, Spec)); + Index := Create_Temp (Ghdl_Index_Type); + High := Create_Temp (Ghdl_Index_Type); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Value + (New_Selected_Element + (New_Obj (Slice), + Type_Info.T.Range_Dir)), + Ghdl_Bool_Type)); + -- Same direction, so left to right. + New_Assign_Stmt (New_Obj (Index), + New_Value (New_Obj (Left))); + New_Assign_Stmt (New_Obj (High), + New_Value (New_Obj (Right))); + New_Else_Stmt (If_Blk); + -- Opposite direction, so right to left. + New_Assign_Stmt (New_Obj (Index), + New_Value (New_Obj (Right))); + New_Assign_Stmt (New_Obj (High), + New_Value (New_Obj (Left))); + Finish_If_Stmt (If_Blk); + + -- Loop. + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Gt, + New_Value (New_Obj (Index)), + New_Value (New_Obj (High)), + Ghdl_Bool_Type)); + Open_Temp; + Gen_Subblock_Call (New_Value (New_Obj (Index)), True); + Close_Temp; + Inc_Var (Index); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + when others => + Error_Kind + ("translate_generate_block_configuration_calls", Spec); + end case; + else + -- Conditional generate statement. + declare + Var : O_Dnode; + If_Blk : O_If_Block; + begin + -- Configure the block only if it was created. + Open_Temp; + Var := Create_Temp_Init + (Info.Block_Decls_Ptr_Type, + New_Value (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Info.Block_Parent_Field))); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Neq, + New_Obj_Value (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), + Ghdl_Bool_Type)); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Translate_Block_Configuration_Calls (Block_Config, Block, Info); + Clear_Scope (Info.Block_Scope); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + end if; + end Translate_Generate_Block_Configuration_Calls; + + procedure Translate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Base_Block : Iir; + Base_Info : Block_Info_Acc) + is + El : Iir; + begin + El := Get_Configuration_Item_Chain (Block_Config); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + Translate_Component_Configuration_Call + (El, Base_Block, Base_Info); + when Iir_Kind_Block_Configuration => + declare + Block : constant Iir := Strip_Denoting_Name + (Get_Block_Specification (El)); + begin + if Get_Kind (Block) = Iir_Kind_Block_Statement then + Translate_Block_Configuration_Calls + (El, Base_Block, Get_Info (Block)); + else + Translate_Generate_Block_Configuration_Calls + (El, Base_Info); + end if; + end; + when others => + Error_Kind ("translate_block_configuration_calls(2)", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Configuration_Calls; + + procedure Translate_Configuration_Declaration (Config : Iir) + is + Block_Config : constant Iir_Block_Configuration := + Get_Block_Configuration (Config); + Arch : constant Iir_Architecture_Body := + Get_Block_Specification (Block_Config); + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Interface_List : O_Inter_List; + Config_Info : Config_Info_Acc; + Instance : O_Dnode; + Num : Iir_Int32; + Final : Boolean; + begin + if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then + Chap4.Translate_Declaration_Chain (Config); + end if; + + Config_Info := Add_Info (Config, Kind_Config); + + -- Configurator. + Start_Procedure_Decl + (Interface_List, Create_Identifier, Global_Storage); + New_Interface_Decl (Interface_List, Instance, Wki_Instance, + Arch_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, Config_Info.Config_Subprg); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Declare subprograms for configuration. + Num := 0; + Translate_Block_Configuration_Decls (Block_Config, Arch, Arch, Num); + + -- Body. + Start_Subprogram_Body (Config_Info.Config_Subprg); + Push_Local_Factory; + + Push_Architecture_Scope (Arch, Instance); + + if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then + Open_Temp; + Chap4.Elab_Declaration_Chain (Config, Final); + Close_Temp; + if Final then + raise Internal_Error; + end if; + end if; + + Translate_Block_Configuration_Calls (Block_Config, Arch, Arch_Info); + + Pop_Architecture_Scope (Arch); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Configuration_Declaration; + end Chap1; + + package body Chap2 is + procedure Elab_Package (Spec : Iir_Package_Declaration); + + type Name_String_Xlat_Array is array (Name_Id range <>) of + String (1 .. 4); + Operator_String_Xlat : constant + Name_String_Xlat_Array (Std_Names.Name_Id_Operators) := + (Std_Names.Name_Op_Equality => "OPEq", + Std_Names.Name_Op_Inequality => "OPNe", + Std_Names.Name_Op_Less => "OPLt", + Std_Names.Name_Op_Less_Equal => "OPLe", + Std_Names.Name_Op_Greater => "OPGt", + Std_Names.Name_Op_Greater_Equal => "OPGe", + Std_Names.Name_Op_Plus => "OPPl", + Std_Names.Name_Op_Minus => "OPMi", + Std_Names.Name_Op_Mul => "OPMu", + Std_Names.Name_Op_Div => "OPDi", + Std_Names.Name_Op_Exp => "OPEx", + Std_Names.Name_Op_Concatenation => "OPCc", + Std_Names.Name_Op_Condition => "OPCd", + Std_Names.Name_Op_Match_Equality => "OPQe", + Std_Names.Name_Op_Match_Inequality => "OPQi", + Std_Names.Name_Op_Match_Less => "OPQL", + Std_Names.Name_Op_Match_Less_Equal => "OPQl", + Std_Names.Name_Op_Match_Greater => "OPQG", + Std_Names.Name_Op_Match_Greater_Equal => "OPQg"); + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type) + is + Id : Name_Id; + begin + -- FIXME: name_shift_operators, name_logical_operators, + -- name_word_operators, name_mod, name_rem + Id := Get_Identifier (Spec); + if Id in Std_Names.Name_Id_Operators then + Push_Identifier_Prefix + (Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec)); + else + Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec)); + end if; + end Push_Subprg_Identifier; + + procedure Translate_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + Mark : Id_Mark_Type; + begin + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Translate_Object_Subtype (Inter); + Inter := Get_Chain (Inter); + end loop; + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Interfaces; + + procedure Elab_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + begin + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Elab_Object_Subtype (Get_Type (Inter)); + Inter := Get_Chain (Inter); + end loop; + end Elab_Subprogram_Interfaces; + + + -- Return the type of a subprogram interface. + -- Return O_Tnode_Null if the parameter is passed through the + -- interface record. + function Translate_Interface_Type (Inter : Iir) return O_Tnode + is + Mode : Object_Kind_Type; + Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); + begin + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_File_Declaration => + Mode := Mode_Value; + when Iir_Kind_Interface_Signal_Declaration => + Mode := Mode_Signal; + when others => + Error_Kind ("translate_interface_type", Inter); + end case; + case Tinfo.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Tinfo.Ortho_Type (Mode); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + return Tinfo.Ortho_Ptr_Type (Mode); + end case; + end Translate_Interface_Type; + + procedure Translate_Subprogram_Declaration (Spec : Iir) + is + Info : constant Subprg_Info_Acc := Get_Info (Spec); + Is_Func : constant Boolean := + Get_Kind (Spec) = Iir_Kind_Function_Declaration; + Inter : Iir; + Inter_Type : Iir; + Arg_Info : Ortho_Info_Acc; + Tinfo : Type_Info_Acc; + Interface_List : O_Inter_List; + Has_Result_Record : Boolean; + El_List : O_Element_List; + Mark : Id_Mark_Type; + Rtype : Iir; + Id : O_Ident; + Storage : O_Storage; + Foreign : Foreign_Info_Type := Foreign_Bad; + begin + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + if Get_Foreign_Flag (Spec) then + -- Special handling for foreign subprograms. + Foreign := Translate_Foreign_Id (Spec); + case Foreign.Kind is + when Foreign_Unknown => + Id := Create_Identifier; + when Foreign_Intrinsic => + Id := Create_Identifier; + when Foreign_Vhpidirect => + Id := Get_Identifier + (Name_Table.Name_Buffer (Foreign.Subprg_First + .. Foreign.Subprg_Last)); + end case; + Storage := O_Storage_External; + else + Id := Create_Identifier; + Storage := Global_Storage; + end if; + + if Is_Func then + -- If the result of a function is a composite type for ortho, + -- the result is allocated by the caller and an access to it is + -- given to the function. + Rtype := Get_Return_Type (Spec); + Info.Use_Stack2 := False; + Tinfo := Get_Info (Rtype); + + if Is_Composite (Tinfo) then + Start_Procedure_Decl (Interface_List, Id, Storage); + New_Interface_Decl + (Interface_List, Info.Res_Interface, + Get_Identifier ("RESULT"), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + -- Furthermore, if the result type is unconstrained, the + -- function will allocate it on a secondary stack. + if not Is_Fully_Constrained_Type (Rtype) then + Info.Use_Stack2 := True; + end if; + else + -- Normal function. + Start_Function_Decl + (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value)); + Info.Res_Interface := O_Dnode_Null; + end if; + else + -- Create info for each interface of the procedure. + -- For parameters passed via copy and that needs a copy-out, + -- gather them in a record. An access to the record is then + -- passed to the procedure. + Has_Result_Record := False; + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Arg_Info := Add_Info (Inter, Kind_Interface); + Inter_Type := Get_Type (Inter); + Tinfo := Get_Info (Inter_Type); + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Inter) in Iir_Out_Modes + and then Tinfo.Type_Mode not in Type_Mode_By_Ref + and then Tinfo.Type_Mode /= Type_Mode_File + then + -- This interface is done via the result record. + -- Note: file passed through variables are vhdl87 files, + -- which are initialized at elaboration and thus + -- behave like an IN parameter. + if not Has_Result_Record then + -- Create the record. + Start_Record_Type (El_List); + Has_Result_Record := True; + end if; + -- Add a field to the record. + New_Record_Field (El_List, Arg_Info.Interface_Field, + Create_Identifier_Without_Prefix (Inter), + Tinfo.Ortho_Type (Mode_Value)); + else + Arg_Info.Interface_Field := O_Fnode_Null; + end if; + Inter := Get_Chain (Inter); + end loop; + if Has_Result_Record then + -- Declare the record type and an access to the record. + Finish_Record_Type (El_List, Info.Res_Record_Type); + New_Type_Decl (Create_Identifier ("RESTYPE"), + Info.Res_Record_Type); + Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type); + New_Type_Decl (Create_Identifier ("RESPTR"), + Info.Res_Record_Ptr); + else + Info.Res_Interface := O_Dnode_Null; + end if; + + Start_Procedure_Decl (Interface_List, Id, Storage); + + if Has_Result_Record then + -- Add the record parameter. + New_Interface_Decl (Interface_List, Info.Res_Interface, + Get_Identifier ("RESULT"), + Info.Res_Record_Ptr); + end if; + end if; + + -- Instance parameter if any. + if not Get_Foreign_Flag (Spec) then + Chap2.Create_Subprg_Instance (Interface_List, Spec); + end if; + + -- Translate interfaces. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Is_Func then + -- Create the info. + Arg_Info := Add_Info (Inter, Kind_Interface); + Arg_Info.Interface_Field := O_Fnode_Null; + else + -- The info was already created (just above) + Arg_Info := Get_Info (Inter); + end if; + + if Arg_Info.Interface_Field = O_Fnode_Null then + -- Not via the RESULT parameter. + Arg_Info.Interface_Type := Translate_Interface_Type (Inter); + New_Interface_Decl + (Interface_List, Arg_Info.Interface_Node, + Create_Identifier_Without_Prefix (Inter), + Arg_Info.Interface_Type); + end if; + Inter := Get_Chain (Inter); + end loop; + Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); + + -- Call the hook for foreign subprograms. + if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then + Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func); + end if; + + Save_Local_Identifier (Info.Subprg_Local_Id); + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Declaration; + + -- Return TRUE iff subprogram specification SPEC is translated in an + -- ortho function. + function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean + is + begin + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + return False; + end if; + if Get_Info (Spec).Res_Interface /= O_Dnode_Null then + return False; + end if; + return True; + end Is_Subprogram_Ortho_Function; + + -- Return TRUE iif SUBPRG_BODY declares explicitely or implicitely + -- (or even implicitely by translation) a subprogram. + function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean + is + Decl : Iir; + Atype : Iir; + begin + Decl := Get_Declaration_Chain (Subprg_Body); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- The declaration preceed the body. + raise Internal_Error; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Atype := Get_Type_Definition (Decl); + case Iir_Kinds_Type_And_Subtype_Definition + (Get_Kind (Atype)) is + when Iir_Kinds_Scalar_Type_Definition => + null; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_File_Type_Definition => + return True; + when Iir_Kind_Protected_Type_Declaration => + raise Internal_Error; + when Iir_Kinds_Composite_Type_Definition => + -- At least for "=". + return True; + when Iir_Kind_Incomplete_Type_Definition => + null; + end case; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return False; + end Has_Nested_Subprograms; + + procedure Translate_Subprogram_Body (Subprg : Iir) + is + Spec : constant Iir := Get_Subprogram_Specification (Subprg); + Info : constant Ortho_Info_Acc := Get_Info (Spec); + + Old_Subprogram : Iir; + Mark : Id_Mark_Type; + Final : Boolean; + Is_Ortho_Func : Boolean; + + -- Set for a public method. In this case, the lock must be acquired + -- and retained. + Is_Prot : Boolean := False; + + -- True if the body has local (nested) subprograms. + Has_Nested : Boolean; + + Frame_Ptr_Type : O_Tnode; + Upframe_Field : O_Fnode; + + Frame : O_Dnode; + Frame_Ptr : O_Dnode; + + Has_Return : Boolean; + + Prev_Subprg_Instances : Chap2.Subprg_Instance_Stack; + begin + -- Do not translate body for foreign subprograms. + if Get_Foreign_Flag (Spec) then + return; + end if; + + -- Check if there are nested subprograms to unnest. In that case, + -- a frame record is created, which is less efficient than the + -- use of local variables. + if Flag_Unnest_Subprograms then + Has_Nested := Has_Nested_Subprograms (Subprg); + else + Has_Nested := False; + end if; + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + Restore_Local_Identifier (Info.Subprg_Local_Id); + + if Has_Nested then + -- Unnest subprograms. + -- Create an instance for the local declarations. + Push_Instance_Factory (Info.Subprg_Frame_Scope'Access); + Add_Subprg_Instance_Field (Upframe_Field); + + if Info.Res_Record_Ptr /= O_Tnode_Null then + Info.Res_Record_Var := + Create_Var (Create_Var_Identifier ("RESULT"), + Info.Res_Record_Ptr); + end if; + + -- Create fields for parameters. + -- FIXME: do it only if they are referenced in nested + -- subprograms. + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + Inter_Info.Interface_Field := + Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inter), + Inter_Info.Interface_Type); + end if; + Inter := Get_Chain (Inter); + end loop; + end; + + Chap4.Translate_Declaration_Chain (Subprg); + Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access); + + New_Type_Decl (Create_Identifier ("_FRAMETYPE"), + Get_Scope_Type (Info.Subprg_Frame_Scope)); + Declare_Scope_Acc + (Info.Subprg_Frame_Scope, + Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type); + + Rtis.Generate_Subprogram_Body (Subprg); + + -- Local frame + Chap2.Push_Subprg_Instance + (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, + Wki_Upframe, Prev_Subprg_Instances); + -- Link to previous frame + Chap2.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); + + -- Link to previous frame + Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + -- Local frame + Chap2.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances); + end if; + + -- Create the body + + Start_Subprogram_Body (Info.Ortho_Func); + + Start_Subprg_Instance_Use (Spec); + + -- Variables will be created on the stack. + Push_Local_Factory; + + -- Code has access to local (and outer) variables. + -- FIXME: this is not necessary if Has_Nested is set + Chap2.Clear_Subprg_Instance (Prev_Subprg_Instances); + + -- There is a local scope for temporaries. + Open_Local_Temp; + + if not Has_Nested then + Chap4.Translate_Declaration_Chain (Subprg); + Rtis.Generate_Subprogram_Body (Subprg); + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); + else + New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, + Get_Scope_Type (Info.Subprg_Frame_Scope)); + + New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"), + O_Storage_Local, Frame_Ptr_Type); + New_Assign_Stmt (New_Obj (Frame_Ptr), + New_Address (New_Obj (Frame), Frame_Ptr_Type)); + + -- FIXME: use direct reference (ie Frame instead of Frame_Ptr) + Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr); + + -- Set UPFRAME. + Chap2.Set_Subprg_Instance_Field + (Frame_Ptr, Upframe_Field, Info.Subprg_Instance); + + if Info.Res_Record_Type /= O_Tnode_Null then + -- Initialize the RESULT field + New_Assign_Stmt (Get_Var (Info.Res_Record_Var), + New_Obj_Value (Info.Res_Interface)); + -- Do not reference the RESULT field in the subprogram body, + -- directly reference the RESULT parameter. + -- FIXME: has a flag (see below for parameters). + Info.Res_Record_Var := Null_Var; + end if; + + -- Copy parameters to FRAME. + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + New_Assign_Stmt + (New_Selected_Element (New_Obj (Frame), + Inter_Info.Interface_Field), + New_Obj_Value (Inter_Info.Interface_Node)); + + -- Forget the reference to the field in FRAME, so that + -- this subprogram will directly reference the parameter + -- (and not its copy in the FRAME). + Inter_Info.Interface_Field := O_Fnode_Null; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + end if; + + -- Init out parameters passed by value/copy. + declare + Inter : Iir; + Inter_Type : Iir; + Type_Info : Type_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Inter) = Iir_Out_Mode + then + Inter_Type := Get_Type (Inter); + Type_Info := Get_Info (Inter_Type); + if (Type_Info.Type_Mode in Type_Mode_By_Value + or Type_Info.Type_Mode in Type_Mode_By_Copy) + and then Type_Info.Type_Mode /= Type_Mode_File + then + Chap4.Init_Object + (Chap6.Translate_Name (Inter), Inter_Type); + end if; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + + Chap4.Elab_Declaration_Chain (Subprg, Final); + + -- If finalization is required, create a dummy loop around the + -- body and convert returns into exit out of this loop. + -- If the subprogram is a function, also create a variable for the + -- result. + Is_Prot := Is_Subprogram_Method (Spec); + if Final or Is_Prot then + if Is_Prot then + -- Lock the object. + Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), + Ghdl_Protected_Enter); + end if; + Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec); + if Is_Ortho_Func then + New_Var_Decl + (Info.Subprg_Result, Get_Identifier ("RESULT"), + O_Storage_Local, + Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value)); + end if; + Start_Loop_Stmt (Info.Subprg_Exit); + end if; + + Old_Subprogram := Current_Subprogram; + Current_Subprogram := Spec; + Has_Return := Chap8.Translate_Statements_Chain_Has_Return + (Get_Sequential_Statement_Chain (Subprg)); + Current_Subprogram := Old_Subprogram; + + if Final or Is_Prot then + -- Create a barrier to catch missing return statement. + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + New_Exit_Stmt (Info.Subprg_Exit); + else + if not Has_Return then + -- Missing return + Chap6.Gen_Program_Error + (Subprg, Chap6.Prg_Err_Missing_Return); + end if; + end if; + Finish_Loop_Stmt (Info.Subprg_Exit); + Chap4.Final_Declaration_Chain (Subprg, False); + + if Is_Prot then + -- Unlock the object. + Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), + Ghdl_Protected_Leave); + end if; + if Is_Ortho_Func then + New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); + end if; + else + if Get_Kind (Spec) = Iir_Kind_Function_Declaration + and then not Has_Return + then + -- Missing return + Chap6.Gen_Program_Error + (Subprg, Chap6.Prg_Err_Missing_Return); + end if; + end if; + + if Has_Nested then + Clear_Scope (Info.Subprg_Frame_Scope); + end if; + + Chap2.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances); + Close_Local_Temp; + Pop_Local_Factory; + + Finish_Subprg_Instance_Use (Spec); + + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Body; + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) + is + Header : constant Iir := Get_Package_Header (Decl); + Info : Ortho_Info_Acc; + Interface_List : O_Inter_List; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Info := Add_Info (Decl, Kind_Package); + + -- Translate declarations. + if Is_Uninstantiated_Package (Decl) then + -- Create an instance for the spec. + Push_Instance_Factory (Info.Package_Spec_Scope'Access); + Chap4.Translate_Generic_Chain (Header); + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + Pop_Instance_Factory (Info.Package_Spec_Scope'Access); + + -- Name the spec instance and create a pointer. + New_Type_Decl (Create_Identifier ("SPECINSTTYPE"), + Get_Scope_Type (Info.Package_Spec_Scope)); + Declare_Scope_Acc (Info.Package_Spec_Scope, + Create_Identifier ("SPECINSTPTR"), + Info.Package_Spec_Ptr_Type); + + -- Create an instance and its pointer for the body. + Chap2.Declare_Inst_Type_And_Ptr + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type); + + -- Each subprogram has a body instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + else + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + end if; + + -- Translate subprograms declarations. + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + -- Declare elaborator for the body. + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Body_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Body_Subprg); + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + + -- The spec elaborator has a spec instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + end if; + + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Spec_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Spec_Subprg); + + if Flag_Rti then + -- Generate RTI. + Rtis.Generate_Unit (Decl); + end if; + + if Global_Storage = O_Storage_Public then + -- Create elaboration procedure for the spec + Elab_Package (Decl); + end if; + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; + Save_Local_Identifier (Info.Package_Local_Id); + end Translate_Package_Declaration; + + procedure Translate_Package_Body (Decl : Iir_Package_Body) + is + Spec : constant Iir_Package_Declaration := Get_Package (Decl); + Info : constant Ortho_Info_Acc := Get_Info (Spec); + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + -- Translate declarations. + if Is_Uninstantiated_Package (Spec) then + Push_Instance_Factory (Info.Package_Body_Scope'Access); + Info.Package_Spec_Field := Add_Instance_Factory_Field + (Get_Identifier ("SPEC"), + Get_Scope_Type (Info.Package_Spec_Scope)); + + Chap4.Translate_Declaration_Chain (Decl); + + Pop_Instance_Factory (Info.Package_Body_Scope'Access); + + if Global_Storage = O_Storage_External then + return; + end if; + else + -- May be called during elaboration to generate RTI. + if Global_Storage = O_Storage_External then + return; + end if; + + Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id); + + Chap4.Translate_Declaration_Chain (Decl); + end if; + + if Flag_Rti then + Rtis.Generate_Unit (Decl); + end if; + + if Is_Uninstantiated_Package (Spec) then + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; + + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; + + Elab_Package_Body (Spec, Decl); + end Translate_Package_Body; + + procedure Elab_Package (Spec : Iir_Package_Declaration) + is + Info : constant Ortho_Info_Acc := Get_Info (Spec); + Final : Boolean; + Constr : O_Assoc_List; + pragma Unreferenced (Final); + begin + Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); + + Elab_Dependence (Get_Design_Unit (Spec)); + + if not Is_Uninstantiated_Package (Spec) + and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit + then + -- Register the top level package. This is done dynamically, as + -- we know only during elaboration that the design depends on a + -- package (a package maybe referenced by an entity which is never + -- instantiated due to generate statements). + Start_Association (Constr, Ghdl_Rti_Add_Package); + New_Association + (Constr, + New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); + New_Procedure_Call (Constr); + end if; + + Open_Temp; + Chap4.Elab_Declaration_Chain (Spec, Final); + Close_Temp; + + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package; + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) + is + Info : constant Ortho_Info_Acc := Get_Info (Spec); + If_Blk : O_If_Block; + Constr : O_Assoc_List; + Final : Boolean; + begin + Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); + + if Is_Uninstantiated_Package (Spec) then + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; + + -- If the package was already elaborated, return now, + -- else mark the package as elaborated. + Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var))); + New_Return_Stmt; + New_Else_Stmt (If_Blk); + New_Assign_Stmt (Get_Var (Info.Package_Elab_Var), + New_Lit (Ghdl_Bool_True_Node)); + Finish_If_Stmt (If_Blk); + + -- Elab Spec. + Start_Association (Constr, Info.Package_Elab_Spec_Subprg); + Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance); + New_Procedure_Call (Constr); + + if Bod /= Null_Iir then + Elab_Dependence (Get_Design_Unit (Bod)); + Open_Temp; + Chap4.Elab_Declaration_Chain (Bod, Final); + Close_Temp; + end if; + + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + end if; + + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package_Body; + + procedure Instantiate_Iir_Info (N : Iir); + + procedure Instantiate_Iir_Chain_Info (Chain : Iir) + is + N : Iir; + begin + N := Chain; + while N /= Null_Iir loop + Instantiate_Iir_Info (N); + N := Get_Chain (N); + end loop; + end Instantiate_Iir_Chain_Info; + + procedure Instantiate_Iir_List_Info (L : Iir_List) + is + El : Iir; + begin + case L is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + return; + when others => + for I in Natural loop + El := Get_Nth_Element (L, I); + exit when El = Null_Iir; + Instantiate_Iir_Info (El); + end loop; + end case; + end Instantiate_Iir_List_Info; + + procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is + begin + case Src.Kind is + when Kind_Type => + Dest.all := (Kind => Kind_Type, + Type_Mode => Src.Type_Mode, + Type_Incomplete => Src.Type_Incomplete, + Type_Locally_Constrained => + Src.Type_Locally_Constrained, + C => null, + Ortho_Type => Src.Ortho_Type, + Ortho_Ptr_Type => Src.Ortho_Ptr_Type, + Type_Transient_Chain => Null_Iir, + T => Src.T, + Type_Rti => Src.Type_Rti); + pragma Assert (Src.C = null); + pragma Assert (Src.Type_Transient_Chain = Null_Iir); + when Kind_Object => + pragma Assert (Src.Object_Driver = Null_Var); + pragma Assert (Src.Object_Function = O_Dnode_Null); + Dest.all := + (Kind => Kind_Object, + Object_Static => Src.Object_Static, + Object_Var => Instantiate_Var (Src.Object_Var), + Object_Driver => Null_Var, + Object_Rti => Src.Object_Rti, + Object_Function => O_Dnode_Null); + when Kind_Subprg => + Dest.Subprg_Frame_Scope := + Instantiate_Var_Scope (Src.Subprg_Frame_Scope); + Dest.all := + (Kind => Kind_Subprg, + Use_Stack2 => Src.Use_Stack2, + Ortho_Func => Src.Ortho_Func, + Res_Interface => Src.Res_Interface, + Res_Record_Var => Instantiate_Var (Src.Res_Record_Var), + Res_Record_Type => Src.Res_Record_Type, + Res_Record_Ptr => Src.Res_Record_Ptr, + Subprg_Frame_Scope => Dest.Subprg_Frame_Scope, + Subprg_Instance => Instantiate_Subprg_Instance + (Src.Subprg_Instance), + Subprg_Resolv => null, + Subprg_Local_Id => Src.Subprg_Local_Id, + Subprg_Exit => Src.Subprg_Exit, + Subprg_Result => Src.Subprg_Result); + when Kind_Interface => + Dest.all := (Kind => Kind_Interface, + Interface_Node => Src.Interface_Node, + Interface_Field => Src.Interface_Field, + Interface_Type => Src.Interface_Type); + when Kind_Index => + Dest.all := (Kind => Kind_Index, + Index_Field => Src.Index_Field); + when Kind_Expr => + Dest.all := (Kind => Kind_Expr, + Expr_Node => Src.Expr_Node); + when others => + raise Internal_Error; + end case; + end Copy_Info; + + procedure Instantiate_Iir_Info (N : Iir) is + begin + -- Nothing to do for null node. + if N = Null_Iir then + return; + end if; + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + Orig : constant Iir := Sem_Inst.Get_Origin (N); + pragma Assert (Orig /= Null_Iir); + Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig); + Info : Ortho_Info_Acc; + begin + if Orig_Info /= null then + Info := Add_Info (N, Orig_Info.Kind); + + Copy_Info (Info, Orig_Info); + + case Info.Kind is + when Kind_Subprg => + Push_Instantiate_Var_Scope + (Info.Subprg_Frame_Scope'Access, + Orig_Info.Subprg_Frame_Scope'Access); + when others => + null; + end case; + end if; + + for I in Fields'Range loop + F := Fields (I); + case Get_Field_Type (F) is + when Type_Iir => + case Get_Field_Attribute (F) is + when Attr_None => + Instantiate_Iir_Info (Get_Iir (N, F)); + when Attr_Ref => + null; + when Attr_Maybe_Ref => + if not Get_Is_Ref (N) then + Instantiate_Iir_Info (Get_Iir (N, F)); + end if; + when Attr_Chain => + Instantiate_Iir_Chain_Info (Get_Iir (N, F)); + when Attr_Chain_Next => + null; + when Attr_Of_Ref => + raise Internal_Error; + end case; + when Type_Iir_List => + case Get_Field_Attribute (F) is + when Attr_None => + Instantiate_Iir_List_Info (Get_Iir_List (N, F)); + when Attr_Ref + | Attr_Of_Ref => + null; + when others => + raise Internal_Error; + end case; + when Type_PSL_NFA + | Type_PSL_Node => + -- TODO + raise Internal_Error; + when Type_Date_Type + | Type_Date_State_Type + | Type_Time_Stamp_Id => + -- Can this happen ? + raise Internal_Error; + when Type_String_Id + | Type_Source_Ptr + | Type_Base_Type + | Type_Iir_Constraint + | Type_Iir_Mode + | Type_Iir_Index32 + | Type_Iir_Int64 + | Type_Boolean + | Type_Iir_Staticness + | Type_Iir_All_Sensitized + | Type_Iir_Signal_Kind + | Type_Tri_State_Type + | Type_Iir_Pure_State + | Type_Iir_Delay_Mechanism + | Type_Iir_Lexical_Layout_Type + | Type_Iir_Predefined_Functions + | Type_Iir_Direction + | Type_Location_Type + | Type_Iir_Int32 + | Type_Int32 + | Type_Iir_Fp64 + | Type_Token_Type + | Type_Name_Id => + null; + end case; + end loop; + + if Info /= null then + case Info.Kind is + when Kind_Subprg => + Pop_Instantiate_Var_Scope + (Info.Subprg_Frame_Scope'Access); + when others => + null; + end case; + end if; + end; + end Instantiate_Iir_Info; + + procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir) + is + Inter : Iir; + Orig : Iir; + Orig_Info : Ortho_Info_Acc; + Info : Ortho_Info_Acc; + begin + Inter := Chain; + while Inter /= Null_Iir loop + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration => + Orig := Sem_Inst.Get_Origin (Inter); + Orig_Info := Get_Info (Orig); + + Info := Add_Info (Inter, Orig_Info.Kind); + Copy_Info (Info, Orig_Info); + + when Iir_Kind_Interface_Package_Declaration => + null; + + when others => + raise Internal_Error; + end case; + + Inter := Get_Chain (Inter); + end loop; + end Instantiate_Iir_Generic_Chain_Info; + + -- Add info for an interface_package_declaration or a + -- package_instantiation_declaration + procedure Instantiate_Info_Package (Inst : Iir) + is + Spec : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Inst, Kind_Package_Instance); + + -- Create the info instances. + Push_Instantiate_Var_Scope + (Info.Package_Instance_Spec_Scope'Access, + Pkg_Info.Package_Spec_Scope'Access); + Push_Instantiate_Var_Scope + (Info.Package_Instance_Body_Scope'Access, + Pkg_Info.Package_Body_Scope'Access); + Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst)); + Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst)); + Pop_Instantiate_Var_Scope + (Info.Package_Instance_Body_Scope'Access); + Pop_Instantiate_Var_Scope + (Info.Package_Instance_Spec_Scope'Access); + end Instantiate_Info_Package; + + procedure Translate_Package_Instantiation_Declaration (Inst : Iir) + is + Spec : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); + Info : Ortho_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + begin + Instantiate_Info_Package (Inst); + Info := Get_Info (Inst); + + -- FIXME: if the instantiation occurs within a package declaration, + -- the variable must be declared extern (and public in the body). + Info.Package_Instance_Body_Var := Create_Var + (Create_Var_Identifier (Inst), + Get_Scope_Type (Pkg_Info.Package_Body_Scope)); + + -- FIXME: this is correct only for global instantiation, and only if + -- there is only one. + Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope, + Pkg_Info.Package_Spec_Field, + Info.Package_Instance_Body_Scope'Access); + + -- Declare elaboration procedure + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB"), Global_Storage); + -- Chap2.Add_Subprg_Instance_Interfaces + -- (Interface_List, Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Instance_Elab_Subprg); + + if Global_Storage /= O_Storage_Public then + return; + end if; + + -- Elaborator: + Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg); + -- Chap2.Start_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + + Elab_Dependence (Get_Design_Unit (Inst)); + + Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope, + Pkg_Info.Package_Spec_Field, + Pkg_Info.Package_Body_Scope'Access); + Chap5.Elab_Generic_Map_Aspect (Inst); + Clear_Scope (Pkg_Info.Package_Spec_Scope); + Clear_Scope (Pkg_Info.Package_Body_Scope); + + -- Call the elaborator of the generic. The generic must be + -- temporary associated with the instance variable. + Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg); + Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Add_Subprg_Instance_Assoc + (Constr, Pkg_Info.Package_Elab_Body_Instance); + Clear_Scope (Pkg_Info.Package_Body_Scope); + New_Procedure_Call (Constr); + + -- Chap2.Finish_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Body; + end Translate_Package_Instantiation_Declaration; + + procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration) + is + Info : Ortho_Info_Acc; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + begin + -- Std.Standard is pre-elaborated. + if Pkg = Standard_Package then + return; + end if; + + -- Nothing to do for uninstantiated package. + if Is_Uninstantiated_Package (Pkg) then + return; + end if; + + -- Call the package elaborator only if not already elaborated. + Info := Get_Info (Pkg); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, + New_Value (Get_Var (Info.Package_Elab_Var)))); + -- Elaborates only non-elaborated packages. + Start_Association (Constr, Info.Package_Elab_Body_Subprg); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + end Elab_Dependence_Package; + + procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) + is + Info : constant Ortho_Info_Acc := Get_Info (Pkg); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Package_Instance_Elab_Subprg); + New_Procedure_Call (Constr); + end Elab_Dependence_Package_Instantiation; + + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) + is + Depend_List: Iir_Design_Unit_List; + Design: Iir; + Library_Unit: Iir; + 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_Design_Unit then + Library_Unit := Get_Library_Unit (Design); + case Get_Kind (Library_Unit) is + when Iir_Kind_Package_Declaration => + Elab_Dependence_Package (Library_Unit); + when Iir_Kind_Package_Instantiation_Declaration => + Elab_Dependence_Package_Instantiation (Library_Unit); + when Iir_Kind_Entity_Declaration => + -- FIXME: architecture already elaborates its entity. + null; + when Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_Package_Body => + -- A package instantiation depends on the body. + null; + when others => + Error_Kind ("elab_dependence", Library_Unit); + end case; + end if; + end loop; + end Elab_Dependence; + + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode) is + begin + Predeclare_Scope_Type (Scope, Create_Identifier ("INSTTYPE")); + Declare_Scope_Acc + (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type); + end Declare_Inst_Type_And_Ptr; + + procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack) is + begin + Prev := Current_Subprg_Instance; + Current_Subprg_Instance := Null_Subprg_Instance_Stack; + end Clear_Subprg_Instance; + + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + Prev : out Subprg_Instance_Stack) + is + begin + Prev := Current_Subprg_Instance; + Current_Subprg_Instance := (Scope => Scope, + Ptr_Type => Ptr_Type, + Ident => Ident); + end Push_Subprg_Instance; + + function Has_Current_Subprg_Instance return Boolean is + begin + return Current_Subprg_Instance.Ptr_Type /= O_Tnode_Null; + end Has_Current_Subprg_Instance; + + procedure Pop_Subprg_Instance (Ident : O_Ident; + Prev : Subprg_Instance_Stack) + is + begin + if Is_Equal (Current_Subprg_Instance.Ident, Ident) then + Current_Subprg_Instance := Prev; + else + -- POP does not match with a push. + raise Internal_Error; + end if; + end Pop_Subprg_Instance; + + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type) + is + begin + if Has_Current_Subprg_Instance then + Vars.Scope := Current_Subprg_Instance.Scope; + Vars.Inter_Type := Current_Subprg_Instance.Ptr_Type; + New_Interface_Decl + (Interfaces, Vars.Inter, + Current_Subprg_Instance.Ident, + Current_Subprg_Instance.Ptr_Type); + else + Vars := Null_Subprg_Instance; + end if; + end Add_Subprg_Instance_Interfaces; + + procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is + begin + if Has_Current_Subprg_Instance then + Field := Add_Instance_Factory_Field + (Current_Subprg_Instance.Ident, + Current_Subprg_Instance.Ptr_Type); + else + Field := O_Fnode_Null; + end if; + end Add_Subprg_Instance_Field; + + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean is + begin + return Vars.Inter /= O_Dnode_Null; + end Has_Subprg_Instance; + + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode is + begin + pragma Assert (Has_Subprg_Instance (Vars)); + return New_Address (Get_Instance_Ref (Vars.Scope.all), + Vars.Inter_Type); + end Get_Subprg_Instance; + + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + New_Association (Assocs, Get_Subprg_Instance (Vars)); + end if; + end Add_Subprg_Instance_Assoc; + + procedure Set_Subprg_Instance_Field + (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type) + is + begin + if Has_Subprg_Instance (Vars) then + New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field), + New_Obj_Value (Vars.Inter)); + end if; + end Set_Subprg_Instance_Field; + + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + Set_Scope_Via_Param_Ptr (Vars.Scope.all, Vars.Inter); + end if; + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + Clear_Scope (Vars.Scope.all); + end if; + end Finish_Subprg_Instance_Use; + + procedure Start_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode) is + begin + if Field /= O_Fnode_Null then + Set_Scope_Via_Field_Ptr (Prev.Scope.all, Field, + Current_Subprg_Instance.Scope); + end if; + end Start_Prev_Subprg_Instance_Use_Via_Field; + + procedure Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode) is + begin + if Field /= O_Fnode_Null then + Clear_Scope (Prev.Scope.all); + end if; + end Finish_Prev_Subprg_Instance_Use_Via_Field; + + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir) + is + begin + Add_Subprg_Instance_Interfaces + (Interfaces, Get_Info (Subprg).Subprg_Instance); + end Create_Subprg_Instance; + + procedure Start_Subprg_Instance_Use (Subprg : Iir) is + begin + Start_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Subprg : Iir) is + begin + Finish_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Finish_Subprg_Instance_Use; + + function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) + return Subprg_Instance_Type is + begin + return Subprg_Instance_Type' + (Inter => Inst.Inter, + Inter_Type => Inst.Inter_Type, + Scope => Instantiated_Var_Scope (Inst.Scope)); + end Instantiate_Subprg_Instance; + end Chap2; + + package body Chap3 is + function Create_Static_Type_Definition_Type_Range (Def : Iir) + return O_Cnode; + procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode); + + -- For scalar subtypes: creates info from the base type. + procedure Create_Subtype_Info_From_Type (Def : Iir; + Subtype_Info : Type_Info_Acc; + Base_Info : Type_Info_Acc); + + -- Finish a type definition: declare the type, define and declare a + -- pointer to the type. + procedure Finish_Type_Definition + (Info : Type_Info_Acc; Completion : Boolean := False) + is + begin + -- Declare the type. + if not Completion then + New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); + end if; + + -- Create an access to the type and declare it. + Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Info.Ortho_Ptr_Type (Mode_Value)); + + -- Signal type. + if Info.Type_Mode in Type_Mode_Scalar then + Info.Ortho_Type (Mode_Signal) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + end if; + if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then + New_Type_Decl (Create_Identifier ("SIG"), + Info.Ortho_Type (Mode_Signal)); + end if; + + -- Signal pointer type. + if Info.Type_Mode in Type_Mode_Composite + and then Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null + then + Info.Ortho_Ptr_Type (Mode_Signal) := + New_Access_Type (Info.Ortho_Type (Mode_Signal)); + New_Type_Decl (Create_Identifier ("SIGPTR"), + Info.Ortho_Ptr_Type (Mode_Signal)); + else + Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; + end if; + end Finish_Type_Definition; + + procedure Create_Size_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + begin + Info.C := new Complex_Type_Arr_Info; + Info.C (Mode_Value).Size_Var := Create_Var + (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); + if Get_Has_Signal_Flag (Def) then + Info.C (Mode_Signal).Size_Var := Create_Var + (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); + end if; + end Create_Size_Var; + + -- A builder set internal fields of object pointed by BASE_PTR, using + -- memory from BASE_PTR and returns a pointer to the next memory byte + -- to be used. + procedure Create_Builder_Subprogram_Decl (Info : Type_Info_Acc; + Name : Name_Id; + Kind : Object_Kind_Type) + is + Interface_List : O_Inter_List; + Ident : O_Ident; + Ptype : O_Tnode; + begin + case Kind is + when Mode_Value => + Ident := Create_Identifier (Name, "_BUILDER"); + when Mode_Signal => + Ident := Create_Identifier (Name, "_SIGBUILDER"); + end case; + -- FIXME: return the same type as its first parameter ??? + Start_Function_Decl + (Interface_List, Ident, Global_Storage, Ghdl_Index_Type); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.C (Kind).Builder_Instance); + case Info.Type_Mode is + when Type_Mode_Fat_Array => + Ptype := Info.T.Base_Ptr_Type (Kind); + when Type_Mode_Record => + Ptype := Info.Ortho_Ptr_Type (Kind); + when others => + raise Internal_Error; + end case; + New_Interface_Decl + (Interface_List, Info.C (Kind).Builder_Base_Param, + Get_Identifier ("base_ptr"), Ptype); + -- Add parameter for array bounds. + if Info.Type_Mode = Type_Mode_Fat_Array then + New_Interface_Decl + (Interface_List, Info.C (Kind).Builder_Bound_Param, + Get_Identifier ("bound"), Info.T.Bounds_Ptr_Type); + end if; + Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func); + end Create_Builder_Subprogram_Decl; + + function Gen_Call_Type_Builder (Var_Ptr : O_Dnode; + Var_Type : Iir; + Kind : Object_Kind_Type) + return O_Enode + is + Tinfo : constant Type_Info_Acc := Get_Info (Var_Type); + Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type)); + Assoc : O_Assoc_List; + begin + -- Build the field + Start_Association (Assoc, Binfo.C (Kind).Builder_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assoc, Binfo.C (Kind).Builder_Instance); + + case Tinfo.Type_Mode is + when Type_Mode_Record + | Type_Mode_Array => + New_Association (Assoc, New_Obj_Value (Var_Ptr)); + when Type_Mode_Fat_Array => + -- Note: a fat array can only be at the top of a complex type; + -- the bounds must have been set. + New_Association + (Assoc, New_Value_Selected_Acc_Value + (New_Obj (Var_Ptr), Tinfo.T.Base_Field (Kind))); + when others => + raise Internal_Error; + end case; + + if Tinfo.Type_Mode in Type_Mode_Arrays then + declare + Arr : Mnode; + begin + case Type_Mode_Arrays (Tinfo.Type_Mode) is + when Type_Mode_Array => + Arr := T2M (Var_Type, Kind); + when Type_Mode_Fat_Array => + Arr := Dp2M (Var_Ptr, Tinfo, Kind); + end case; + New_Association + (Assoc, M2Addr (Chap3.Get_Array_Bounds (Arr))); + end; + end if; + + return New_Function_Call (Assoc); + end Gen_Call_Type_Builder; + + procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) + is + Mem : O_Dnode; + V : Mnode; + begin + Open_Temp; + V := Stabilize (Var); + Mem := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Mem), + Gen_Call_Type_Builder (M2Dp (V), Var_Type, Get_Object_Kind (Var))); + Close_Temp; + end Gen_Call_Type_Builder; + + ------------------ + -- Enumeration -- + ------------------ + + function Translate_Enumeration_Literal (Lit : Iir_Enumeration_Literal) + return O_Ident + is + El_Str : String (1 .. 4); + Id : Name_Id; + N : Integer; + C : Character; + begin + Id := Get_Identifier (Lit); + if Name_Table.Is_Character (Id) then + C := Name_Table.Get_Character (Id); + El_Str (1) := 'C'; + case C is + when 'A' .. 'Z' + | 'a' .. 'z' + | '0' .. '9' => + El_Str (2) := '_'; + El_Str (3) := C; + when others => + N := Character'Pos (Name_Table.Get_Character (Id)); + El_Str (2) := N2hex (N / 16); + El_Str (3) := N2hex (N mod 16); + end case; + return Get_Identifier (El_Str (1 .. 3)); + else + return Create_Identifier_Without_Prefix (Lit); + end if; + end Translate_Enumeration_Literal; + + procedure Translate_Enumeration_Type + (Def : Iir_Enumeration_Type_Definition) + is + El_List : Iir_List; + El : Iir_Enumeration_Literal; + Constr : O_Enum_List; + Lit_Name : O_Ident; + Val : O_Cnode; + Info : Type_Info_Acc; + Nbr : Natural; + Size : Natural; + begin + El_List := Get_Enumeration_Literal_List (Def); + Nbr := Get_Nbr_Elements (El_List); + if Nbr <= 256 then + Size := 8; + else + Size := 32; + end if; + Start_Enum_Type (Constr, Size); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + + Lit_Name := Translate_Enumeration_Literal (El); + New_Enum_Literal (Constr, Lit_Name, Val); + Set_Ortho_Expr (El, Val); + end loop; + Info := Get_Info (Def); + Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value)); + if Nbr <= 256 then + Info.Type_Mode := Type_Mode_E8; + else + Info.Type_Mode := Type_Mode_E32; + end if; + -- Enumerations are always in their range. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + Finish_Type_Definition (Info); + end Translate_Enumeration_Type; + + procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition) + is + Info : Type_Info_Acc; + El_List : Iir_List; + True_Lit, False_Lit : Iir_Enumeration_Literal; + False_Node, True_Node : O_Cnode; + begin + Info := Get_Info (Def); + El_List := Get_Enumeration_Literal_List (Def); + if Get_Nbr_Elements (El_List) /= 2 then + raise Internal_Error; + end if; + False_Lit := Get_Nth_Element (El_List, 0); + True_Lit := Get_Nth_Element (El_List, 1); + New_Boolean_Type + (Info.Ortho_Type (Mode_Value), + Translate_Enumeration_Literal (False_Lit), False_Node, + Translate_Enumeration_Literal (True_Lit), True_Node); + Info.Type_Mode := Type_Mode_B1; + Set_Ortho_Expr (False_Lit, False_Node); + Set_Ortho_Expr (True_Lit, True_Node); + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + Finish_Type_Definition (Info); + end Translate_Bool_Type; + + --------------- + -- Integer -- + --------------- + + -- Return the number of bits (32 or 64) required to represent the + -- (integer or physical) type definition DEF. + type Type_Precision is (Precision_32, Precision_64); + function Get_Type_Precision (Def : Iir) return Type_Precision + is + St : Iir; + L, H : Iir; + Lv, Hv : Iir_Int64; + begin + St := Get_Subtype_Definition (Get_Type_Declarator (Def)); + Get_Low_High_Limit (Get_Range_Constraint (St), L, H); + Lv := Get_Value (L); + Hv := Get_Value (H); + if Lv >= -(2 ** 31) and then Hv <= (2 ** 31 - 1) then + return Precision_32; + else + if Flag_Only_32b then + Error_Msg_Sem + ("range of " & Disp_Node (Get_Type_Declarator (St)) + & " is too large", St); + return Precision_32; + end if; + return Precision_64; + end if; + end Get_Type_Precision; + + procedure Translate_Integer_Type + (Def : Iir_Integer_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + case Get_Type_Precision (Def) is + when Precision_32 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); + Info.Type_Mode := Type_Mode_I32; + when Precision_64 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); + Info.Type_Mode := Type_Mode_I64; + end case; + -- Integers are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Integer_Type; + + ---------------------- + -- Floating types -- + ---------------------- + + procedure Translate_Floating_Type (Def : Iir_Floating_Type_Definition) + is + Info : Type_Info_Acc; + begin + -- FIXME: should check precision + Info := Get_Info (Def); + Info.Type_Mode := Type_Mode_F64; + Info.Ortho_Type (Mode_Value) := New_Float_Type; + -- Reals are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Floating_Type; + + ---------------- + -- Physical -- + ---------------- + + procedure Translate_Physical_Type (Def : Iir_Physical_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + case Get_Type_Precision (Def) is + when Precision_32 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); + Info.Type_Mode := Type_Mode_P32; + when Precision_64 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); + Info.Type_Mode := Type_Mode_P64; + end case; + -- Phyiscals are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Physical_Type; + + procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition) + is + Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value); + Unit : Iir; + Info : Object_Info_Acc; + begin + Unit := Get_Unit_Chain (Def); + while Unit /= Null_Iir loop + Info := Add_Info (Unit, Kind_Object); + Info.Object_Var := + Create_Var (Create_Var_Identifier (Unit), Phy_Type); + Unit := Get_Chain (Unit); + end loop; + end Translate_Physical_Units; + + ------------ + -- File -- + ------------ + + procedure Translate_File_Type (Def : Iir_File_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type; + Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type; + Info.Type_Mode := Type_Mode_File; + end Translate_File_Type; + + 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 (Type_Mode_Scalar) of Character + := "beEiIpPF"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_Definition => + Res (Off) := Scalar_Map (Get_Info (Def).Type_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 Create_File_Type_Var (Def : Iir_File_Type_Definition) + is + Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); + Info : Type_Info_Acc; + begin + if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition then + return; + end if; + declare + Len : constant Natural := Get_File_Signature_Length (Type_Name); + Sig : String (1 .. Len + 2); + Off : Natural := Sig'First; + begin + Get_File_Signature (Type_Name, Sig, Off); + Sig (Len + 1) := '.'; + Sig (Len + 2) := Character'Val (10); + Info := Get_Info (Def); + Info.T.File_Signature := Create_String + (Sig, Create_Identifier ("FILESIG"), Global_Storage); + end; + end Create_File_Type_Var; + + ------------- + -- Array -- + ------------- + + function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is + begin + if Get_Has_Signal_Flag (Def) then + return Mode_Signal; + else + return Mode_Value; + end if; + end Type_To_Last_Object_Kind; + + procedure Create_Array_Fat_Pointer + (Info : Type_Info_Acc; Kind : Object_Kind_Type) + is + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field + (Constr, Info.T.Base_Field (Kind), Get_Identifier ("BASE"), + Info.T.Base_Ptr_Type (Kind)); + New_Record_Field + (Constr, Info.T.Bounds_Field (Kind), Get_Identifier ("BOUNDS"), + Info.T.Bounds_Ptr_Type); + Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); + end Create_Array_Fat_Pointer; + + procedure Translate_Incomplete_Array_Type + (Def : Iir_Array_Type_Definition) + is + Arr_Info : Incomplete_Type_Info_Acc; + Info : Type_Info_Acc; + begin + Arr_Info := Get_Info (Def); + if Arr_Info.Incomplete_Array /= null then + -- This (incomplete) array type was already translated. + -- This is the case for a second access type definition to this + -- still incomplete array type. + return; + end if; + Info := new Ortho_Info_Type (Kind_Type); + Info.Type_Mode := Type_Mode_Fat_Array; + Info.Type_Incomplete := True; + Arr_Info.Incomplete_Array := Info; + + Info.T := Ortho_Info_Type_Array_Init; + Info.T.Bounds_Type := O_Tnode_Null; + + Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUNDP"), + Info.T.Bounds_Ptr_Type); + + Info.T.Base_Ptr_Type (Mode_Value) := New_Access_Type (O_Tnode_Null); + New_Type_Decl (Create_Identifier ("BASEP"), + Info.T.Base_Ptr_Type (Mode_Value)); + + Create_Array_Fat_Pointer (Info, Mode_Value); + + New_Type_Decl + (Create_Identifier, Info.Ortho_Type (Mode_Value)); + end Translate_Incomplete_Array_Type; + + -- Declare the bounds types for DEF. + procedure Translate_Array_Type_Bounds + (Def : Iir_Array_Type_Definition; + Info : Type_Info_Acc; + Complete : Boolean) + is + Indexes_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Def); + Constr : O_Element_List; + Dim : String (1 .. 8); + N : Natural; + P : Natural; + Index : Iir; + Index_Info : Index_Info_Acc; + Index_Type_Mark : Iir; + begin + Start_Record_Type (Constr); + for I in Natural loop + Index_Type_Mark := Get_Nth_Element (Indexes_List, I); + exit when Index_Type_Mark = Null_Iir; + Index := Get_Index_Type (Index_Type_Mark); + + -- Index comes from a type mark. + pragma Assert (not Is_Anonymous_Type_Definition (Index)); + + Index_Info := Add_Info (Index_Type_Mark, Kind_Index); + + -- Build the name + N := I + 1; + P := Dim'Last; + loop + Dim (P) := Character'Val (Character'Pos ('0') + N mod 10); + P := P - 1; + N := N / 10; + exit when N = 0; + end loop; + P := P - 3; + Dim (P .. P + 3) := "dim_"; + + New_Record_Field (Constr, Index_Info.Index_Field, + Get_Identifier (Dim (P .. Dim'Last)), + Get_Info (Get_Base_Type (Index)).T.Range_Type); + end loop; + Finish_Record_Type (Constr, Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUND"), + Info.T.Bounds_Type); + if Complete then + Finish_Access_Type (Info.T.Bounds_Ptr_Type, Info.T.Bounds_Type); + else + Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUNDP"), + Info.T.Bounds_Ptr_Type); + end if; + end Translate_Array_Type_Bounds; + + procedure Translate_Array_Type_Base + (Def : Iir_Array_Type_Definition; + Info : Type_Info_Acc; + Complete : Boolean) + is + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Id, Idptr : O_Ident; + begin + El_Type := Get_Element_Subtype (Def); + Translate_Type_Definition (El_Type, True); + El_Tinfo := Get_Info (El_Type); + + if Is_Complex_Type (El_Tinfo) then + if El_Tinfo.Type_Mode = Type_Mode_Array then + Info.T.Base_Type := El_Tinfo.T.Base_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.T.Base_Ptr_Type; + else + Info.T.Base_Type := El_Tinfo.Ortho_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type; + end if; + else + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + case Kind is + when Mode_Value => + -- For the values. + Id := Create_Identifier ("BASE"); + if not Complete then + Idptr := Create_Identifier ("BASEP"); + else + Idptr := O_Ident_Nul; + end if; + when Mode_Signal => + -- For the signals + Id := Create_Identifier ("SIGBASE"); + Idptr := Create_Identifier ("SIGBASEP"); + end case; + Info.T.Base_Type (Kind) := + New_Array_Type (El_Tinfo.Ortho_Type (Kind), + Ghdl_Index_Type); + New_Type_Decl (Id, Info.T.Base_Type (Kind)); + if Is_Equal (Idptr, O_Ident_Nul) then + Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), + Info.T.Base_Type (Kind)); + else + Info.T.Base_Ptr_Type (Kind) := + New_Access_Type (Info.T.Base_Type (Kind)); + New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); + end if; + end loop; + end if; + end Translate_Array_Type_Base; + + -- For unidimensional arrays: create a constant bounds whose length + -- is 1, for concatenation with element. + procedure Translate_Static_Unidimensional_Array_Length_One + (Def : Iir_Array_Type_Definition) + is + Indexes : constant Iir_List := Get_Index_Subtype_List (Def); + Index_Type : Iir; + Index_Base_Type : Iir; + Constr : O_Record_Aggr_List; + Constr1 : O_Record_Aggr_List; + Arr_Info : Type_Info_Acc; + Tinfo : Type_Info_Acc; + Irange : Iir; + Res1 : O_Cnode; + Res : O_Cnode; + begin + if Get_Nbr_Elements (Indexes) /= 1 then + -- Not a one-dimensional array. + return; + end if; + Index_Type := Get_Index_Type (Indexes, 0); + Arr_Info := Get_Info (Def); + if Get_Type_Staticness (Index_Type) = Locally then + if Global_Storage /= O_Storage_External then + Index_Base_Type := Get_Base_Type (Index_Type); + Tinfo := Get_Info (Index_Base_Type); + Irange := Get_Range_Constraint (Index_Type); + Start_Record_Aggr (Constr, Arr_Info.T.Bounds_Type); + Start_Record_Aggr (Constr1, Tinfo.T.Range_Type); + New_Record_Aggr_El + (Constr1, + Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); + New_Record_Aggr_El + (Constr1, + Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); + New_Record_Aggr_El + (Constr1, Chap7.Translate_Static_Range_Dir (Irange)); + New_Record_Aggr_El + (Constr1, Ghdl_Index_1); + Finish_Record_Aggr (Constr1, Res1); + New_Record_Aggr_El (Constr, Res1); + Finish_Record_Aggr (Constr, Res); + else + Res := O_Cnode_Null; + end if; + Arr_Info.T.Array_1bound := Create_Global_Const + (Create_Identifier ("BR1"), + Arr_Info.T.Bounds_Type, Global_Storage, Res); + else + Arr_Info.T.Array_1bound := Create_Var + (Create_Var_Identifier ("BR1"), + Arr_Info.T.Bounds_Type, Global_Storage); + end if; + end Translate_Static_Unidimensional_Array_Length_One; + + procedure Translate_Dynamic_Unidimensional_Array_Length_One + (Def : Iir_Array_Type_Definition) + is + Indexes : constant Iir_List := Get_Index_Subtype_List (Def); + Index_Type : Iir; + Arr_Info : Type_Info_Acc; + Bound1, Rng : Mnode; + begin + if Get_Nbr_Elements (Indexes) /= 1 then + return; + end if; + Index_Type := Get_Index_Type (Indexes, 0); + if Get_Type_Staticness (Index_Type) = Locally then + return; + end if; + Arr_Info := Get_Info (Def); + Open_Temp; + Bound1 := Varv2M (Arr_Info.T.Array_1bound, Arr_Info, Mode_Value, + Arr_Info.T.Bounds_Type, Arr_Info.T.Bounds_Ptr_Type); + Bound1 := Bounds_To_Range (Bound1, Def, 1); + Stabilize (Bound1); + Rng := Type_To_Range (Index_Type); + Stabilize (Rng); + New_Assign_Stmt (M2Lv (Range_To_Dir (Bound1)), + M2E (Range_To_Dir (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Left (Bound1)), + M2E (Range_To_Left (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Bound1)), + M2E (Range_To_Left (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Length (Bound1)), + New_Lit (Ghdl_Index_1)); + Close_Temp; + end Translate_Dynamic_Unidimensional_Array_Length_One; + + procedure Translate_Array_Type_Definition + (Def : Iir_Array_Type_Definition) + is + Info : constant Type_Info_Acc := Get_Info (Def); + -- If true, INFO was already partially filled, by a previous access + -- type definition to this incomplete array type. + Completion : constant Boolean := Info.Type_Mode = Type_Mode_Fat_Array; + El_Tinfo : Type_Info_Acc; + begin + if not Completion then + Info.Type_Mode := Type_Mode_Fat_Array; + Info.T := Ortho_Info_Type_Array_Init; + end if; + Translate_Array_Type_Base (Def, Info, Completion); + Translate_Array_Type_Bounds (Def, Info, Completion); + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + if not Completion then + Create_Array_Fat_Pointer (Info, Mode_Value); + end if; + if Get_Has_Signal_Flag (Def) then + Create_Array_Fat_Pointer (Info, Mode_Signal); + end if; + Finish_Type_Definition (Info, Completion); + + Translate_Static_Unidimensional_Array_Length_One (Def); + + El_Tinfo := Get_Info (Get_Element_Subtype (Def)); + if Is_Complex_Type (El_Tinfo) then + -- This is a complex type. + Info.C := new Complex_Type_Arr_Info; + -- No size variable for unconstrained array type. + for Mode in Object_Kind_Type loop + Info.C (Mode).Size_Var := Null_Var; + Info.C (Mode).Builder_Need_Func := + El_Tinfo.C (Mode).Builder_Need_Func; + end loop; + end if; + Info.Type_Incomplete := False; + end Translate_Array_Type_Definition; + + -- Get the length of DEF, ie the number of elements. + -- If the length is not statically defined, returns -1. + function Get_Array_Subtype_Length (Def : Iir_Array_Subtype_Definition) + return Iir_Int64 + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Index : Iir; + Len : Iir_Int64; + begin + -- Check if the bounds of the array are locally static. + Len := 1; + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + + if Get_Type_Staticness (Index) /= Locally then + return -1; + end if; + Len := Len * Eval_Discrete_Type_Length (Index); + end loop; + return Len; + end Get_Array_Subtype_Length; + + procedure Translate_Array_Subtype_Definition + (Def : Iir_Array_Subtype_Definition) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Type : constant Iir := Get_Base_Type (Def); + Binfo : constant Type_Info_Acc := Get_Info (Base_Type); + + Len : Iir_Int64; + + Id : O_Ident; + begin + -- Note: info of indexes subtype are not created! + + Len := Get_Array_Subtype_Length (Def); + Info.Type_Mode := Type_Mode_Array; + Info.Type_Locally_Constrained := (Len >= 0); + if Is_Complex_Type (Binfo) + or else not Info.Type_Locally_Constrained + then + -- This is a complex type as the size is not known at compile + -- time. + Info.Ortho_Type := Binfo.T.Base_Ptr_Type; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + + Create_Size_Var (Def); + + for Mode in Object_Kind_Type loop + Info.C (Mode).Builder_Need_Func := + Is_Complex_Type (Binfo) + and then Binfo.C (Mode).Builder_Need_Func; + end loop; + else + -- Length is known. Create a constrained array. + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + case I is + when Mode_Value => + Id := Create_Identifier; + when Mode_Signal => + Id := Create_Identifier ("SIG"); + end case; + Info.Ortho_Type (I) := New_Constrained_Array_Type + (Binfo.T.Base_Type (I), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + New_Type_Decl (Id, Info.Ortho_Type (I)); + end loop; + end if; + end Translate_Array_Subtype_Definition; + + procedure Translate_Array_Subtype_Element_Subtype + (Def : Iir_Array_Subtype_Definition) + is + El_Type : constant Iir := Get_Element_Subtype (Def); + Type_Mark : constant Iir := Get_Denoted_Type_Mark (Def); + Tm_El_Type : Iir; + begin + if Type_Mark = Null_Iir then + -- Array subtype for constained array definition. Same element + -- subtype as the base type. + return; + end if; + + Tm_El_Type := Get_Element_Subtype (Type_Mark); + if El_Type = Tm_El_Type then + -- Same element subtype as the type mark. + return; + end if; + + case Get_Kind (El_Type) is + when Iir_Kinds_Scalar_Subtype_Definition => + declare + El_Info : Ortho_Info_Acc; + begin + El_Info := Add_Info (El_Type, Kind_Type); + Create_Subtype_Info_From_Type + (El_Type, El_Info, Get_Info (Tm_El_Type)); + end; + when others => + Error_Kind ("translate_array_subtype_element_subtype", El_Type); + end case; + end Translate_Array_Subtype_Element_Subtype; + + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Baseinfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def)); + Index : Iir; + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Start_Record_Aggr (List, Baseinfo.T.Bounds_Type); + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + New_Record_Aggr_El + (List, Create_Static_Type_Definition_Type_Range (Index)); + end loop; + Finish_Record_Aggr (List, Res); + return Res; + end Create_Static_Array_Subtype_Bounds; + + procedure Create_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition; Target : O_Lnode) + is + Base_Type : constant Iir := Get_Base_Type (Def); + Baseinfo : constant Type_Info_Acc := Get_Info (Base_Type); + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Indexes_Def_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Base_Type); + Index : Iir; + Targ : Mnode; + begin + Targ := Lv2M (Target, True, + Baseinfo.T.Bounds_Type, + Baseinfo.T.Bounds_Ptr_Type, + null, Mode_Value); + Open_Temp; + if Get_Nbr_Elements (Indexes_List) > 1 then + Targ := Stabilize (Targ); + end if; + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + declare + Index_Type : constant Iir := Get_Base_Type (Index); + Index_Info : constant Type_Info_Acc := Get_Info (Index_Type); + Base_Index_Info : constant Index_Info_Acc := + Get_Info (Get_Nth_Element (Indexes_Def_List, I)); + D : O_Dnode; + begin + Open_Temp; + D := Create_Temp_Ptr + (Index_Info.T.Range_Ptr_Type, + New_Selected_Element (M2Lv (Targ), + Base_Index_Info.Index_Field)); + Chap7.Translate_Discrete_Range_Ptr (D, Index); + Close_Temp; + end; + end loop; + Close_Temp; + end Create_Array_Subtype_Bounds; + + -- Get staticness of the array bounds. + function Get_Array_Bounds_Staticness (Def : Iir) return Iir_Staticness + is + List : constant Iir_List := Get_Index_Subtype_List (Def); + Idx_Type : Iir; + begin + for I in Natural loop + Idx_Type := Get_Index_Type (List, I); + exit when Idx_Type = Null_Iir; + if Get_Type_Staticness (Idx_Type) /= Locally then + return Globally; + end if; + end loop; + return Locally; + end Get_Array_Bounds_Staticness; + + -- Create a variable containing the bounds for array subtype DEF. + procedure Create_Array_Subtype_Bounds_Var + (Def : Iir; Elab_Now : Boolean) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Info : Type_Info_Acc; + Val : O_Cnode; + begin + if Info.T.Array_Bounds /= Null_Var then + return; + end if; + Base_Info := Get_Info (Get_Base_Type (Def)); + case Get_Array_Bounds_Staticness (Def) is + when None + | Globally => + Info.T.Static_Bounds := False; + Info.T.Array_Bounds := Create_Var + (Create_Var_Identifier ("STB"), Base_Info.T.Bounds_Type); + if Elab_Now then + Create_Array_Subtype_Bounds + (Def, Get_Var (Info.T.Array_Bounds)); + end if; + when Locally => + Info.T.Static_Bounds := True; + if Global_Storage = O_Storage_External then + -- Do not create the value of the type desc, since it + -- is never dereferenced in a static type desc. + Val := O_Cnode_Null; + else + Val := Create_Static_Array_Subtype_Bounds (Def); + end if; + Info.T.Array_Bounds := Create_Global_Const + (Create_Identifier ("STB"), + Base_Info.T.Bounds_Type, Global_Storage, Val); + + when Unknown => + raise Internal_Error; + end case; + end Create_Array_Subtype_Bounds_Var; + + procedure Create_Array_Type_Builder + (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; + Bound : constant O_Dnode := Info.C (Kind).Builder_Bound_Param; + Var_Off : O_Dnode; + Var_Mem : O_Dnode; + Var_Length : O_Dnode; + El_Type : Iir; + El_Info : Type_Info_Acc; + Label : O_Snode; + begin + Start_Subprogram_Body (Info.C (Kind).Builder_Func); + Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + + -- Compute length of the array. + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local, + Info.T.Base_Ptr_Type (Kind)); + New_Var_Decl (Var_Off, Get_Identifier ("off"), O_Storage_Local, + Ghdl_Index_Type); + + El_Type := Get_Element_Subtype (Def); + El_Info := Get_Info (El_Type); + + New_Assign_Stmt + (New_Obj (Var_Length), + New_Dyadic_Op (ON_Mul_Ov, + New_Value (Get_Var (El_Info.C (Kind).Size_Var)), + Get_Bounds_Length (Dp2M (Bound, Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type), + Def))); + + -- Find the innermost non-array element. + while El_Info.Type_Mode = Type_Mode_Array loop + El_Type := Get_Element_Subtype (El_Type); + El_Info := Get_Info (El_Type); + end loop; + + -- Set each index of the array. + Init_Var (Var_Off); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Off), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + + New_Assign_Stmt + (New_Obj (Var_Mem), + New_Unchecked_Address + (New_Slice (New_Access_Element + (New_Convert_Ov (New_Obj_Value (Base), + Char_Ptr_Type)), + Chararray_Type, + New_Obj_Value (Var_Off)), + Info.T.Base_Ptr_Type (Kind))); + + New_Assign_Stmt + (New_Obj (Var_Off), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Off), + Gen_Call_Type_Builder (Var_Mem, El_Type, Kind))); + Finish_Loop_Stmt (Label); + + New_Return_Stmt (New_Obj_Value (Var_Off)); + + Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Finish_Subprogram_Body; + end Create_Array_Type_Builder; + + -------------- + -- record -- + -------------- + + -- Get the alignment mask for *ortho* type ATYPE. + function Get_Type_Alignmask (Atype : O_Tnode) return O_Enode is + begin + return New_Dyadic_Op + (ON_Sub_Ov, + New_Lit (New_Alignof (Atype, Ghdl_Index_Type)), + New_Lit (Ghdl_Index_1)); + end Get_Type_Alignmask; + + -- Get the alignment mask for type INFO (Mode_Value). + function Get_Type_Alignmask (Info : Type_Info_Acc) return O_Enode is + begin + if Is_Complex_Type (Info) then + if Info.Type_Mode /= Type_Mode_Record then + raise Internal_Error; + end if; + return New_Value (Get_Var (Info.C (Mode_Value).Align_Var)); + else + return Get_Type_Alignmask (Info.Ortho_Type (Mode_Value)); + end if; + end Get_Type_Alignmask; + + -- Align VALUE (of unsigned type) for type ATYPE. + -- The formulae is: (V + (A - 1)) and not (A - 1), where A is the + -- alignment for ATYPE in bytes. + function Realign (Value : O_Enode; Atype : Iir) return O_Enode + is + Tinfo : constant Type_Info_Acc := Get_Info (Atype); + begin + return New_Dyadic_Op + (ON_And, + New_Dyadic_Op (ON_Add_Ov, Value, Get_Type_Alignmask (Tinfo)), + New_Monadic_Op (ON_Not, Get_Type_Alignmask (Tinfo))); + end Realign; + + function Realign (Value : O_Enode; Mask : O_Dnode) return O_Enode is + begin + return New_Dyadic_Op + (ON_And, + New_Dyadic_Op (ON_Add_Ov, Value, New_Obj_Value (Mask)), + New_Monadic_Op (ON_Not, New_Obj_Value (Mask))); + end Realign; + + -- Find the innermost non-array element. + function Get_Innermost_Non_Array_Element (Atype : Iir) return Iir + is + Res : Iir := Atype; + begin + while Get_Kind (Res) in Iir_Kinds_Array_Type_Definition loop + Res := Get_Element_Subtype (Res); + end loop; + return Res; + end Get_Innermost_Non_Array_Element; + + procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) + is + El_List : O_Element_List; + List : Iir_List; + El : Iir_Element_Declaration; + Info : Type_Info_Acc; + Field_Info : Ortho_Info_Acc; + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + El_Tnode : O_Tnode; + + -- True if a size variable will be created since the size of + -- the record is not known at compile-time. + Need_Size : Boolean; + + Mark : Id_Mark_Type; + begin + Info := Get_Info (Def); + Need_Size := False; + List := Get_Elements_Declaration_List (Def); + + -- First, translate the anonymous type of the elements. + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + if Get_Info (El_Type) = null then + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + Translate_Type_Definition (El_Type); + Pop_Identifier_Prefix (Mark); + end if; + if not Need_Size and then Is_Complex_Type (Get_Info (El_Type)) then + Need_Size := True; + end if; + Field_Info := Add_Info (El, Kind_Field); + end loop; + + -- Then create the record type. + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Start_Record_Type (El_List); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Field_Info := Get_Info (El); + El_Tinfo := Get_Info (Get_Type (El)); + if Is_Complex_Type (El_Tinfo) then + -- Always use an offset for a complex type. + El_Tnode := Ghdl_Index_Type; + else + El_Tnode := El_Tinfo.Ortho_Type (Kind); + end if; + + New_Record_Field (El_List, Field_Info.Field_Node (Kind), + Create_Identifier_Without_Prefix (El), + El_Tnode); + end loop; + Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); + end loop; + Info.Type_Mode := Type_Mode_Record; + Finish_Type_Definition (Info); + + if Need_Size then + Create_Size_Var (Def); + Info.C (Mode_Value).Align_Var := Create_Var + (Create_Var_Identifier ("ALIGNMSK"), Ghdl_Index_Type); + Info.C (Mode_Value).Builder_Need_Func := True; + Info.C (Mode_Signal).Builder_Need_Func := True; + end if; + end Translate_Record_Type; + + procedure Create_Record_Type_Builder + (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; + List : Iir_List; + El : Iir_Element_Declaration; + + Off_Var : O_Dnode; + Ptr_Var : O_Dnode; + Off_Val : O_Enode; + El_Type : Iir; + Inner_Type : Iir; + El_Tinfo : Type_Info_Acc; + begin + Start_Subprogram_Body (Info.C (Kind).Builder_Func); + Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + + New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local, + Ghdl_Index_Type); + + -- Reserve memory for the record, ie: + -- OFF = SIZEOF (record). + New_Assign_Stmt + (New_Obj (Off_Var), + New_Lit (New_Sizeof (Info.Ortho_Type (Kind), + Ghdl_Index_Type))); + + -- Set memory for each complex element. + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + El_Tinfo := Get_Info (El_Type); + if Is_Complex_Type (El_Tinfo) then + -- Complex type. + + -- Align on the innermost array element (which should be + -- a record) for Mode_Value. No need to align for signals, + -- as all non-composite elements are accesses. + Inner_Type := Get_Innermost_Non_Array_Element (El_Type); + Off_Val := New_Obj_Value (Off_Var); + if Kind = Mode_Value then + Off_Val := Realign (Off_Val, Inner_Type); + end if; + New_Assign_Stmt (New_Obj (Off_Var), Off_Val); + + -- Set the offset. + New_Assign_Stmt + (New_Selected_Element (New_Acc_Value (New_Obj (Base)), + Get_Info (El).Field_Node (Kind)), + New_Obj_Value (Off_Var)); + + if El_Tinfo.C (Kind).Builder_Need_Func then + -- This type needs a builder, call it. + Start_Declare_Stmt; + New_Var_Decl + (Ptr_Var, Get_Identifier ("var_ptr"), + O_Storage_Local, El_Tinfo.Ortho_Ptr_Type (Kind)); + + New_Assign_Stmt + (New_Obj (Ptr_Var), + M2E (Chap6.Translate_Selected_Element + (Dp2M (Base, Info, Kind), El))); + + New_Assign_Stmt + (New_Obj (Off_Var), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Off_Var), + Gen_Call_Type_Builder + (Ptr_Var, El_Type, Kind))); + + Finish_Declare_Stmt; + else + -- Allocate memory. + New_Assign_Stmt + (New_Obj (Off_Var), + New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Off_Var), + New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)))); + end if; + end if; + end loop; + New_Return_Stmt (New_Value (Get_Var (Info.C (Kind).Size_Var))); + Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Finish_Subprogram_Body; + end Create_Record_Type_Builder; + + -------------- + -- Access -- + -------------- + procedure Translate_Access_Type (Def : Iir_Access_Type_Definition) + is + D_Type : constant Iir := Get_Designated_Type (Def); + D_Info : constant Ortho_Info_Acc := Get_Info (D_Type); + Def_Info : constant Type_Info_Acc := Get_Info (Def); + Dtype : O_Tnode; + Arr_Info : Type_Info_Acc; + begin + if not Is_Fully_Constrained_Type (D_Type) then + -- An access type to an unconstrained type definition is a fat + -- pointer. + Def_Info.Type_Mode := Type_Mode_Fat_Acc; + if D_Info.Kind = Kind_Incomplete_Type then + Translate_Incomplete_Array_Type (D_Type); + Arr_Info := D_Info.Incomplete_Array; + Def_Info.Ortho_Type := Arr_Info.Ortho_Type; + Def_Info.T := Arr_Info.T; + else + Def_Info.Ortho_Type := D_Info.Ortho_Type; + Def_Info.T := D_Info.T; + end if; + Def_Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Def_Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Def_Info.Ortho_Ptr_Type (Mode_Value)); + else + -- Otherwise, it is a thin pointer. + Def_Info.Type_Mode := Type_Mode_Acc; + -- No access types for signals. + Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + + if D_Info.Kind = Kind_Incomplete_Type then + Dtype := O_Tnode_Null; + elsif Is_Complex_Type (D_Info) then + -- FIXME: clean here when the ortho_type of a array + -- complex_type is correctly set (not a pointer). + Def_Info.Ortho_Type (Mode_Value) := + D_Info.Ortho_Ptr_Type (Mode_Value); + Finish_Type_Definition (Def_Info, True); + return; + elsif D_Info.Type_Mode in Type_Mode_Arrays then + -- The designated type cannot be a sub array inside ortho. + -- FIXME: lift this restriction. + Dtype := D_Info.T.Base_Type (Mode_Value); + else + Dtype := D_Info.Ortho_Type (Mode_Value); + end if; + Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype); + Finish_Type_Definition (Def_Info); + end if; + end Translate_Access_Type; + + ------------------------ + -- Incomplete types -- + ------------------------ + procedure Translate_Incomplete_Type (Def : Iir) + is +-- Ftype : Iir; +-- Info : Type_Info_Acc; + Info : Incomplete_Type_Info_Acc; + Ctype : Iir; + begin + if Get_Nbr_Elements (Get_Incomplete_Type_List (Def)) = 0 then + -- FIXME: + -- This is a work-around for dummy incomplete type (ie incomplete + -- types not used before the full type declaration). + return; + end if; + Ctype := Get_Type (Get_Type_Declarator (Def)); + Info := Add_Info (Ctype, Kind_Incomplete_Type); + Info.Incomplete_Type := Def; + Info.Incomplete_Array := null; + end Translate_Incomplete_Type; + + -- CTYPE is the type which has been completed. + procedure Translate_Complete_Type + (Incomplete_Info : in out Incomplete_Type_Info_Acc; Ctype : Iir) + is + List : Iir_List; + Atype : Iir; + Def_Info : Type_Info_Acc; + C_Info : Type_Info_Acc; + Dtype : O_Tnode; + begin + C_Info := Get_Info (Ctype); + List := Get_Incomplete_Type_List (Incomplete_Info.Incomplete_Type); + for I in Natural loop + Atype := Get_Nth_Element (List, I); + exit when Atype = Null_Iir; + if Get_Kind (Atype) /= Iir_Kind_Access_Type_Definition then + raise Internal_Error; + end if; + Def_Info := Get_Info (Atype); + case C_Info.Type_Mode is + when Type_Mode_Arrays => + Dtype := C_Info.T.Base_Type (Mode_Value); + when others => + Dtype := C_Info.Ortho_Type (Mode_Value); + end case; + Finish_Access_Type (Def_Info.Ortho_Type (Mode_Value), Dtype); + end loop; + Unchecked_Deallocation (Incomplete_Info); + end Translate_Complete_Type; + + ----------------- + -- protected -- + ----------------- + + procedure Translate_Protected_Type (Def : Iir_Protected_Type_Declaration) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Mark : Id_Mark_Type; + begin + New_Uncomplete_Record_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); + + Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Info.Ortho_Ptr_Type (Mode_Value)); + + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; + + Info.Type_Mode := Type_Mode_Protected; + + -- A protected type is a complex type, as its size is not known + -- at definition point (will be known at body declaration). + Info.C := new Complex_Type_Arr_Info; + Info.C (Mode_Value).Builder_Need_Func := False; + + -- This is just use to set overload number on subprograms, and to + -- translate interfaces. + Push_Identifier_Prefix + (Mark, Get_Identifier (Get_Type_Declarator (Def))); + Chap4.Translate_Declaration_Chain (Def); + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type; + + procedure Translate_Protected_Type_Subprograms + (Def : Iir_Protected_Type_Declaration) + is + Info : constant Type_Info_Acc := Get_Info (Def); + El : Iir; + Inter_List : O_Inter_List; + Mark : Id_Mark_Type; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Push_Identifier_Prefix + (Mark, Get_Identifier (Get_Type_Declarator (Def))); + + -- Init. + Start_Function_Decl + (Inter_List, Create_Identifier ("INIT"), Global_Storage, + Info.Ortho_Ptr_Type (Mode_Value)); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Init_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Subprg); + + -- Use the object as instance. + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj, + Prev_Subprg_Instance); + + -- Final. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("FINI"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Final_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Final_Subprg); + + -- Methods. + El := Get_Declaration_Chain (Def); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- Translate only if used. + if Get_Info (El) /= null then + Chap2.Translate_Subprogram_Declaration (El); + end if; + when others => + Error_Kind ("translate_protected_type_subprograms", El); + end case; + El := Get_Chain (El); + end loop; + + Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Subprograms; + + procedure Translate_Protected_Type_Body (Bod : Iir) + is + Decl : constant Iir_Protected_Type_Declaration := + Get_Protected_Type_Declaration (Bod); + Info : constant Type_Info_Acc := Get_Info (Decl); + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + -- Create the object type + Push_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); + -- First, the previous instance. + Chap2.Add_Subprg_Instance_Field (Info.T.Prot_Subprg_Instance_Field); + -- Then the object lock + Info.T.Prot_Lock_Field := Add_Instance_Factory_Field + (Get_Identifier ("LOCK"), Ghdl_Ptr_Type); + + -- Translate declarations. + Chap4.Translate_Declaration_Chain (Bod); + + Pop_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); + Info.Ortho_Type (Mode_Value) := Get_Scope_Type (Info.T.Prot_Scope); + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Body; + + procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode) + is + Info : constant Type_Info_Acc := Get_Info (Type_Def); + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Proc); + New_Association + (Assoc, + New_Unchecked_Address + (New_Selected_Element + (Get_Instance_Ref (Info.T.Prot_Scope), + Info.T.Prot_Lock_Field), + Ghdl_Ptr_Type)); + New_Procedure_Call (Assoc); + end Call_Ghdl_Protected_Procedure; + + procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir) + is + Mark : Id_Mark_Type; + Decl : constant Iir := Get_Protected_Type_Declaration (Bod); + Info : constant Type_Info_Acc := Get_Info (Decl); + Final : Boolean; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + -- Subprograms of BOD. + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj, + Prev_Subprg_Instance); + Chap2.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Bod); + + Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); + + Pop_Identifier_Prefix (Mark); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Init subprogram + declare + Var_Obj : O_Dnode; + begin + Start_Subprogram_Body (Info.T.Prot_Init_Subprg); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + New_Var_Decl (Var_Obj, Wki_Obj, O_Storage_Local, + Info.Ortho_Ptr_Type (Mode_Value)); + + -- Allocate the object + New_Assign_Stmt + (New_Obj (Var_Obj), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Info.Ortho_Type (Mode_Value), + Ghdl_Index_Type)), + Info.Ortho_Ptr_Type (Mode_Value))); + + Chap2.Set_Subprg_Instance_Field + (Var_Obj, Info.T.Prot_Subprg_Instance_Field, + Info.T.Prot_Init_Instance); + + Set_Scope_Via_Param_Ptr (Info.T.Prot_Scope, Var_Obj); + + -- Create lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init); + + -- Elaborate fields. + Open_Temp; + Chap4.Elab_Declaration_Chain (Bod, Final); + Close_Temp; + + Clear_Scope (Info.T.Prot_Scope); + + New_Return_Stmt (New_Obj_Value (Var_Obj)); + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + + Finish_Subprogram_Body; + end; + + -- Fini subprogram + begin + Start_Subprogram_Body (Info.T.Prot_Final_Subprg); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + + -- Deallocate fields. + if Final or True then + Chap4.Final_Declaration_Chain (Bod, True); + end if; + + -- Destroy lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini); + + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + Finish_Subprogram_Body; + end; + end Translate_Protected_Type_Body_Subprograms; + + --------------- + -- Scalars -- + --------------- + + -- Create a type_range structure. + procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode) + is + T_Info : Type_Info_Acc; + Base_Type : Iir; + Expr : Iir; + V : O_Dnode; + begin + Base_Type := Get_Base_Type (Def); + T_Info := Get_Info (Base_Type); + Expr := Get_Range_Constraint (Def); + Open_Temp; + V := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, Target); + Chap7.Translate_Range_Ptr (V, Expr, Def); + Close_Temp; + end Create_Scalar_Type_Range; + + function Create_Static_Scalar_Type_Range (Def : Iir) return O_Cnode is + begin + return Chap7.Translate_Static_Range (Get_Range_Constraint (Def), + Get_Base_Type (Def)); + end Create_Static_Scalar_Type_Range; + + procedure Create_Scalar_Type_Range_Type + (Def : Iir; With_Length : Boolean) + is + Constr : O_Element_List; + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Def); + Start_Record_Type (Constr); + New_Record_Field + (Constr, Info.T.Range_Left, Wki_Left, + Info.Ortho_Type (Mode_Value)); + New_Record_Field + (Constr, Info.T.Range_Right, Wki_Right, + Info.Ortho_Type (Mode_Value)); + New_Record_Field + (Constr, Info.T.Range_Dir, Wki_Dir, Ghdl_Dir_Type_Node); + if With_Length then + New_Record_Field + (Constr, Info.T.Range_Length, Wki_Length, Ghdl_Index_Type); + else + Info.T.Range_Length := O_Fnode_Null; + end if; + Finish_Record_Type (Constr, Info.T.Range_Type); + New_Type_Decl (Create_Identifier ("TRT"), Info.T.Range_Type); + Info.T.Range_Ptr_Type := New_Access_Type (Info.T.Range_Type); + New_Type_Decl (Create_Identifier ("TRPTR"), + Info.T.Range_Ptr_Type); + end Create_Scalar_Type_Range_Type; + + function Create_Static_Type_Definition_Type_Range (Def : Iir) + return O_Cnode + is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kinds_Scalar_Subtype_Definition => + return Create_Static_Scalar_Type_Range (Def); + + when Iir_Kind_Array_Subtype_Definition => + return Create_Static_Array_Subtype_Bounds (Def); + + when Iir_Kind_Array_Type_Definition => + return O_Cnode_Null; + + when others => + Error_Kind ("create_static_type_definition_type_range", Def); + end case; + end Create_Static_Type_Definition_Type_Range; + + procedure Create_Type_Definition_Type_Range (Def : Iir) + is + Target : O_Lnode; + Info : Type_Info_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kinds_Scalar_Subtype_Definition => + Target := Get_Var (Get_Info (Def).T.Range_Var); + Create_Scalar_Type_Range (Def, Target); + + when Iir_Kind_Array_Subtype_Definition => + if Get_Constraint_State (Def) = Fully_Constrained then + Info := Get_Info (Def); + if not Info.T.Static_Bounds then + Target := Get_Var (Info.T.Array_Bounds); + Create_Array_Subtype_Bounds (Def, Target); + end if; + end if; + + when Iir_Kind_Array_Type_Definition => + declare + Index_List : constant Iir_List := + Get_Index_Subtype_List (Def); + Index : Iir; + begin + for I in Natural loop + Index := Get_Index_Type (Index_List, I); + exit when Index = Null_Iir; + if Is_Anonymous_Type_Definition (Index) then + Create_Type_Definition_Type_Range (Index); + end if; + end loop; + end; + Translate_Dynamic_Unidimensional_Array_Length_One (Def); + return; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Protected_Type_Declaration => + return; + + when others => + Error_Kind ("create_type_definition_type_range", Def); + end case; + end Create_Type_Definition_Type_Range; + + -- Return TRUE iff LIT is equal to the high (IS_HI=TRUE) or low + -- (IS_HI=false) limit of the base type of DEF. MODE is the mode of + -- DEF. + function Is_Equal_Limit (Lit : Iir; + Is_Hi : Boolean; + Def : Iir; + Mode : Type_Mode_Type) return Boolean + is + begin + case Mode is + when Type_Mode_B1 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Eval_Pos (Lit)); + if Is_Hi then + return V = 1; + else + return V = 0; + end if; + end; + when Type_Mode_E8 => + declare + V : Iir_Int32; + Base_Type : Iir; + begin + V := Iir_Int32 (Eval_Pos (Lit)); + if Is_Hi then + Base_Type := Get_Base_Type (Def); + return V = Iir_Int32 + (Get_Nbr_Elements + (Get_Enumeration_Literal_List (Base_Type))) - 1; + else + return V = 0; + end if; + end; + when Type_Mode_I32 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Get_Value (Lit)); + if Is_Hi then + return V = Iir_Int32'Last; + else + return V = Iir_Int32'First; + end if; + end; + when Type_Mode_P32 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Get_Physical_Value (Lit)); + if Is_Hi then + return V = Iir_Int32'Last; + else + return V = Iir_Int32'First; + end if; + end; + when Type_Mode_I64 => + declare + V : Iir_Int64; + begin + V := Get_Value (Lit); + if Is_Hi then + return V = Iir_Int64'Last; + else + return V = Iir_Int64'First; + end if; + end; + when Type_Mode_P64 => + declare + V : Iir_Int64; + begin + V := Get_Physical_Value (Lit); + if Is_Hi then + return V = Iir_Int64'Last; + else + return V = Iir_Int64'First; + end if; + end; + when Type_Mode_F64 => + declare + V : Iir_Fp64; + begin + V := Get_Fp_Value (Lit); + if Is_Hi then + return V = Iir_Fp64'Last; + else + return V = Iir_Fp64'First; + end if; + end; + when others => + Error_Kind ("is_equal_limit " & Type_Mode_Type'Image (Mode), + Lit); + end case; + end Is_Equal_Limit; + + -- For scalar subtypes: creates info from the base type. + procedure Create_Subtype_Info_From_Type (Def : Iir; + Subtype_Info : Type_Info_Acc; + Base_Info : Type_Info_Acc) + is + Rng : Iir; + Lo, Hi : Iir; + begin + Subtype_Info.Ortho_Type := Base_Info.Ortho_Type; + Subtype_Info.Ortho_Ptr_Type := Base_Info.Ortho_Ptr_Type; + Subtype_Info.Type_Mode := Base_Info.Type_Mode; + Subtype_Info.T := Base_Info.T; + + Rng := Get_Range_Constraint (Def); + if Get_Expr_Staticness (Rng) /= Locally then + -- Bounds are not known. + -- Do the checks. + Subtype_Info.T.Nocheck_Hi := False; + Subtype_Info.T.Nocheck_Low := False; + else + -- Bounds are locally static. + Get_Low_High_Limit (Rng, Lo, Hi); + Subtype_Info.T.Nocheck_Hi := + Is_Equal_Limit (Hi, True, Def, Base_Info.Type_Mode); + Subtype_Info.T.Nocheck_Low := + Is_Equal_Limit (Lo, False, Def, Base_Info.Type_Mode); + end if; + end Create_Subtype_Info_From_Type; + + procedure Create_Record_Size_Var (Def : Iir; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Def)); + El : Iir_Element_Declaration; + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Inner_Type : Iir; + Inner_Tinfo : Type_Info_Acc; + Res : O_Enode; + Align_Var : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + + -- Start with the size of the 'base' record, that + -- contains all non-complex types and an offset for + -- each complex types. + Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type)); + + -- Start with alignment of the record. + -- ALIGN = ALIGNOF (record) + if Kind = Mode_Value then + Align_Var := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Align_Var), + Get_Type_Alignmask (Info.Ortho_Type (Kind))); + end if; + + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + El_Tinfo := Get_Info (El_Type); + if Is_Complex_Type (El_Tinfo) then + Inner_Type := Get_Innermost_Non_Array_Element (El_Type); + + -- Align (only for Mode_Value) the size, + -- and add the size of the element. + if Kind = Mode_Value then + Inner_Tinfo := Get_Info (Inner_Type); + -- If alignmask (Inner_Type) > alignmask then + -- alignmask = alignmask (Inner_type); + -- end if; + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Gt, + Get_Type_Alignmask (Inner_Tinfo), + New_Obj_Value (Align_Var), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Align_Var), Get_Type_Alignmask (Inner_Tinfo)); + Finish_If_Stmt (If_Blk); + Res := Realign (Res, Inner_Type); + end if; + Res := New_Dyadic_Op + (ON_Add_Ov, + New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Res); + end if; + end loop; + if Kind = Mode_Value then + Res := Realign (Res, Align_Var); + end if; + New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); + Close_Temp; + end Create_Record_Size_Var; + + procedure Create_Array_Size_Var (Def : Iir; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + El_Type : constant Iir := Get_Element_Subtype (Def); + Res : O_Enode; + begin + Res := New_Dyadic_Op + (ON_Mul_Ov, + Get_Array_Type_Length (Def), + Chap3.Get_Object_Size (T2M (El_Type, Kind), El_Type)); + New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); + end Create_Array_Size_Var; + + procedure Create_Type_Definition_Size_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + begin + if not Is_Complex_Type (Info) then + return; + end if; + + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + if Info.C (Kind).Size_Var /= Null_Var then + case Info.Type_Mode is + when Type_Mode_Non_Composite + | Type_Mode_Fat_Array + | Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + when Type_Mode_Record => + Create_Record_Size_Var (Def, Kind); + when Type_Mode_Array => + Create_Array_Size_Var (Def, Kind); + end case; + end if; + end loop; + end Create_Type_Definition_Size_Var; + + procedure Create_Type_Range_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Info : Type_Info_Acc; + Val : O_Cnode; + Suffix : String (1 .. 3) := "xTR"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Subtype_Definition => + Suffix (1) := 'S'; -- "STR"; + when Iir_Kind_Enumeration_Type_Definition => + Suffix (1) := 'B'; -- "BTR"; + when others => + raise Internal_Error; + end case; + Base_Info := Get_Info (Get_Base_Type (Def)); + case Get_Type_Staticness (Def) is + when None + | Globally => + Info.T.Range_Var := Create_Var + (Create_Var_Identifier (Suffix), Base_Info.T.Range_Type); + when Locally => + if Global_Storage = O_Storage_External then + -- Do not create the value of the type desc, since it + -- is never dereferenced in a static type desc. + Val := O_Cnode_Null; + else + Val := Create_Static_Type_Definition_Type_Range (Def); + end if; + Info.T.Range_Var := Create_Global_Const + (Create_Identifier (Suffix), + Base_Info.T.Range_Type, Global_Storage, Val); + when Unknown => + raise Internal_Error; + end case; + end Create_Type_Range_Var; + + + -- Call HANDLE_A_SUBTYPE for all type/subtypes declared with DEF + -- (of course, this is a noop if DEF is not a composite type). + generic + with procedure Handle_A_Subtype (Atype : Iir); + procedure Handle_Anonymous_Subtypes (Def : Iir); + + procedure Handle_Anonymous_Subtypes (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Asub : Iir; + begin + Asub := Get_Element_Subtype (Def); + if Is_Anonymous_Type_Definition (Asub) then + Handle_A_Subtype (Asub); + end if; + end; + when Iir_Kind_Record_Type_Definition => + declare + El : Iir; + Asub : Iir; + 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; + Asub := Get_Type (El); + if Is_Anonymous_Type_Definition (Asub) then + Handle_A_Subtype (Asub); + end if; + end loop; + end; + when others => + null; + end case; + end Handle_Anonymous_Subtypes; + + -- Note: boolean types are translated by translate_bool_type_definition! + procedure Translate_Type_Definition + (Def : Iir; With_Vars : Boolean := True) + is + Info : Ortho_Info_Acc; + Base_Info : Type_Info_Acc; + Base_Type : Iir; + Complete_Info : Incomplete_Type_Info_Acc; + begin + -- Handle the special case of incomplete type. + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + Translate_Incomplete_Type (Def); + return; + end if; + + -- If the definition is already translated, return now. + Info := Get_Info (Def); + if Info /= null then + if Info.Kind = Kind_Type then + -- The subtype was already translated. + return; + end if; + if Info.Kind = Kind_Incomplete_Type then + -- Type is being completed. + Complete_Info := Info; + Clear_Info (Def); + if Complete_Info.Incomplete_Array /= null then + Info := Complete_Info.Incomplete_Array; + Set_Info (Def, Info); + Unchecked_Deallocation (Complete_Info); + else + Info := Add_Info (Def, Kind_Type); + end if; + else + raise Internal_Error; + end if; + else + Complete_Info := null; + Info := Add_Info (Def, Kind_Type); + end if; + + Base_Type := Get_Base_Type (Def); + Base_Info := Get_Info (Base_Type); + + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + Translate_Enumeration_Type (Def); + Create_Scalar_Type_Range_Type (Def, True); + Create_Type_Range_Var (Def); + --Create_Type_Desc_Var (Def); + + when Iir_Kind_Integer_Type_Definition => + Translate_Integer_Type (Def); + Create_Scalar_Type_Range_Type (Def, True); + + when Iir_Kind_Physical_Type_Definition => + Translate_Physical_Type (Def); + Create_Scalar_Type_Range_Type (Def, False); + if With_Vars and Get_Type_Staticness (Def) /= Locally then + Translate_Physical_Units (Def); + else + Info.T.Range_Var := Null_Var; + end if; + + when Iir_Kind_Floating_Type_Definition => + Translate_Floating_Type (Def); + Create_Scalar_Type_Range_Type (Def, False); + + when Iir_Kinds_Scalar_Subtype_Definition => + Create_Subtype_Info_From_Type (Def, Info, Base_Info); + if With_Vars then + Create_Type_Range_Var (Def); + else + Info.T.Range_Var := Null_Var; + end if; + + when Iir_Kind_Array_Type_Definition => + declare + El_Type : Iir; + Mark : Id_Mark_Type; + begin + El_Type := Get_Element_Subtype (Def); + if Get_Info (El_Type) = null then + Push_Identifier_Prefix (Mark, "ET"); + Translate_Type_Definition (El_Type); + Pop_Identifier_Prefix (Mark); + end if; + end; + Translate_Array_Type_Definition (Def); + + when Iir_Kind_Array_Subtype_Definition => + if Get_Index_Constraint_Flag (Def) then + if Base_Info = null or else Base_Info.Type_Incomplete then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "BT"); + Translate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + Base_Info := Get_Info (Base_Type); + end; + end if; + Translate_Array_Subtype_Definition (Def); + Info.T := Base_Info.T; + --Info.Type_Range_Type := Base_Info.Type_Range_Type; + if With_Vars then + Create_Array_Subtype_Bounds_Var (Def, False); + end if; + else + -- An unconstrained array subtype. Use same infos as base + -- type. + Free_Info (Def); + Set_Info (Def, Base_Info); + end if; + Translate_Array_Subtype_Element_Subtype (Def); + + when Iir_Kind_Record_Type_Definition => + Translate_Record_Type (Def); + Info.T := Ortho_Info_Type_Record_Init; + + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + Free_Info (Def); + Set_Info (Def, Base_Info); + + when Iir_Kind_Access_Type_Definition => + declare + Dtype : constant Iir := Get_Designated_Type (Def); + begin + -- Translate the subtype + if Is_Anonymous_Type_Definition (Dtype) then + Translate_Type_Definition (Dtype); + end if; + Translate_Access_Type (Def); + end; + + when Iir_Kind_File_Type_Definition => + Translate_File_Type (Def); + Info.T := Ortho_Info_Type_File_Init; + if With_Vars then + Create_File_Type_Var (Def); + end if; + + when Iir_Kind_Protected_Type_Declaration => + Translate_Protected_Type (Def); + Info.T := Ortho_Info_Type_Prot_Init; + + when others => + Error_Kind ("translate_type_definition", Def); + end case; + + if Complete_Info /= null then + Translate_Complete_Type (Complete_Info, Def); + end if; + end Translate_Type_Definition; + + procedure Translate_Bool_Type_Definition (Def : Iir) + is + Info : Type_Info_Acc; + begin + -- If the definition is already translated, return now. + Info := Get_Info (Def); + if Info /= null then + raise Internal_Error; + end if; + + Info := Add_Info (Def, Kind_Type); + + if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then + raise Internal_Error; + end if; + Translate_Bool_Type (Def); + + -- This is usually done in translate_type_definition, but boolean + -- types are not handled by translate_type_definition. + Create_Scalar_Type_Range_Type (Def, True); + end Translate_Bool_Type_Definition; + + procedure Translate_Type_Subprograms (Decl : Iir) + is + Def : Iir; + Tinfo : Type_Info_Acc; + Id : Name_Id; + begin + Def := Get_Type_Definition (Decl); + + if Get_Kind (Def) in Iir_Kinds_Subtype_Definition then + -- Also elaborate the base type, iff DEF and its BASE_TYPE have + -- been declared by the same type declarator. This avoids several + -- elaboration of the same type. + Def := Get_Base_Type (Def); + if Get_Type_Declarator (Def) /= Decl then + -- Can this happen ?? + raise Internal_Error; + end if; + elsif Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + return; + end if; + + if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then + Translate_Protected_Type_Subprograms (Def); + end if; + + Tinfo := Get_Info (Def); + if not Is_Complex_Type (Tinfo) + or else Tinfo.C (Mode_Value).Builder_Need_Func = False + then + return; + end if; + + -- Declare subprograms. + Id := Get_Identifier (Decl); + Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal); + end if; + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Define subprograms. + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition => + Create_Array_Type_Builder (Def, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Array_Type_Builder (Def, Mode_Signal); + end if; + when Iir_Kind_Record_Type_Definition => + Create_Record_Type_Builder (Def, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Record_Type_Builder (Def, Mode_Signal); + end if; + when others => + Error_Kind ("translate_type_subprograms", Def); + end case; + end Translate_Type_Subprograms; + + -- Initialize the objects related to a type (type range and type + -- descriptor). + procedure Elab_Type_Definition (Def : Iir); + procedure Elab_Type_Definition_Depend is new Handle_Anonymous_Subtypes + (Handle_A_Subtype => Elab_Type_Definition); + procedure Elab_Type_Definition (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Incomplete_Type_Definition => + -- Nothing to do. + return; + when Iir_Kind_Protected_Type_Declaration => + -- Elaboration subprograms interfaces. + declare + Final : Boolean; + begin + Chap4.Elab_Declaration_Chain (Def, Final); + if Final then + raise Internal_Error; + end if; + end; + return; + when others => + null; + end case; + + if Get_Type_Staticness (Def) = Locally then + return; + end if; + + Elab_Type_Definition_Depend (Def); + + Create_Type_Definition_Type_Range (Def); + Create_Type_Definition_Size_Var (Def); + end Elab_Type_Definition; + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Id); + Chap3.Translate_Type_Definition (Def); + Pop_Identifier_Prefix (Mark); + end Translate_Named_Type_Definition; + + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean) + is + Mark : Id_Mark_Type; + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Def); + if Type_Info /= null then + return; + end if; + Push_Identifier_Prefix_Uniq (Mark); + Chap3.Translate_Type_Definition (Def, False); + if Transient then + Add_Transient_Type_In_Temp (Def); + end if; + Pop_Identifier_Prefix (Mark); + end Translate_Anonymous_Type_Definition; + + procedure Destroy_Type_Info (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Free_Type_Info (Type_Info); + Clear_Info (Atype); + end Destroy_Type_Info; + + procedure Translate_Object_Subtype (Decl : Iir; + With_Vars : Boolean := True) + is + Mark : Id_Mark_Type; + Mark2 : Id_Mark_Type; + Def : Iir; + begin + Def := Get_Type (Decl); + if Is_Anonymous_Type_Definition (Def) then + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark2, "OT"); + Chap3.Translate_Type_Definition (Def, With_Vars); + Pop_Identifier_Prefix (Mark2); + Pop_Identifier_Prefix (Mark); + end if; + end Translate_Object_Subtype; + + procedure Elab_Object_Subtype (Def : Iir) is + begin + if Is_Anonymous_Type_Definition (Def) then + Elab_Type_Definition (Def); + end if; + end Elab_Object_Subtype; + + procedure Elab_Type_Declaration (Decl : Iir) + is + begin + Elab_Type_Definition (Get_Type_Definition (Decl)); + end Elab_Type_Declaration; + + procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration) + is + begin + Elab_Type_Definition (Get_Type (Decl)); + end Elab_Subtype_Declaration; + + function Get_Thin_Array_Length (Atype : Iir) return O_Cnode + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Indexes_List); + Index : Iir; + Val : Iir_Int64; + Rng : Iir; + begin + Val := 1; + for I in 0 .. Nbr_Dim - 1 loop + Index := Get_Index_Type (Indexes_List, I); + Rng := Get_Range_Constraint (Index); + Val := Val * Eval_Discrete_Range_Length (Rng); + end loop; + return New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Val)); + end Get_Thin_Array_Length; + + function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) + return Mnode + is + Indexes_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Get_Base_Type (Atype)); + Index_Type_Mark : constant Iir := + Get_Nth_Element (Indexes_List, Dim - 1); + Index_Type : constant Iir := Get_Index_Type (Index_Type_Mark); + Base_Index_Info : constant Index_Info_Acc := + Get_Info (Index_Type_Mark); + Iinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Index_Type)); + begin + return Lv2M (New_Selected_Element (M2Lv (B), + Base_Index_Info.Index_Field), + Iinfo, + Get_Object_Kind (B), + Iinfo.T.Range_Type, + Iinfo.T.Range_Ptr_Type); + end Bounds_To_Range; + + function Type_To_Range (Atype : Iir) return Mnode + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + return Varv2M (Info.T.Range_Var, Info, Mode_Value, + Info.T.Range_Type, Info.T.Range_Ptr_Type); + end Type_To_Range; + + function Range_To_Length (R : Mnode) return Mnode + is + Tinfo : constant Type_Info_Acc := Get_Type_Info (R); + begin + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Length), + Tinfo, + Mode_Value); + end Range_To_Length; + + function Range_To_Dir (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Dir), + Tinfo, + Mode_Value); + end Range_To_Dir; + + function Range_To_Left (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Left), + Tinfo, + Mode_Value); + end Range_To_Left; + + function Range_To_Right (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Right), + Tinfo, + Mode_Value); + end Range_To_Right; + + function Get_Array_Type_Bounds (Info : Type_Info_Acc) return Mnode + is + begin + case Info.Type_Mode is + when Type_Mode_Fat_Array => + raise Internal_Error; + when Type_Mode_Array => + return Varv2M (Info.T.Array_Bounds, + Info, Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type); + when others => + raise Internal_Error; + end case; + end Get_Array_Type_Bounds; + + function Get_Array_Type_Bounds (Atype : Iir) return Mnode is + begin + return Get_Array_Type_Bounds (Get_Info (Atype)); + end Get_Array_Type_Bounds; + + function Get_Array_Bounds (Arr : Mnode) return Mnode + is + Info : constant Type_Info_Acc := Get_Type_Info (Arr); + begin + case Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + declare + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Arr); + return Lp2M + (New_Selected_Element (M2Lv (Arr), + Info.T.Bounds_Field (Kind)), + Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type); + end; + when Type_Mode_Array => + return Get_Array_Type_Bounds (Info); + when others => + raise Internal_Error; + end case; + end Get_Array_Bounds; + + function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) + return Mnode is + begin + return Bounds_To_Range (Get_Array_Bounds (Arr), Atype, Dim); + end Get_Array_Range; + + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + Index_List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Dim_Length : O_Enode; + Res : O_Enode; + Bounds_Stable : Mnode; + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + end if; + + if Nbr_Dim > 1 then + Bounds_Stable := Stabilize (Bounds); + else + Bounds_Stable := Bounds; + end if; + + for Dim in 1 .. Nbr_Dim loop + Dim_Length := + M2E (Range_To_Length + (Bounds_To_Range (Bounds_Stable, Atype, Dim))); + if Dim = 1 then + Res := Dim_Length; + else + Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); + end if; + end loop; + return Res; + end Get_Bounds_Length; + + function Get_Array_Type_Length (Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype); + end if; + end Get_Array_Type_Length; + + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Bounds (Arr), Atype); + end if; + end Get_Array_Length; + + function Get_Array_Base (Arr : Mnode) return Mnode + is + Info : Type_Info_Acc; + begin + Info := Get_Type_Info (Arr); + case Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + declare + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Arr); + return Lp2M + (New_Selected_Element (M2Lv (Arr), + Info.T.Base_Field (Kind)), + Info, + Get_Object_Kind (Arr), + Info.T.Base_Type (Kind), + Info.T.Base_Ptr_Type (Kind)); + end; + when Type_Mode_Array => + return Arr; + when others => + raise Internal_Error; + end case; + end Get_Array_Base; + + function Reindex_Complex_Array + (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc) + return Mnode + is + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + pragma Assert (Is_Complex_Type (El_Tinfo)); + return + E2M + (New_Unchecked_Address + (New_Slice + (New_Access_Element + (New_Convert_Ov (M2E (Base), Char_Ptr_Type)), + Chararray_Type, + New_Dyadic_Op (ON_Mul_Ov, + New_Value + (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Index)), + El_Tinfo.Ortho_Ptr_Type (Kind)), + Res_Info, Kind); + end Reindex_Complex_Array; + + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, El_Tinfo); + else + return Lv2M (New_Indexed_Element (M2Lv (Base), Index), + El_Tinfo, Kind); + end if; + end Index_Base; + + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + T_Info : constant Type_Info_Acc := Get_Info (Atype); + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, T_Info); + else + return Lv2M (New_Slice (M2Lv (Base), + T_Info.T.Base_Type (Kind), + Index), + False, + T_Info.T.Base_Type (Kind), + T_Info.T.Base_Ptr_Type (Kind), + T_Info, Kind); + end if; + end Slice_Base; + + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; + Res : Mnode; + Arr_Type : Iir) + is + Dinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Arr_Type)); + Kind : constant Object_Kind_Type := Get_Object_Kind (Res); + Length : O_Enode; + begin + -- Compute array size. + Length := Get_Object_Size (Res, Arr_Type); + -- Allocate the storage for the elements. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + Gen_Alloc (Alloc_Kind, Length, Dinfo.T.Base_Ptr_Type (Kind))); + + if Is_Complex_Type (Dinfo) + and then Dinfo.C (Kind).Builder_Need_Func + then + Open_Temp; + -- Build the type. + Chap3.Gen_Call_Type_Builder (Res, Arr_Type); + Close_Temp; + end if; + end Allocate_Fat_Array_Base; + + procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix_Uniq (Mark); + if Get_Info (Sub_Type) = null then + -- Minimal subtype creation. + Translate_Type_Definition (Sub_Type, False); + if Transient then + Add_Transient_Type_In_Temp (Sub_Type); + end if; + end if; + -- Force creation of variables. + Chap3.Create_Array_Subtype_Bounds_Var (Sub_Type, True); + Chap3.Create_Type_Definition_Size_Var (Sub_Type); + Pop_Identifier_Prefix (Mark); + end Create_Array_Subtype; + + -- Copy SRC to DEST. + -- Both have the same type, OTYPE. + procedure Translate_Object_Copy (Dest : Mnode; + Src : O_Enode; + Obj_Type : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Obj_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Dest); + D : Mnode; + begin + case Info.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File => + -- Scalar or thin pointer. + New_Assign_Stmt (M2Lv (Dest), Src); + when Type_Mode_Fat_Acc => + -- a fat pointer. + D := Stabilize (Dest); + Copy_Fat_Pointer (D, Stabilize (E2M (Src, Info, Kind))); + when Type_Mode_Fat_Array => + -- a fat array. + D := Stabilize (Dest); + Gen_Memcpy (M2Addr (Get_Array_Base (D)), + M2Addr (Get_Array_Base (E2M (Src, Info, Kind))), + Get_Object_Size (D, Obj_Type)); + when Type_Mode_Array + | Type_Mode_Record => + D := Stabilize (Dest); + Gen_Memcpy (M2Addr (D), Src, Get_Object_Size (D, Obj_Type)); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Object_Copy; + + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) + return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); + begin + if Is_Complex_Type (Type_Info) + and then Type_Info.C (Kind).Size_Var /= Null_Var + then + return New_Value (Get_Var (Type_Info.C (Kind).Size_Var)); + end if; + case Type_Info.Type_Mode is + when Type_Mode_Non_Composite + | Type_Mode_Array + | Type_Mode_Record => + return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind), + Ghdl_Index_Type)); + when Type_Mode_Fat_Array => + declare + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Obj_Bt : Iir; + Sz : O_Enode; + begin + Obj_Bt := Get_Base_Type (Obj_Type); + El_Type := Get_Element_Subtype (Obj_Bt); + El_Tinfo := Get_Info (El_Type); + -- See create_type_definition_size_var. + Sz := Get_Object_Size (T2M (El_Type, Kind), El_Type); + if Is_Complex_Type (El_Tinfo) then + Sz := New_Dyadic_Op + (ON_Add_Ov, + Sz, + New_Lit (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind), + Ghdl_Index_Type))); + end if; + return New_Dyadic_Op + (ON_Mul_Ov, Chap3.Get_Array_Length (Obj, Obj_Bt), Sz); + end; + when others => + raise Internal_Error; + end case; + end Get_Object_Size; + + procedure Translate_Object_Allocation + (Res : in out Mnode; + Alloc_Kind : Allocation_Kind; + Obj_Type : Iir; + Bounds : Mnode) + is + Dinfo : constant Type_Info_Acc := Get_Info (Obj_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Res); + begin + if Dinfo.Type_Mode = Type_Mode_Fat_Array then + -- Allocate memory for bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + Gen_Alloc (Alloc_Kind, + New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Dinfo.T.Bounds_Ptr_Type)); + + -- Copy bounds to the allocated area. + Gen_Memcpy + (M2Addr (Chap3.Get_Array_Bounds (Res)), + M2Addr (Bounds), + New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, Ghdl_Index_Type))); + + -- Allocate base. + Allocate_Fat_Array_Base (Alloc_Kind, Res, Obj_Type); + else + New_Assign_Stmt + (M2Lp (Res), + Gen_Alloc + (Alloc_Kind, + Chap3.Get_Object_Size (T2M (Obj_Type, Kind), + Obj_Type), + Dinfo.Ortho_Ptr_Type (Kind))); + + if Is_Complex_Type (Dinfo) + and then Dinfo.C (Kind).Builder_Need_Func + then + Open_Temp; + -- Build the type. + Chap3.Gen_Call_Type_Builder (Res, Obj_Type); + Close_Temp; + end if; + + end if; + end Translate_Object_Allocation; + + procedure Gen_Deallocate (Obj : O_Enode) + is + Assocs : O_Assoc_List; + begin + Start_Association (Assocs, Ghdl_Deallocate); + New_Association (Assocs, New_Convert_Ov (Obj, Ghdl_Ptr_Type)); + New_Procedure_Call (Assocs); + end Gen_Deallocate; + + -- Performs deallocation of PARAM (the parameter of a deallocate call). + procedure Translate_Object_Deallocation (Param : Iir) + is + -- Performs deallocation of field FIELD of type FTYPE of PTR. + -- If FIELD is O_FNODE_NULL, deallocate PTR (of type FTYPE). + -- Here, deallocate means freeing memory and clearing to null. + procedure Deallocate_1 + (Ptr : Mnode; Field : O_Fnode; Ftype : O_Tnode) + is + L : O_Lnode; + begin + for I in 0 .. 1 loop + L := M2Lv (Ptr); + if Field /= O_Fnode_Null then + L := New_Selected_Element (L, Field); + end if; + case I is + when 0 => + -- Call deallocator. + Gen_Deallocate (New_Value (L)); + when 1 => + -- set the value to 0. + New_Assign_Stmt (L, New_Lit (New_Null_Access (Ftype))); + end case; + end loop; + end Deallocate_1; + + Param_Type : Iir; + Val : Mnode; + Info : Type_Info_Acc; + Binfo : Type_Info_Acc; + begin + -- Compute parameter + Val := Chap6.Translate_Name (Param); + if Get_Object_Kind (Val) = Mode_Signal then + raise Internal_Error; + end if; + Stabilize (Val); + Param_Type := Get_Type (Param); + Info := Get_Info (Param_Type); + case Info.Type_Mode is + when Type_Mode_Fat_Acc => + -- This is a fat pointer. + -- Deallocate base and bounds. + Binfo := Get_Info (Get_Designated_Type (Param_Type)); + Deallocate_1 (Val, Binfo.T.Base_Field (Mode_Value), + Binfo.T.Base_Ptr_Type (Mode_Value)); + Deallocate_1 (Val, Binfo.T.Bounds_Field (Mode_Value), + Binfo.T.Bounds_Ptr_Type); + when Type_Mode_Acc => + -- This is a thin pointer. + Deallocate_1 (Val, O_Fnode_Null, + Info.Ortho_Type (Mode_Value)); + when others => + raise Internal_Error; + end case; + end Translate_Object_Deallocation; + + function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode + is + Constr : Iir; + Info : Type_Info_Acc; + + function Gen_Compare (Low : O_Enode; Hi : O_Enode) return O_Enode + is + L, H : O_Enode; + begin + if not Info.T.Nocheck_Low then + L := New_Compare_Op + (ON_Lt, New_Obj_Value (Value), Low, Ghdl_Bool_Type); + end if; + if not Info.T.Nocheck_Hi then + H := New_Compare_Op + (ON_Gt, New_Obj_Value (Value), Hi, Ghdl_Bool_Type); + end if; + if Info.T.Nocheck_Hi then + if Info.T.Nocheck_Low then + -- Should not happen! + return New_Lit (Ghdl_Bool_False_Node); + else + return L; + end if; + else + if Info.T.Nocheck_Low then + return H; + else + return New_Dyadic_Op (ON_Or, L, H); + end if; + end if; + end Gen_Compare; + + function Gen_Compare_To return O_Enode is + begin + return Gen_Compare + (Chap14.Translate_Left_Type_Attribute (Atype), + Chap14.Translate_Right_Type_Attribute (Atype)); + end Gen_Compare_To; + + function Gen_Compare_Downto return O_Enode is + begin + return Gen_Compare + (Chap14.Translate_Right_Type_Attribute (Atype), + Chap14.Translate_Left_Type_Attribute (Atype)); + end Gen_Compare_Downto; + + --Low, High : Iir; + Var_Res : O_Dnode; + If_Blk : O_If_Block; + begin + Constr := Get_Range_Constraint (Atype); + Info := Get_Info (Atype); + + if Get_Kind (Constr) = Iir_Kind_Range_Expression then + -- Constraint is a range expression, therefore, direction is + -- known. + if Get_Expr_Staticness (Constr) = Locally then + -- Range constraint is locally static + -- FIXME: check low and high if they are not limits... + --Low := Get_Low_Limit (Constr); + --High := Get_High_Limit (Constr); + null; + end if; + case Get_Direction (Constr) is + when Iir_To => + return Gen_Compare_To; + when Iir_Downto => + return Gen_Compare_Downto; + end case; + end if; + + -- Range constraint is not static + -- full check (lot's of code ?). + Var_Res := Create_Temp (Ghdl_Bool_Type); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + Chap14.Translate_Dir_Type_Attribute (Atype), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + -- To. + New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_To); + New_Else_Stmt (If_Blk); + -- Downto + New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_Downto); + Finish_If_Stmt (If_Blk); + return New_Obj_Value (Var_Res); + end Not_In_Range; + + function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Info.T.Nocheck_Low and Info.T.Nocheck_Hi then + return False; + end if; + if Expr /= Null_Iir and then Get_Type (Expr) = Atype then + return False; + end if; + return True; + end Need_Range_Check; + + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir) + is + If_Blk : O_If_Block; + begin + if not Need_Range_Check (Expr, Atype) then + return; + end if; + + if Expr /= Null_Iir + and then Get_Expr_Staticness (Expr) = Locally + and then Get_Type_Staticness (Atype) = Locally + then + if not Eval_Is_In_Bound (Eval_Static_Expr (Expr), Atype) then + Chap6.Gen_Bound_Error (Loc); + end if; + else + Open_Temp; + Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype)); + Chap6.Gen_Bound_Error (Loc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end if; + end Check_Range; + + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode + is + Var : O_Dnode; + begin + Var := Create_Temp_Init + (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value); + Check_Range (Var, Expr, Atype, Loc); + return New_Obj_Value (Var); + end Insert_Scalar_Check; + + function Maybe_Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir) + return O_Enode + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + -- pragma Assert (Base_Type = Get_Base_Type (Atype)); + if Get_Kind (Expr_Type) in Iir_Kinds_Scalar_Type_Definition + and then Need_Range_Check (Expr, Atype) + then + return Insert_Scalar_Check (Value, Expr, Atype, Expr); + else + return Value; + end if; + end Maybe_Insert_Scalar_Check; + + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean + is + L_Indexes : constant Iir_List := Get_Index_Subtype_List (L_Type); + R_Indexes : constant Iir_List := Get_Index_Subtype_List (R_Type); + L_El : Iir; + R_El : Iir; + begin + for I in Natural loop + L_El := Get_Index_Type (L_Indexes, I); + R_El := Get_Index_Type (R_Indexes, I); + exit when L_El = Null_Iir and R_El = Null_Iir; + if Eval_Discrete_Type_Length (L_El) + /= Eval_Discrete_Type_Length (R_El) + then + return False; + end if; + end loop; + return True; + end Locally_Array_Match; + + procedure Check_Array_Match (L_Type : Iir; + L_Node : Mnode; + R_Type : Iir; + R_Node : Mnode; + Loc : Iir) + is + L_Tinfo, R_Tinfo : Type_Info_Acc; + begin + L_Tinfo := Get_Info (L_Type); + R_Tinfo := Get_Info (R_Type); + -- FIXME: optimize for a statically bounded array of a complex type. + if L_Tinfo.Type_Mode = Type_Mode_Array + and then L_Tinfo.Type_Locally_Constrained + and then R_Tinfo.Type_Mode = Type_Mode_Array + and then R_Tinfo.Type_Locally_Constrained + then + -- Both left and right are thin array. + -- Check here the length are the same. + if not Locally_Array_Match (L_Type, R_Type) then + Chap6.Gen_Bound_Error (Loc); + end if; + else + -- Check length match. + declare + Index_List : constant Iir_List := + Get_Index_Subtype_List (L_Type); + Index : Iir; + Cond : O_Enode; + Sub_Cond : O_Enode; + begin + for I in Natural loop + Index := Get_Nth_Element (Index_List, I); + exit when Index = Null_Iir; + Sub_Cond := New_Compare_Op + (ON_Neq, + M2E (Range_To_Length + (Get_Array_Range (L_Node, L_Type, I + 1))), + M2E (Range_To_Length + (Get_Array_Range (R_Node, R_Type, I + 1))), + Ghdl_Bool_Type); + if I = 0 then + Cond := Sub_Cond; + else + Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); + end if; + end loop; + Chap6.Check_Bound_Error (Cond, Loc, 0); + end; + end if; + end Check_Array_Match; + + procedure Create_Range_From_Array_Attribute_And_Length + (Array_Attr : Iir; Length : O_Dnode; Range_Ptr : O_Dnode) + is + Attr_Kind : Iir_Kind; + Arr_Rng : Mnode; + Iinfo : Type_Info_Acc; + + Res : Mnode; + + Dir : O_Enode; + Diff : O_Dnode; + Left_Bound : Mnode; + If_Blk : O_If_Block; + If_Blk1 : O_If_Block; + begin + Open_Temp; + Arr_Rng := Chap14.Translate_Array_Attribute_To_Range (Array_Attr); + Iinfo := Get_Type_Info (Arr_Rng); + Stabilize (Arr_Rng); + + Res := Dp2M (Range_Ptr, Iinfo, Mode_Value); + + -- Length. + New_Assign_Stmt (M2Lv (Range_To_Length (Arr_Rng)), + New_Obj_Value (Length)); + + -- Direction. + Attr_Kind := Get_Kind (Array_Attr); + Dir := M2E (Range_To_Dir (Arr_Rng)); + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Dir (Res)), Dir); + when Iir_Kind_Reverse_Range_Array_Attribute => + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, + Dir, + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt + (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_Downto_Node)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_To_Node)); + Finish_If_Stmt (If_Blk); + when others => + Error_Kind ("Create_Range_From_Array_Attribute_And_Length", + Array_Attr); + end case; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + -- Null range. + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), + M2E (Range_To_Right (Arr_Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + M2E (Range_To_Left (Arr_Rng))); + when Iir_Kind_Reverse_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), + M2E (Range_To_Left (Arr_Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + M2E (Range_To_Right (Arr_Rng))); + when others => + raise Internal_Error; + end case; + + New_Else_Stmt (If_Blk); + + -- LEFT. + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + Left_Bound := Range_To_Left (Arr_Rng); + when Iir_Kind_Reverse_Range_Array_Attribute => + Left_Bound := Range_To_Right (Arr_Rng); + when others => + raise Internal_Error; + end case; + Stabilize (Left_Bound); + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), M2E (Left_Bound)); + + -- RIGHT. + Diff := Create_Temp_Init + (Iinfo.Ortho_Type (Mode_Value), + New_Convert_Ov + (New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_1)), + Iinfo.Ortho_Type (Mode_Value))); + + Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, + M2E (Range_To_Dir (Res)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + New_Dyadic_Op (ON_Add_Ov, + M2E (Left_Bound), + New_Obj_Value (Diff))); + New_Else_Stmt (If_Blk1); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Left_Bound), + New_Obj_Value (Diff))); + Finish_If_Stmt (If_Blk1); + + -- FIXME: check right bounds is inside bounds. + Finish_If_Stmt (If_Blk); + Close_Temp; + end Create_Range_From_Array_Attribute_And_Length; + + procedure Create_Range_From_Length + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir) + is + Iinfo : constant Type_Info_Acc := Get_Info (Index_Type); + Range_Constr : constant Iir := Get_Range_Constraint (Index_Type); + Op : ON_Op_Kind; + Diff : O_Enode; + Left_Bound : O_Enode; + Var_Right : O_Dnode; + If_Blk : O_If_Block; + begin + if Get_Kind (Range_Constr) /= Iir_Kind_Range_Expression then + Create_Range_From_Array_Attribute_And_Length + (Range_Constr, Length, Range_Ptr); + return; + end if; + + Start_Declare_Stmt; + New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), + O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Length), + New_Obj_Value (Length)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Dir), + New_Lit (Chap7.Translate_Static_Range_Dir (Range_Constr))); + + case Get_Direction (Range_Constr) is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + -- Null range. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), + Chap7.Translate_Range_Expression_Right (Range_Constr, Index_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), + Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); + + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), + Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); + Left_Bound := Chap7.Translate_Range_Expression_Left + (Range_Constr, Index_Type); + Diff := New_Convert_Ov + (New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_1)), + Iinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (Var_Right), + New_Dyadic_Op (Op, Left_Bound, Diff)); + + -- Check the right bounds is inside the bounds of the index type. + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Loc); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), + New_Obj_Value (Var_Right)); + Finish_If_Stmt (If_Blk); + Finish_Declare_Stmt; + end Create_Range_From_Length; + end Chap3; + + package body Chap4 is + -- Get the ortho type for an object of mode MODE. + function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) + return O_Tnode is + begin + if Is_Complex_Type (Tinfo) then + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + return Tinfo.Ortho_Type (Kind); + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Protected => + -- For a complex type, use a pointer. + return Tinfo.Ortho_Ptr_Type (Kind); + when others => + raise Internal_Error; + end case; + else + return Tinfo.Ortho_Type (Kind); + end if; + end Get_Object_Type; + + procedure Create_Object (El : Iir) + is + Obj_Type : O_Tnode; + Info : Object_Info_Acc; + Tinfo : Type_Info_Acc; + Def : Iir; + Val : Iir; + Storage : O_Storage; + Deferred : Iir; + begin + Def := Get_Type (El); + Val := Get_Default_Value (El); + + -- Be sure the object type was translated. + if Get_Kind (El) = Iir_Kind_Constant_Declaration + and then Get_Deferred_Declaration_Flag (El) = False + and then Get_Deferred_Declaration (El) /= Null_Iir + then + -- This is a full constant declaration which complete a previous + -- incomplete constant declaration. + -- + -- Do not create the subtype of this full constant declaration, + -- since it was already created by the deferred declaration. + -- Use the type of the deferred declaration. + Deferred := Get_Deferred_Declaration (El); + Def := Get_Type (Deferred); + Info := Get_Info (Deferred); + Set_Info (El, Info); + else + Chap3.Translate_Object_Subtype (El); + Info := Add_Info (El, Kind_Object); + end if; + + Tinfo := Get_Info (Def); + Obj_Type := Get_Object_Type (Tinfo, Mode_Value); + + case Get_Kind (El) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration => + Info.Object_Var := + Create_Var (Create_Var_Identifier (El), Obj_Type); + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration (El) /= Null_Iir then + -- This is a full constant declaration (in a body) of a + -- deferred constant declaration (in a package). + Storage := O_Storage_Public; + else + Storage := Global_Storage; + end if; + if Info.Object_Var = Null_Var then + -- Not a full constant declaration (ie a value for an + -- already declared constant). + -- Must create the declaration. + if Chap7.Is_Static_Constant (El) then + Info.Object_Static := True; + Info.Object_Var := Create_Global_Const + (Create_Identifier (El), Obj_Type, Global_Storage, + O_Cnode_Null); + else + Info.Object_Static := False; + Info.Object_Var := Create_Var + (Create_Var_Identifier (El), + Obj_Type, Global_Storage); + end if; + end if; + if Get_Deferred_Declaration (El) = Null_Iir + and then Info.Object_Static + and then Storage /= O_Storage_External + then + -- Deferred constant are never considered as locally static. + -- FIXME: to be improved ? + + -- open_temp/close_temp only required for transient types. + Open_Temp; + Define_Global_Const + (Info.Object_Var, + Chap7.Translate_Static_Expression (Val, Def)); + Close_Temp; + end if; + when others => + Error_Kind ("create_objet", El); + end case; + end Create_Object; + + procedure Create_Signal (Decl : Iir) + is + Sig_Type_Def : constant Iir := Get_Type (Decl); + Sig_Type : O_Tnode; + Type_Info : Type_Info_Acc; + Info : Ortho_Info_Acc; + begin + Chap3.Translate_Object_Subtype (Decl); + + Type_Info := Get_Info (Sig_Type_Def); + Sig_Type := Get_Object_Type (Type_Info, Mode_Signal); + pragma Assert (Sig_Type /= O_Tnode_Null); + + Info := Add_Info (Decl, Kind_Object); + + Info.Object_Var := + Create_Var (Create_Var_Identifier (Decl), Sig_Type); + + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Rtis.Generate_Signal_Rti (Decl); + when Iir_Kind_Guard_Signal_Declaration => + -- No name created for guard signal. + null; + when others => + Error_Kind ("create_signal", Decl); + end case; + end Create_Signal; + + procedure Create_Implicit_Signal (Decl : Iir) + is + Sig_Type : O_Tnode; + Type_Info : Type_Info_Acc; + Info : Ortho_Info_Acc; + Sig_Type_Def : Iir; + begin + Sig_Type_Def := Get_Type (Decl); + -- This has been disabled since DECL can have an anonymous subtype, + -- and DECL has no identifiers, which causes translate_object_subtype + -- to crash. + -- Note: DECL can only be a iir_kind_delayed_attribute. + --Chap3.Translate_Object_Subtype (Decl); + Type_Info := Get_Info (Sig_Type_Def); + Sig_Type := Type_Info.Ortho_Type (Mode_Signal); + if Sig_Type = O_Tnode_Null then + raise Internal_Error; + end if; + + Info := Add_Info (Decl, Kind_Object); + + Info.Object_Var := Create_Var (Create_Uniq_Identifier, Sig_Type); + end Create_Implicit_Signal; + + procedure Create_File_Object (El : Iir_File_Declaration) + is + Obj_Type : O_Tnode; + Info : Ortho_Info_Acc; + Obj_Type_Def : Iir; + begin + Obj_Type_Def := Get_Type (El); + Obj_Type := Get_Ortho_Type (Obj_Type_Def, Mode_Value); + + Info := Add_Info (El, Kind_Object); + + Info.Object_Var := Create_Var (Create_Var_Identifier (El), Obj_Type); + end Create_File_Object; + + procedure Create_Package_Interface (Inter : Iir) + is + Info : Ortho_Info_Acc; + Pkg : constant Iir := Get_Named_Entity + (Get_Uninstantiated_Package_Name (Inter)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Pkg); + begin + Chap2.Instantiate_Info_Package (Inter); + Info := Get_Info (Inter); + + -- The spec + Info.Package_Instance_Spec_Var := + Create_Var (Create_Var_Identifier (Inter, "SPEC", 0), + Pkg_Info.Package_Spec_Ptr_Type); + Set_Scope_Via_Var_Ptr + (Info.Package_Instance_Spec_Scope, + Info.Package_Instance_Spec_Var); + + -- The body + Info.Package_Instance_Body_Var := + Create_Var (Create_Var_Identifier (Inter, "BODY", 0), + Pkg_Info.Package_Body_Ptr_Type); + Set_Scope_Via_Var_Ptr + (Info.Package_Instance_Body_Scope, + Info.Package_Instance_Body_Var); + end Create_Package_Interface; + + procedure Allocate_Complex_Object (Obj_Type : Iir; + Alloc_Kind : Allocation_Kind; + Var : in out Mnode) + is + Type_Info : constant Type_Info_Acc := Get_Type_Info (Var); + Kind : constant Object_Kind_Type := Get_Object_Kind (Var); + Targ : Mnode; + begin + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Cannot allocate unconstrained object (since size is unknown). + raise Internal_Error; + end if; + + if not Is_Complex_Type (Type_Info) then + -- Object is not complex. + return; + end if; + + if Type_Info.C (Kind).Builder_Need_Func + and then not Is_Stable (Var) + then + Targ := Create_Temp (Type_Info, Kind); + else + Targ := Var; + end if; + + -- Allocate variable. + New_Assign_Stmt + (M2Lp (Targ), + Gen_Alloc (Alloc_Kind, + Chap3.Get_Object_Size (Var, Obj_Type), + Type_Info.Ortho_Ptr_Type (Kind))); + + if Type_Info.C (Kind).Builder_Need_Func then + -- Build the type. + Chap3.Gen_Call_Type_Builder (Targ, Obj_Type); + if not Is_Stable (Var) then + New_Assign_Stmt (M2Lp (Var), M2Addr (Targ)); + Var := Targ; + end if; + end if; + end Allocate_Complex_Object; + + -- Note : OBJ can be a tree. + -- FIXME: should use translate_aggregate_others. + procedure Init_Array_Object (Obj : Mnode; Obj_Type : Iir) + is + Sobj : Mnode; + + -- Type of the object. + Type_Info : Type_Info_Acc; + + -- Iterator for the elements. + Index : O_Dnode; + + Upper_Limit : O_Enode; + Upper_Var : O_Dnode; + + Label : O_Snode; + begin + Type_Info := Get_Info (Obj_Type); + + -- Iterate on all elements of the object. + Open_Temp; + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Sobj := Stabilize (Obj); + else + Sobj := Obj; + end if; + Upper_Limit := Chap3.Get_Array_Length (Sobj, Obj_Type); + + if Type_Info.Type_Mode /= Type_Mode_Array then + Upper_Var := Create_Temp_Init (Ghdl_Index_Type, Upper_Limit); + else + Upper_Var := O_Dnode_Null; + end if; + + Index := Create_Temp (Ghdl_Index_Type); + Init_Var (Index); + Start_Loop_Stmt (Label); + if Upper_Var /= O_Dnode_Null then + Upper_Limit := New_Obj_Value (Upper_Var); + end if; + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Index), Upper_Limit, + Ghdl_Bool_Type)); + Init_Object (Chap3.Index_Base (Chap3.Get_Array_Base (Sobj), + Obj_Type, + New_Obj_Value (Index)), + Get_Element_Subtype (Obj_Type)); + Inc_Var (Index); + Finish_Loop_Stmt (Label); + + Close_Temp; + end Init_Array_Object; + + procedure Init_Protected_Object (Obj : Mnode; Obj_Type : Iir) + is + Assoc : O_Assoc_List; + Info : Type_Info_Acc; + begin + Info := Get_Info (Obj_Type); + + -- Call the initializer. + Start_Association (Assoc, Info.T.Prot_Init_Subprg); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance); + -- Use of M2Lp is a little bit fragile (not sure we get the + -- variable, but should work: we didn't stabilize it). + New_Assign_Stmt (M2Lp (Obj), New_Function_Call (Assoc)); + end Init_Protected_Object; + + procedure Fini_Protected_Object (Decl : Iir) + is + Obj : Mnode; + Assoc : O_Assoc_List; + Info : Type_Info_Acc; + begin + Info := Get_Info (Get_Type (Decl)); + + Obj := Chap6.Translate_Name (Decl); + -- Call the Finalizator. + Start_Association (Assoc, Info.T.Prot_Final_Subprg); + New_Association (Assoc, M2E (Obj)); + New_Procedure_Call (Assoc); + end Fini_Protected_Object; + + procedure Init_Object (Obj : Mnode; Obj_Type : Iir) + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (Obj); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + New_Assign_Stmt + (M2Lv (Obj), Chap14.Translate_Left_Type_Attribute (Obj_Type)); + when Type_Mode_Acc => + New_Assign_Stmt + (M2Lv (Obj), + New_Lit (New_Null_Access (Tinfo.Ortho_Type (Mode_Value)))); + when Type_Mode_Fat_Acc => + declare + Dinfo : Type_Info_Acc; + Sobj : Mnode; + begin + Open_Temp; + Sobj := Stabilize (Obj); + Dinfo := Get_Info (Get_Designated_Type (Obj_Type)); + New_Assign_Stmt + (New_Selected_Element (M2Lv (Sobj), + Dinfo.T.Bounds_Field (Mode_Value)), + New_Lit (New_Null_Access (Dinfo.T.Bounds_Ptr_Type))); + New_Assign_Stmt + (New_Selected_Element (M2Lv (Sobj), + Dinfo.T.Base_Field (Mode_Value)), + New_Lit (New_Null_Access + (Dinfo.T.Base_Ptr_Type (Mode_Value)))); + Close_Temp; + end; + when Type_Mode_Arrays => + Init_Array_Object (Obj, Obj_Type); + when Type_Mode_Record => + declare + Sobj : Mnode; + El : Iir_Element_Declaration; + List : Iir_List; + begin + Open_Temp; + Sobj := Stabilize (Obj); + List := Get_Elements_Declaration_List + (Get_Base_Type (Obj_Type)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Init_Object (Chap6.Translate_Selected_Element (Sobj, El), + Get_Type (El)); + end loop; + Close_Temp; + end; + when Type_Mode_Protected => + Init_Protected_Object (Obj, Obj_Type); + when Type_Mode_Unknown + | Type_Mode_File => + raise Internal_Error; + end case; + end Init_Object; + + procedure Elab_Object_Storage (Obj : Iir) + is + Obj_Type : constant Iir := Get_Type (Obj); + Obj_Info : constant Object_Info_Acc := Get_Info (Obj); + + Name_Node : Mnode; + + Type_Info : Type_Info_Acc; + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Chap3.Elab_Object_Subtype (Obj_Type); + + Type_Info := Get_Info (Obj_Type); + + -- FIXME: the object type may be a fat array! + -- FIXME: fat array + aggregate ? + + if Type_Info.Type_Mode = Type_Mode_Protected then + -- Protected object will be created by its INIT function. + return; + end if; + + if Is_Complex_Type (Type_Info) + and then Type_Info.Type_Mode /= Type_Mode_Fat_Array + then + -- FIXME: avoid allocation if the value is a string and + -- the object is a constant + Name_Node := Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value); + Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); + Allocate_Complex_Object (Obj_Type, Alloc_Kind, Name_Node); + end if; + end Elab_Object_Storage; + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir) + is + Obj_Type : constant Iir := Get_Type (Obj); + Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type); + Obj_Info : constant Object_Info_Acc := Get_Info (Obj); + + Name_Node : Mnode; + Value_Node : O_Enode; + + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); + + -- Note: no temporary variable region is created, as the allocation + -- may be performed on the stack. + + if Value = Null_Iir then + -- Performs default initialization. + Open_Temp; + Init_Object (Name, Obj_Type); + Close_Temp; + elsif Get_Kind (Value) = Iir_Kind_Aggregate then + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Allocate. + declare + Aggr_Type : Iir; + begin + Aggr_Type := Get_Type (Value); + Chap3.Create_Array_Subtype (Aggr_Type, True); + Name_Node := Stabilize (Name); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), + M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type))); + Chap3.Allocate_Fat_Array_Base + (Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type)); + end; + else + Name_Node := Name; + end if; + Chap7.Translate_Aggregate (Name_Node, Obj_Type, Value); + else + Value_Node := Chap7.Translate_Expression (Value, Obj_Type); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + declare + S : Mnode; + begin + Name_Node := Stabilize (Name); + S := Stabilize (E2M (Value_Node, Type_Info, Mode_Value)); + + if Get_Kind (Value) = Iir_Kind_String_Literal + and then Get_Kind (Obj) = Iir_Kind_Constant_Declaration + then + -- No need to allocate space for the object. + Copy_Fat_Pointer (Name_Node, S); + else + Chap3.Translate_Object_Allocation + (Name_Node, Alloc_Kind, Obj_Type, + Chap3.Get_Array_Bounds (S)); + Chap3.Translate_Object_Copy + (Name_Node, M2Addr (S), Obj_Type); + end if; + end; + else + Chap3.Translate_Object_Copy (Name, Value_Node, Obj_Type); + end if; + Destroy_Local_Transient_Types; + end if; + end Elab_Object_Init; + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Value (Obj : Iir; Value : Iir) + is + Name : Mnode; + begin + Elab_Object_Storage (Obj); + Name := Get_Var (Get_Info (Obj).Object_Var, + Get_Info (Get_Type (Obj)), Mode_Value); + Elab_Object_Init (Name, Obj, Value); + end Elab_Object_Value; + + -- Create code to elaborate OBJ. + procedure Elab_Object (Obj : Iir) + is + Value : Iir; + Obj1 : Iir; + begin + -- A locally static constant is pre-elaborated. + -- (only constant can be locally static). + if Get_Expr_Staticness (Obj) = Locally + and then Get_Deferred_Declaration (Obj) = Null_Iir + then + return; + end if; + + -- Set default value. + if Get_Kind (Obj) = Iir_Kind_Constant_Declaration then + if Get_Info (Obj).Object_Static then + return; + end if; + if Get_Deferred_Declaration_Flag (Obj) then + -- No code generation for a deferred constant. + return; + end if; + Obj1 := Get_Deferred_Declaration (Obj); + if Obj1 = Null_Iir then + Obj1 := Obj; + end if; + else + Obj1 := Obj; + end if; + + New_Debug_Line_Stmt (Get_Line_Number (Obj)); + + -- Still use the default value of the not deferred constant. + -- FIXME: what about composite types. + Value := Get_Default_Value (Obj); + Elab_Object_Value (Obj1, Value); + end Elab_Object; + + procedure Fini_Object (Obj : Iir) + is + Obj_Type : Iir; + Type_Info : Type_Info_Acc; + begin + Obj_Type := Get_Type (Obj); + Type_Info := Get_Info (Obj_Type); + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + declare + V : Mnode; + begin + Open_Temp; + V := Chap6.Translate_Name (Obj); + Stabilize (V); + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap3.Get_Array_Bounds (V)))); + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap3.Get_Array_Base (V)))); + Close_Temp; + end; + elsif Is_Complex_Type (Type_Info) then + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap6.Translate_Name (Obj)))); + end if; + end Fini_Object; + + function Get_Nbr_Signals (Sig : Mnode; Sig_Type : Iir) return O_Enode + is + Info : constant Type_Info_Acc := Get_Info (Sig_Type); + begin + case Info.Type_Mode is + when Type_Mode_Scalar => + -- Note: here we discard SIG... + return New_Lit (Ghdl_Index_1); + when Type_Mode_Arrays => + declare + Len : O_Dnode; + If_Blk : O_If_Block; + Ssig : Mnode; + begin + Ssig := Stabilize (Sig); + Len := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Array_Length (Ssig, Sig_Type)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Neq, + New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Len), + New_Dyadic_Op + (ON_Mul_Ov, + New_Obj_Value (Len), + Get_Nbr_Signals + (Chap3.Index_Base + (Chap3.Get_Array_Base (Ssig), Sig_Type, + New_Lit (Ghdl_Index_0)), + Get_Element_Subtype (Sig_Type)))); + Finish_If_Stmt (If_Blk); + + return New_Obj_Value (Len); + end; + when Type_Mode_Record => + declare + List : Iir_List; + El : Iir; + Res : O_Enode; + E : O_Enode; + Sig_El : Mnode; + Ssig : Mnode; + begin + List := + Get_Elements_Declaration_List (Get_Base_Type (Sig_Type)); + Ssig := Stabilize (Sig); + Res := O_Enode_Null; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Sig_El := Chap6.Translate_Selected_Element (Ssig, El); + E := Get_Nbr_Signals (Sig_El, Get_Type (El)); + if Res /= O_Enode_Null then + Res := New_Dyadic_Op (ON_Add_Ov, Res, E); + else + Res := E; + end if; + end loop; + if Res = O_Enode_Null then + -- Empty records. + Res := New_Lit (Ghdl_Index_0); + end if; + return Res; + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Get_Nbr_Signals; + + -- Get the leftest signal of SIG. + -- The leftest signal of + -- a scalar signal is itself, + -- an array signal is the leftest, + -- a record signal is the first element. + function Get_Leftest_Signal (Sig: Mnode; Sig_Type : Iir) + return Mnode + is + Res : Mnode; + Res_Type : Iir; + Info : Type_Info_Acc; + begin + Res := Sig; + Res_Type := Sig_Type; + loop + Info := Get_Type_Info (Res); + case Info.Type_Mode is + when Type_Mode_Scalar => + return Res; + when Type_Mode_Arrays => + Res := Chap3.Index_Base + (Chap3.Get_Array_Base (Res), Res_Type, + New_Lit (Ghdl_Index_0)); + Res_Type := Get_Element_Subtype (Res_Type); + when Type_Mode_Record => + declare + Element : Iir; + begin + Element := Get_First_Element + (Get_Elements_Declaration_List + (Get_Base_Type (Res_Type))); + Res := Chap6.Translate_Selected_Element (Res, Element); + Res_Type := Get_Type (Element); + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end loop; + end Get_Leftest_Signal; + + -- Add func and instance. + procedure Add_Associations_For_Resolver + (Assoc : in out O_Assoc_List; Func_Decl : Iir) + is + Func_Info : constant Subprg_Info_Acc := Get_Info (Func_Decl); + Resolv_Info : constant Subprg_Resolv_Info_Acc := + Func_Info.Subprg_Resolv; + Val : O_Enode; + begin + New_Association + (Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func, + Ghdl_Ptr_Type))); + if Chap2.Has_Subprg_Instance (Resolv_Info.Var_Instance) then + Val := New_Convert_Ov + (Chap2.Get_Subprg_Instance (Resolv_Info.Var_Instance), + Ghdl_Ptr_Type); + else + Val := New_Lit (New_Null_Access (Ghdl_Ptr_Type)); + end if; + New_Association (Assoc, Val); + end Add_Associations_For_Resolver; + + type O_If_Block_Acc is access O_If_Block; + + type Elab_Signal_Data is record + -- Default value of the signal. + Val : Mnode; + -- If statement for a block of signals. + If_Stmt : O_If_Block_Acc; + -- True if the default value is set. + Has_Val : Boolean; + -- True if a resolution function was already attached. + Already_Resolved : Boolean; + -- True if the signal may already have been created. + Check_Null : Boolean; + end record; + + procedure Elab_Signal_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Elab_Signal_Data) + is + Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type); + Create_Subprg : O_Dnode; + Conv : O_Tnode; + Res : O_Enode; + Assoc : O_Assoc_List; + Init_Val : O_Enode; + -- For the resolution function (if any). + Func : Iir; + If_Stmt : O_If_Block; + Targ_Ptr : O_Dnode; + begin + if Data.Check_Null then + Targ_Ptr := Create_Temp_Init + (Ghdl_Signal_Ptr_Ptr, + New_Unchecked_Address (M2Lv (Targ), Ghdl_Signal_Ptr_Ptr)); + Start_If_Stmt + (If_Stmt, + New_Compare_Op (ON_Eq, + New_Value (New_Acc_Value (New_Obj (Targ_Ptr))), + New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), + Ghdl_Bool_Type)); + end if; + + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Create_Subprg := Ghdl_Create_Signal_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Create_Subprg := Ghdl_Create_Signal_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Create_Subprg := Ghdl_Create_Signal_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Create_Subprg := Ghdl_Create_Signal_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Create_Subprg := Ghdl_Create_Signal_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Create_Subprg := Ghdl_Create_Signal_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("elab_signal_non_composite", Targ_Type); + end case; + + if Data.Has_Val then + Init_Val := M2E (Data.Val); + else + Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); + end if; + + Start_Association (Assoc, Create_Subprg); + New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); + + if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then + Func := Has_Resolution_Function (Targ_Type); + else + Func := Null_Iir; + end if; + if Func /= Null_Iir and then not Data.Already_Resolved then + Add_Associations_For_Resolver (Assoc, Func); + else + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end if; + + Res := New_Function_Call (Assoc); + + if Data.Check_Null then + New_Assign_Stmt (New_Acc_Value (New_Obj (Targ_Ptr)), Res); + Finish_If_Stmt (If_Stmt); + else + New_Assign_Stmt + (M2Lv (Targ), + New_Convert_Ov (Res, Type_Info.Ortho_Type (Mode_Signal))); + end if; + end Elab_Signal_Non_Composite; + + function Elab_Signal_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Elab_Signal_Data) + return Elab_Signal_Data + is + Assoc : O_Assoc_List; + Func : Iir; + Res : Elab_Signal_Data; + begin + Res := Data; + if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then + Func := Has_Resolution_Function (Targ_Type); + if Func /= Null_Iir and then not Data.Already_Resolved then + if Data.Check_Null then + Res.If_Stmt := new O_If_Block; + Start_If_Stmt + (Res.If_Stmt.all, + New_Compare_Op + (ON_Eq, + New_Convert_Ov (M2E (Get_Leftest_Signal (Targ, + Targ_Type)), + Ghdl_Signal_Ptr), + New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), + Ghdl_Bool_Type)); + --Res.Check_Null := False; + end if; + -- Add resolver. + Start_Association (Assoc, Ghdl_Signal_Create_Resolution); + Add_Associations_For_Resolver (Assoc, Func); + New_Association + (Assoc, New_Convert_Ov (M2Addr (Targ), Ghdl_Ptr_Type)); + New_Association (Assoc, Get_Nbr_Signals (Targ, Targ_Type)); + New_Procedure_Call (Assoc); + Res.Already_Resolved := True; + end if; + end if; + if Data.Has_Val then + if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then + Res.Val := Stabilize (Data.Val); + else + Res.Val := Chap3.Get_Array_Base (Data.Val); + end if; + end if; + return Res; + end Elab_Signal_Prepare_Composite; + + procedure Elab_Signal_Finish_Composite (Data : in out Elab_Signal_Data) + is + procedure Free is new Ada.Unchecked_Deallocation + (Object => O_If_Block, Name => O_If_Block_Acc); + begin + if Data.If_Stmt /= null then + Finish_If_Stmt (Data.If_Stmt.all); + Free (Data.If_Stmt); + end if; + end Elab_Signal_Finish_Composite; + + function Elab_Signal_Update_Array (Data : Elab_Signal_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Elab_Signal_Data + is + begin + if not Data.Has_Val then + return Data; + else + return Elab_Signal_Data' + (Val => Chap3.Index_Base (Data.Val, Targ_Type, + New_Obj_Value (Index)), + Has_Val => True, + If_Stmt => null, + Already_Resolved => Data.Already_Resolved, + Check_Null => Data.Check_Null); + end if; + end Elab_Signal_Update_Array; + + function Elab_Signal_Update_Record (Data : Elab_Signal_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Elab_Signal_Data + is + pragma Unreferenced (Targ_Type); + begin + if not Data.Has_Val then + return Data; + else + return Elab_Signal_Data' + (Val => Chap6.Translate_Selected_Element (Data.Val, El), + Has_Val => True, + If_Stmt => null, + Already_Resolved => Data.Already_Resolved, + Check_Null => Data.Check_Null); + end if; + end Elab_Signal_Update_Record; + + procedure Elab_Signal is new Foreach_Non_Composite + (Data_Type => Elab_Signal_Data, + Composite_Data_Type => Elab_Signal_Data, + Do_Non_Composite => Elab_Signal_Non_Composite, + Prepare_Data_Array => Elab_Signal_Prepare_Composite, + Update_Data_Array => Elab_Signal_Update_Array, + Finish_Data_Array => Elab_Signal_Finish_Composite, + Prepare_Data_Record => Elab_Signal_Prepare_Composite, + Update_Data_Record => Elab_Signal_Update_Record, + Finish_Data_Record => Elab_Signal_Finish_Composite); + + -- Elaborate signal subtypes and allocate the storage for the object. + procedure Elab_Signal_Declaration_Storage (Decl : Iir) + is + Sig_Type : Iir; + Type_Info : Type_Info_Acc; + Name_Node : Mnode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Open_Temp; + + Sig_Type := Get_Type (Decl); + Chap3.Elab_Object_Subtype (Sig_Type); + Type_Info := Get_Info (Sig_Type); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Name_Node := Chap6.Translate_Name (Decl); + Name_Node := Stabilize (Name_Node); + Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); + elsif Is_Complex_Type (Type_Info) then + Name_Node := Chap6.Translate_Name (Decl); + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + end if; + + Close_Temp; + end Elab_Signal_Declaration_Storage; + + function Has_Direct_Driver (Sig : Iir) return Boolean + is + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Get_Object_Prefix (Sig)); + return Info.Kind = Kind_Object + and then Info.Object_Driver /= Null_Var; + end Has_Direct_Driver; + + procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir) + is + Sig_Type : constant Iir := Get_Type (Decl); + Sig_Info : constant Ortho_Info_Acc := Get_Info (Decl); + Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type); + Name_Node : Mnode; + begin + Open_Temp; + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Name_Node := Get_Var (Sig_Info.Object_Driver, + Type_Info, Mode_Value); + Name_Node := Stabilize (Name_Node); + -- Copy bounds from signal. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), + M2Addr (Chap3.Get_Array_Bounds (Chap6.Translate_Name (Decl)))); + -- Allocate base. + Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); + elsif Is_Complex_Type (Type_Info) then + Name_Node := Get_Var (Sig_Info.Object_Driver, + Type_Info, Mode_Value); + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + end if; + + Close_Temp; + end Elab_Direct_Driver_Declaration_Storage; + + -- Create signal object. + -- Note: SIG can be a signal sub-element (used when signals are + -- collapsed). + -- If CHECK_NULL is TRUE, create the signal only if it was not yet + -- created. + procedure Elab_Signal_Declaration_Object + (Sig : Iir; Parent : Iir; Check_Null : Boolean) + is + Decl : constant Iir := Strip_Denoting_Name (Sig); + Sig_Type : constant Iir := Get_Type (Sig); + Base_Decl : constant Iir := Get_Object_Prefix (Sig); + Name_Node : Mnode; + Val : Iir; + Data : Elab_Signal_Data; + begin + New_Debug_Line_Stmt (Get_Line_Number (Sig)); + + Open_Temp; + + -- Set the name of the signal. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Name_Rti); + New_Association + (Assoc, + New_Lit (New_Global_Unchecked_Address + (Get_Info (Base_Decl).Object_Rti, + Rtis.Ghdl_Rti_Access))); + Rtis.Associate_Rti_Context (Assoc, Parent); + New_Procedure_Call (Assoc); + end; + + Name_Node := Chap6.Translate_Name (Decl); + if Get_Object_Kind (Name_Node) /= Mode_Signal then + raise Internal_Error; + end if; + + if Decl = Base_Decl then + Data.Already_Resolved := False; + Data.Check_Null := Check_Null; + Val := Get_Default_Value (Base_Decl); + if Val = Null_Iir then + Data.Has_Val := False; + else + Data.Has_Val := True; + Data.Val := E2M (Chap7.Translate_Expression (Val, Sig_Type), + Get_Info (Sig_Type), + Mode_Value); + end if; + else + -- Sub signal. + -- Do not add resolver. + -- Do not use default value. + Data.Already_Resolved := True; + Data.Has_Val := False; + Data.Check_Null := False; + end if; + Elab_Signal (Name_Node, Sig_Type, Data); + + Close_Temp; + end Elab_Signal_Declaration_Object; + + procedure Elab_Signal_Declaration + (Decl : Iir; Parent : Iir; Check_Null : Boolean) + is + begin + Elab_Signal_Declaration_Storage (Decl); + Elab_Signal_Declaration_Object (Decl, Parent, Check_Null); + end Elab_Signal_Declaration; + + procedure Elab_Signal_Attribute (Decl : Iir) + is + Assoc : O_Assoc_List; + Dtype : Iir; + Type_Info : Type_Info_Acc; + Info : Object_Info_Acc; + Prefix : Iir; + Prefix_Node : Mnode; + Res : O_Enode; + Val : O_Enode; + Param : Iir; + Subprg : O_Dnode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Info := Get_Info (Decl); + Dtype := Get_Type (Decl); + Type_Info := Get_Info (Dtype); + -- Create the signal (with the time) + case Get_Kind (Decl) is + when Iir_Kind_Stable_Attribute => + Subprg := Ghdl_Create_Stable_Signal; + when Iir_Kind_Quiet_Attribute => + Subprg := Ghdl_Create_Quiet_Signal; + when Iir_Kind_Transaction_Attribute => + Subprg := Ghdl_Create_Transaction_Signal; + when others => + Error_Kind ("elab_signal_attribute", Decl); + end case; + Start_Association (Assoc, Subprg); + case Get_Kind (Decl) is + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute => + Param := Get_Parameter (Decl); + if Param = Null_Iir then + Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); + else + Val := Chap7.Translate_Expression (Param); + end if; + New_Association (Assoc, Val); + when others => + null; + end case; + Res := New_Convert_Ov (New_Function_Call (Assoc), + Type_Info.Ortho_Type (Mode_Signal)); + New_Assign_Stmt (Get_Var (Info.Object_Var), Res); + + -- Register all signals this depends on. + Prefix := Get_Prefix (Decl); + Prefix_Node := Chap6.Translate_Name (Prefix); + Register_Signal (Prefix_Node, Get_Type (Prefix), + Ghdl_Signal_Attribute_Register_Prefix); + end Elab_Signal_Attribute; + + type Delayed_Signal_Data is record + Pfx : Mnode; + Param : Iir; + end record; + + procedure Create_Delayed_Signal_Noncomposite + (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) + is + pragma Unreferenced (Targ_Type); + Assoc : O_Assoc_List; + Type_Info : Type_Info_Acc; + Val : O_Enode; + begin + Start_Association (Assoc, Ghdl_Create_Delayed_Signal); + New_Association + (Assoc, + New_Convert_Ov (New_Value (M2Lv (Data.Pfx)), Ghdl_Signal_Ptr)); + if Data.Param = Null_Iir then + Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); + else + Val := Chap7.Translate_Expression (Data.Param); + end if; + New_Association (Assoc, Val); + Type_Info := Get_Type_Info (Targ); + New_Assign_Stmt + (M2Lv (Targ), + New_Convert_Ov (New_Function_Call (Assoc), + Type_Info.Ortho_Type (Mode_Signal))); + end Create_Delayed_Signal_Noncomposite; + + function Create_Delayed_Signal_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) + return Delayed_Signal_Data + is + pragma Unreferenced (Targ_Type); + Res : Delayed_Signal_Data; + begin + Res.Param := Data.Param; + if Get_Type_Info (Targ).Type_Mode = Type_Mode_Record then + Res.Pfx := Stabilize (Data.Pfx); + else + Res.Pfx := Chap3.Get_Array_Base (Data.Pfx); + end if; + return Res; + end Create_Delayed_Signal_Prepare_Composite; + + function Create_Delayed_Signal_Update_Data_Array + (Data : Delayed_Signal_Data; Targ_Type : Iir; Index : O_Dnode) + return Delayed_Signal_Data + is + begin + return Delayed_Signal_Data' + (Pfx => Chap3.Index_Base (Data.Pfx, Targ_Type, + New_Obj_Value (Index)), + Param => Data.Param); + end Create_Delayed_Signal_Update_Data_Array; + + function Create_Delayed_Signal_Update_Data_Record + (Data : Delayed_Signal_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Delayed_Signal_Data + is + pragma Unreferenced (Targ_Type); + begin + return Delayed_Signal_Data' + (Pfx => Chap6.Translate_Selected_Element (Data.Pfx, El), + Param => Data.Param); + end Create_Delayed_Signal_Update_Data_Record; + + procedure Create_Delayed_Signal_Finish_Data_Composite + (Data : in out Delayed_Signal_Data) + is + pragma Unreferenced (Data); + begin + null; + end Create_Delayed_Signal_Finish_Data_Composite; + + procedure Create_Delayed_Signal is new Foreach_Non_Composite + (Data_Type => Delayed_Signal_Data, + Composite_Data_Type => Delayed_Signal_Data, + Do_Non_Composite => Create_Delayed_Signal_Noncomposite, + Prepare_Data_Array => Create_Delayed_Signal_Prepare_Composite, + Update_Data_Array => Create_Delayed_Signal_Update_Data_Array, + Finish_Data_Array => Create_Delayed_Signal_Finish_Data_Composite, + Prepare_Data_Record => Create_Delayed_Signal_Prepare_Composite, + Update_Data_Record => Create_Delayed_Signal_Update_Data_Record, + Finish_Data_Record => Create_Delayed_Signal_Finish_Data_Composite); + + procedure Elab_Signal_Delayed_Attribute (Decl : Iir) + is + Name_Node : Mnode; + Sig_Type : Iir; + Type_Info : Type_Info_Acc; + Pfx_Node : Mnode; + Data: Delayed_Signal_Data; + begin + Name_Node := Chap6.Translate_Name (Decl); + Sig_Type := Get_Type (Decl); + Type_Info := Get_Info (Sig_Type); + + if Is_Complex_Type (Type_Info) then + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + -- We cannot stabilize NAME_NODE, since Allocate_Complex_Object + -- assign it. + Name_Node := Chap6.Translate_Name (Decl); + end if; + + Pfx_Node := Chap6.Translate_Name (Get_Prefix (Decl)); + Data := Delayed_Signal_Data'(Pfx => Pfx_Node, + Param => Get_Parameter (Decl)); + + Create_Delayed_Signal (Name_Node, Get_Type (Decl), Data); + end Elab_Signal_Delayed_Attribute; + + procedure Elab_File_Declaration (Decl : Iir_File_Declaration) + is + Constr : O_Assoc_List; + Name : Mnode; + File_Name : Iir; + Open_Kind : Iir; + Mode_Val : O_Enode; + Str : O_Enode; + Is_Text : Boolean; + Info : Type_Info_Acc; + begin + -- Elaborate the file. + Name := Chap6.Translate_Name (Decl); + if Get_Object_Kind (Name) /= Mode_Value then + raise Internal_Error; + end if; + Is_Text := Get_Text_File_Flag (Get_Type (Decl)); + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Elaborate); + else + Start_Association (Constr, Ghdl_File_Elaborate); + Info := Get_Info (Get_Type (Decl)); + if Info.T.File_Signature /= O_Dnode_Null then + New_Association + (Constr, New_Address (New_Obj (Info.T.File_Signature), + Char_Ptr_Type)); + else + New_Association (Constr, + New_Lit (New_Null_Access (Char_Ptr_Type))); + end if; + end if; + New_Assign_Stmt (M2Lv (Name), New_Function_Call (Constr)); + + -- If file_open_information is present, open the file. + File_Name := Get_File_Logical_Name (Decl); + if File_Name = Null_Iir then + return; + end if; + Open_Temp; + Name := Chap6.Translate_Name (Decl); + Open_Kind := Get_File_Open_Kind (Decl); + if Open_Kind /= Null_Iir then + Mode_Val := New_Convert_Ov + (Chap7.Translate_Expression (Open_Kind), Ghdl_I32_Type); + else + case Get_Mode (Decl) is + when Iir_In_Mode => + Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0)); + when Iir_Out_Mode => + Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1)); + when others => + raise Internal_Error; + end case; + end if; + Str := Chap7.Translate_Expression (File_Name, String_Type_Definition); + + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Open); + else + Start_Association (Constr, Ghdl_File_Open); + end if; + New_Association (Constr, M2E (Name)); + New_Association (Constr, Mode_Val); + New_Association (Constr, Str); + New_Procedure_Call (Constr); + Close_Temp; + end Elab_File_Declaration; + + procedure Final_File_Declaration (Decl : Iir_File_Declaration) + is + Constr : O_Assoc_List; + Name : Mnode; + Is_Text : Boolean; + begin + Is_Text := Get_Text_File_Flag (Get_Type (Decl)); + + Open_Temp; + Name := Chap6.Translate_Name (Decl); + Stabilize (Name); + + -- LRM 3.4.1 File Operations + -- 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. + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Close); + else + Start_Association (Constr, Ghdl_File_Close); + end if; + New_Association (Constr, M2E (Name)); + New_Procedure_Call (Constr); + + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Finalize); + else + Start_Association (Constr, Ghdl_File_Finalize); + end if; + New_Association (Constr, M2E (Name)); + New_Procedure_Call (Constr); + + Close_Temp; + end Final_File_Declaration; + + procedure Translate_Type_Declaration (Decl : Iir) + is + begin + Chap3.Translate_Named_Type_Definition (Get_Type_Definition (Decl), + Get_Identifier (Decl)); + end Translate_Type_Declaration; + + procedure Translate_Anonymous_Type_Declaration (Decl : Iir) + is + Mark : Id_Mark_Type; + Mark1 : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark1, "BT"); + Chap3.Translate_Type_Definition (Get_Type_Definition (Decl)); + Pop_Identifier_Prefix (Mark1); + Pop_Identifier_Prefix (Mark); + end Translate_Anonymous_Type_Declaration; + + procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration) + is + begin + Chap3.Translate_Named_Type_Definition (Get_Type (Decl), + Get_Identifier (Decl)); + end Translate_Subtype_Declaration; + + procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Chap3.Translate_Bool_Type_Definition (Get_Type_Definition (Decl)); + Pop_Identifier_Prefix (Mark); + end Translate_Bool_Type_Declaration; + + procedure Translate_Object_Alias_Declaration + (Decl : Iir_Object_Alias_Declaration) + is + Decl_Type : Iir; + Info : Alias_Info_Acc; + Tinfo : Type_Info_Acc; + Atype : O_Tnode; + begin + Decl_Type := Get_Type (Decl); + + Chap3.Translate_Named_Type_Definition + (Decl_Type, Get_Identifier (Decl)); + + Info := Add_Info (Decl, Kind_Alias); + case Get_Kind (Get_Object_Prefix (Decl)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + Info.Alias_Kind := Mode_Signal; + when others => + Info.Alias_Kind := Mode_Value; + end case; + + Tinfo := Get_Info (Decl_Type); + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + -- create an object. + -- At elaboration: copy base from name, copy bounds from type, + -- check for matching bounds. + Atype := Get_Ortho_Type (Decl_Type, Info.Alias_Kind); + when Type_Mode_Array + | Type_Mode_Acc + | Type_Mode_Fat_Acc => + -- Create an object pointer. + -- At elaboration: copy base from name. + Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); + when Type_Mode_Scalar => + case Info.Alias_Kind is + when Mode_Signal => + Atype := Tinfo.Ortho_Type (Mode_Signal); + when Mode_Value => + Atype := Tinfo.Ortho_Ptr_Type (Mode_Value); + end case; + when Type_Mode_Record => + -- Create an object pointer. + -- At elaboration: copy base from name. + Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); + when others => + raise Internal_Error; + end case; + Info.Alias_Var := Create_Var (Create_Var_Identifier (Decl), Atype); + end Translate_Object_Alias_Declaration; + + procedure Elab_Object_Alias_Declaration + (Decl : Iir_Object_Alias_Declaration) + is + Decl_Type : Iir; + Name : Iir; + Name_Node : Mnode; + Alias_Node : Mnode; + Alias_Info : Alias_Info_Acc; + Name_Type : Iir; + Tinfo : Type_Info_Acc; + Kind : Object_Kind_Type; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Decl_Type := Get_Type (Decl); + Tinfo := Get_Info (Decl_Type); + + Alias_Info := Get_Info (Decl); + Chap3.Elab_Object_Subtype (Decl_Type); + Name := Get_Name (Decl); + Name_Type := Get_Type (Name); + Name_Node := Chap6.Translate_Name (Name); + Kind := Get_Object_Kind (Name_Node); + + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + Open_Temp; + Stabilize (Name_Node); + Alias_Node := Stabilize + (Get_Var (Alias_Info.Alias_Var, + Tinfo, Alias_Info.Alias_Kind)); + Copy_Fat_Pointer (Alias_Node, Name_Node); + Close_Temp; + when Type_Mode_Array => + Open_Temp; + Stabilize (Name_Node); + New_Assign_Stmt + (Get_Var (Alias_Info.Alias_Var), + M2E (Chap3.Get_Array_Base (Name_Node))); + Chap3.Check_Array_Match (Decl_Type, T2M (Decl_Type, Kind), + Name_Type, Name_Node, + Decl); + Close_Temp; + when Type_Mode_Acc + | Type_Mode_Fat_Acc => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + when Type_Mode_Scalar => + case Alias_Info.Alias_Kind is + when Mode_Value => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + when Mode_Signal => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2E (Name_Node)); + end case; + when Type_Mode_Record => + Open_Temp; + Stabilize (Name_Node); + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + Close_Temp; + when others => + raise Internal_Error; + end case; + end Elab_Object_Alias_Declaration; + + procedure Translate_Port_Chain (Parent : Iir) + is + Port : Iir; + begin + Port := Get_Port_Chain (Parent); + while Port /= Null_Iir loop + Create_Signal (Port); + Port := Get_Chain (Port); + end loop; + end Translate_Port_Chain; + + procedure Translate_Generic_Chain (Parent : Iir) + is + Decl : Iir; + begin + Decl := Get_Generic_Chain (Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kinds_Interface_Object_Declaration => + Create_Object (Decl); + when Iir_Kind_Interface_Package_Declaration => + Create_Package_Interface (Decl); + when others => + Error_Kind ("translate_generic_chain", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Translate_Generic_Chain; + + -- Create instance record for a component. + procedure Translate_Component_Declaration (Decl : Iir) + is + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Decl, Kind_Component); + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Instance_Factory (Info.Comp_Scope'Access); + + Info.Comp_Link := Add_Instance_Factory_Field + (Wki_Instance, Rtis.Ghdl_Component_Link_Type); + + -- Generic and ports. + Translate_Generic_Chain (Decl); + Translate_Port_Chain (Decl); + + Pop_Instance_Factory (Info.Comp_Scope'Access); + New_Type_Decl (Create_Identifier ("_COMPTYPE"), + Get_Scope_Type (Info.Comp_Scope)); + Info.Comp_Ptr_Type := New_Access_Type + (Get_Scope_Type (Info.Comp_Scope)); + New_Type_Decl (Create_Identifier ("_COMPPTR"), Info.Comp_Ptr_Type); + Pop_Identifier_Prefix (Mark); + end Translate_Component_Declaration; + + procedure Translate_Declaration (Decl : Iir) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + null; + + when Iir_Kind_Component_Declaration => + Chap4.Translate_Component_Declaration (Decl); + when Iir_Kind_Type_Declaration => + Chap4.Translate_Type_Declaration (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Chap4.Translate_Anonymous_Type_Declaration (Decl); + when Iir_Kind_Subtype_Declaration => + Chap4.Translate_Subtype_Declaration (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + raise Internal_Error; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + + when Iir_Kind_Protected_Type_Body => + null; + + --when Iir_Kind_Implicit_Function_Declaration => + --when Iir_Kind_Signal_Declaration + -- | Iir_Kind_Interface_Signal_Declaration => + -- Chap4.Create_Object (Decl); + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration => + Create_Object (Decl); + + when Iir_Kind_Signal_Declaration => + Create_Signal (Decl); + + when Iir_Kind_Object_Alias_Declaration => + Translate_Object_Alias_Declaration (Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_File_Declaration => + Create_File_Object (Decl); + + when Iir_Kind_Attribute_Declaration => + -- Useless as attribute declarations have a type mark. + Chap3.Translate_Object_Subtype (Decl); + + when Iir_Kind_Attribute_Specification => + Chap5.Translate_Attribute_Specification (Decl); + + when Iir_Kinds_Signal_Attribute => + Chap4.Create_Implicit_Signal (Decl); + + when Iir_Kind_Guard_Signal_Declaration => + Create_Signal (Decl); + + when Iir_Kind_Group_Template_Declaration => + null; + when Iir_Kind_Group_Declaration => + null; + + when others => + Error_Kind ("translate_declaration", Decl); + end case; + end Translate_Declaration; + + procedure Translate_Resolution_Function (Func : Iir) + is + -- Type of the resolution function parameter. + El_Type : Iir; + El_Info : Type_Info_Acc; + Finfo : constant Subprg_Info_Acc := Get_Info (Func); + Interface_List : O_Inter_List; + Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; + Id : O_Ident; + Itype : O_Tnode; + Unused_Instance : O_Dnode; + begin + if Rinfo = null then + -- Not a resolution function + return; + end if; + + -- Declare the procedure. + Id := Create_Identifier (Func, Get_Overload_Number (Func), "_RESOLV"); + Start_Procedure_Decl (Interface_List, Id, Global_Storage); + + -- The instance. + if Chap2.Has_Current_Subprg_Instance then + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, + Rinfo.Var_Instance); + else + -- Create a dummy instance parameter + New_Interface_Decl (Interface_List, Unused_Instance, + Wki_Instance, Ghdl_Ptr_Type); + Rinfo.Var_Instance := Chap2.Null_Subprg_Instance; + end if; + + -- The signal. + El_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + El_Type := Get_Element_Subtype (El_Type); + El_Info := Get_Info (El_Type); + -- FIXME: create a function for getting the type of an interface. + case El_Info.Type_Mode is + when Type_Mode_Thin => + Itype := El_Info.Ortho_Type (Mode_Signal); + when Type_Mode_Fat => + Itype := El_Info.Ortho_Ptr_Type (Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + New_Interface_Decl + (Interface_List, Rinfo.Var_Vals, Get_Identifier ("VALS"), Itype); + + New_Interface_Decl + (Interface_List, Rinfo.Var_Vec, Get_Identifier ("bool_vec"), + Ghdl_Bool_Array_Ptr); + New_Interface_Decl + (Interface_List, Rinfo.Var_Vlen, Get_Identifier ("vec_len"), + Ghdl_Index_Type); + New_Interface_Decl + (Interface_List, Rinfo.Var_Nbr_Drv, Get_Identifier ("nbr_drv"), + Ghdl_Index_Type); + New_Interface_Decl + (Interface_List, Rinfo.Var_Nbr_Ports, Get_Identifier ("nbr_ports"), + Ghdl_Index_Type); + + Finish_Subprogram_Decl (Interface_List, Rinfo.Resolv_Func); + end Translate_Resolution_Function; + + type Read_Source_Kind is (Read_Port, Read_Driver); + type Read_Source_Data is record + Sig : Mnode; + Drv_Index : O_Dnode; + Kind : Read_Source_Kind; + end record; + + procedure Read_Source_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) + is + Assoc : O_Assoc_List; + Targ_Info : Type_Info_Acc; + E : O_Enode; + begin + Targ_Info := Get_Info (Targ_Type); + case Data.Kind is + when Read_Port => + Start_Association (Assoc, Ghdl_Signal_Read_Port); + when Read_Driver => + Start_Association (Assoc, Ghdl_Signal_Read_Driver); + end case; + + New_Association + (Assoc, New_Convert_Ov (M2E (Data.Sig), Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Drv_Index)); + E := New_Convert_Ov (New_Function_Call (Assoc), + Targ_Info.Ortho_Ptr_Type (Mode_Value)); + New_Assign_Stmt (M2Lv (Targ), + New_Value (New_Access_Element (E))); + end Read_Source_Non_Composite; + + function Read_Source_Prepare_Data_Array + (Targ: Mnode; Targ_Type : Iir; Data : Read_Source_Data) + return Read_Source_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Read_Source_Prepare_Data_Array; + + function Read_Source_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) + return Read_Source_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Read_Source_Data'(Sig => Stabilize (Data.Sig), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Prepare_Data_Record; + + function Read_Source_Update_Data_Array + (Data : Read_Source_Data; Targ_Type : Iir; Index : O_Dnode) + return Read_Source_Data + is + begin + return Read_Source_Data' + (Sig => Chap3.Index_Base (Data.Sig, Targ_Type, + New_Obj_Value (Index)), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Update_Data_Array; + + function Read_Source_Update_Data_Record + (Data : Read_Source_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Read_Source_Data + is + pragma Unreferenced (Targ_Type); + begin + return Read_Source_Data' + (Sig => Chap6.Translate_Selected_Element (Data.Sig, El), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Update_Data_Record; + + procedure Read_Source_Finish_Data_Composite + (Data : in out Read_Source_Data) + is + pragma Unreferenced (Data); + begin + null; + end Read_Source_Finish_Data_Composite; + + procedure Read_Signal_Source is new Foreach_Non_Composite + (Data_Type => Read_Source_Data, + Composite_Data_Type => Read_Source_Data, + Do_Non_Composite => Read_Source_Non_Composite, + Prepare_Data_Array => Read_Source_Prepare_Data_Array, + Update_Data_Array => Read_Source_Update_Data_Array, + Finish_Data_Array => Read_Source_Finish_Data_Composite, + Prepare_Data_Record => Read_Source_Prepare_Data_Record, + Update_Data_Record => Read_Source_Update_Data_Record, + Finish_Data_Record => Read_Source_Finish_Data_Composite); + + procedure Translate_Resolution_Function_Body (Func : Iir) + is + -- Type of the resolution function parameter. + Arr_Type : Iir; + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Index_Info : Index_Info_Acc; + + -- Type of parameter element. + El_Type : Iir; + El_Info : Type_Info_Acc; + + -- Type of the function return value. + Ret_Type : Iir; + Ret_Info : Type_Info_Acc; + + -- Type and info of the array index. + Index_Type : Iir; + Index_Tinfo : Type_Info_Acc; + + -- Local variables. + Var_I : O_Dnode; + Var_J : O_Dnode; + Var_Length : O_Dnode; + Var_Res : O_Dnode; + + Vals : Mnode; + Res : Mnode; + + If_Blk : O_If_Block; + Label : O_Snode; + + V : Mnode; + + Var_Bound : O_Dnode; + Var_Range_Ptr : O_Dnode; + Var_Array : O_Dnode; + Finfo : constant Subprg_Info_Acc := Get_Info (Func); + Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; + Assoc : O_Assoc_List; + + Data : Read_Source_Data; + begin + if Rinfo = null then + -- No resolver for this function + return; + end if; + + Ret_Type := Get_Return_Type (Func); + Ret_Info := Get_Info (Ret_Type); + + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + Base_Type := Get_Base_Type (Arr_Type); + Index_Info := Get_Info + (Get_First_Element (Get_Index_Subtype_Definition_List (Base_Type))); + Base_Info := Get_Info (Base_Type); + + El_Type := Get_Element_Subtype (Arr_Type); + El_Info := Get_Info (El_Type); + + Index_Type := Get_Index_Type (Arr_Type, 0); + Index_Tinfo := Get_Info (Index_Type); + + Start_Subprogram_Body (Rinfo.Resolv_Func); + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Start_Subprg_Instance_Use (Rinfo.Var_Instance); + end if; + Push_Local_Factory; + + -- A signal. + + New_Var_Decl + (Var_Res, Get_Identifier ("res"), + O_Storage_Local, Get_Object_Type (Ret_Info, Mode_Value)); + + -- I, J. + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_J, Get_Identifier ("J"), + O_Storage_Local, Ghdl_Index_Type); + + -- Length. + New_Var_Decl + (Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + + New_Var_Decl (Var_Bound, Get_Identifier ("BOUND"), O_Storage_Local, + Base_Info.T.Bounds_Type); + New_Var_Decl (Var_Array, Get_Identifier ("ARRAY"), O_Storage_Local, + Base_Info.Ortho_Type (Mode_Value)); + + New_Var_Decl (Var_Range_Ptr, Get_Identifier ("RANGE_PTR"), + O_Storage_Local, Index_Tinfo.T.Range_Ptr_Type); + + Open_Temp; + + case El_Info.Type_Mode is + when Type_Mode_Thin => + Vals := Dv2M (Rinfo.Var_Vals, El_Info, Mode_Signal); + when Type_Mode_Fat => + Vals := Dp2M (Rinfo.Var_Vals, El_Info, Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + + -- * length := vec_len + nports; + New_Assign_Stmt (New_Obj (Var_Length), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Rinfo.Var_Vlen), + New_Obj_Value (Rinfo.Var_Nbr_Ports))); + + -- * range_ptr := BOUND.dim_1'address; + New_Assign_Stmt + (New_Obj (Var_Range_Ptr), + New_Address (New_Selected_Element (New_Obj (Var_Bound), + Index_Info.Index_Field), + Index_Tinfo.T.Range_Ptr_Type)); + + -- Create range from length + Chap3.Create_Range_From_Length + (Index_Type, Var_Length, Var_Range_Ptr, Func); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Var_Array), + Base_Info.T.Bounds_Field (Mode_Value)), + New_Address (New_Obj (Var_Bound), Base_Info.T.Bounds_Ptr_Type)); + + -- Allocate the array. + Chap3.Allocate_Fat_Array_Base + (Alloc_Stack, Dv2M (Var_Array, Base_Info, Mode_Value), Base_Type); + + -- Fill the array + -- 1. From ports. + -- * I := 0; + Init_Var (Var_I); + -- * loop + Start_Loop_Stmt (Label); + -- * exit when I = nports; + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Obj_Value (Rinfo.Var_Nbr_Ports), + Ghdl_Bool_Type)); + -- fill array[i] + V := Chap3.Index_Base + (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), + Base_Type, New_Obj_Value (Var_I)); + Data := Read_Source_Data'(Vals, Var_I, Read_Port); + Read_Signal_Source (V, El_Type, Data); + + -- * I := I + 1; + Inc_Var (Var_I); + -- * end loop; + Finish_Loop_Stmt (Label); + + -- 2. From drivers. + -- * J := 0; + -- * loop + -- * exit when j = var_max; + -- * if vec[j] then + -- + -- * ptr := get_signal_driver (sig, j); + -- * array[i].XXX := *ptr + -- + -- * i := i + 1; + -- * end if; + -- * J := J + 1; + -- * end loop; + Init_Var (Var_J); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_J), + New_Obj_Value (Rinfo.Var_Nbr_Drv), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk, + New_Value (New_Indexed_Acc_Value (New_Obj (Rinfo.Var_Vec), + New_Obj_Value (Var_J)))); + + V := Chap3.Index_Base + (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), + Base_Type, New_Obj_Value (Var_I)); + Data := Read_Source_Data'(Vals, Var_J, Read_Driver); + Read_Signal_Source (V, El_Type, Data); + + Inc_Var (Var_I); + Finish_If_Stmt (If_Blk); + + Inc_Var (Var_J); + Finish_Loop_Stmt (Label); + + if Finfo.Res_Interface /= O_Dnode_Null then + Res := Lo2M (Var_Res, Ret_Info, Mode_Value); + if Ret_Info.Type_Mode /= Type_Mode_Fat_Array then + Allocate_Complex_Object (Ret_Type, Alloc_Stack, Res); + end if; + end if; + + -- Call the resolution function. + if Finfo.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + Start_Association (Assoc, Finfo.Ortho_Func); + if Finfo.Res_Interface /= O_Dnode_Null then + New_Association (Assoc, M2E (Res)); + end if; + Chap2.Add_Subprg_Instance_Assoc (Assoc, Finfo.Subprg_Instance); + New_Association + (Assoc, New_Address (New_Obj (Var_Array), + Base_Info.Ortho_Ptr_Type (Mode_Value))); + + if Finfo.Res_Interface = O_Dnode_Null then + Res := E2M (New_Function_Call (Assoc), Ret_Info, Mode_Value); + else + New_Procedure_Call (Assoc); + end if; + + if El_Type /= Ret_Type then + Res := E2M + (Chap7.Translate_Implicit_Conv (M2E (Res), Ret_Type, El_Type, + Mode_Value, Func), + El_Info, Mode_Value); + end if; + Chap7.Set_Driving_Value (Vals, El_Type, Res); + + Close_Temp; + Pop_Local_Factory; + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Finish_Subprg_Instance_Use (Rinfo.Var_Instance); + end if; + Finish_Subprogram_Body; + end Translate_Resolution_Function_Body; + + procedure Translate_Declaration_Chain (Parent : Iir) + is + Info : Subprg_Info_Acc; + El : Iir; + begin + El := Get_Declaration_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + -- Translate interfaces. + if (not Flag_Discard_Unused or else Get_Use_Flag (El)) + and then not Is_Second_Subprogram_Specification (El) + then + Info := Add_Info (El, Kind_Subprg); + Chap2.Translate_Subprogram_Interfaces (El); + if Get_Kind (El) = Iir_Kind_Function_Declaration then + if Get_Resolution_Function_Flag (El) then + Info.Subprg_Resolv := new Subprg_Resolv_Info; + end if; + end if; + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + when others => + Translate_Declaration (El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Declaration_Chain; + + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir) + is + El : Iir; + Infos : Chap7.Implicit_Subprogram_Infos; + begin + El := Get_Declaration_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + -- Translate only if used. + if Get_Info (El) /= null then + Chap2.Translate_Subprogram_Declaration (El); + Translate_Resolution_Function (El); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- Do not translate body if generating only specs (for + -- subprograms in an entity). + if Global_Storage /= O_Storage_External + and then + (not Flag_Discard_Unused + or else + Get_Use_Flag (Get_Subprogram_Specification (El))) + then + Chap2.Translate_Subprogram_Body (El); + Translate_Resolution_Function_Body + (Get_Subprogram_Specification (El)); + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Chap3.Translate_Type_Subprograms (El); + Chap7.Init_Implicit_Subprogram_Infos (Infos); + when Iir_Kind_Protected_Type_Body => + Chap3.Translate_Protected_Type_Body (El); + Chap3.Translate_Protected_Type_Body_Subprograms (El); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + if Flag_Discard_Unused_Implicit + and then not Get_Use_Flag (El) + then + case Get_Implicit_Definition (El) is + when Iir_Predefined_Array_Equality + | Iir_Predefined_Array_Greater + | Iir_Predefined_Record_Equality => + -- Used implicitly in case statement or other + -- predefined equality. + Chap7.Translate_Implicit_Subprogram (El, Infos); + when others => + null; + end case; + else + Chap7.Translate_Implicit_Subprogram (El, Infos); + end if; + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Translate_Declaration_Chain_Subprograms; + + procedure Elab_Declaration_Chain (Parent : Iir; Need_Final : out Boolean) + is + Decl : Iir; + begin + Decl := Get_Declaration_Chain (Parent); + Need_Final := False; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + Chap5.Elab_Disconnection_Specification (Decl); + + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Chap3.Elab_Type_Declaration (Decl); + when Iir_Kind_Subtype_Declaration => + Chap3.Elab_Subtype_Declaration (Decl); + + when Iir_Kind_Protected_Type_Body => + null; + + --when Iir_Kind_Signal_Declaration => + -- Chap1.Elab_Signal (Decl); + when Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration => + Elab_Object (Decl); + if Get_Kind (Get_Type (Decl)) + = Iir_Kind_Protected_Type_Declaration + then + Need_Final := True; + end if; + + when Iir_Kind_Signal_Declaration => + Elab_Signal_Declaration (Decl, Parent, False); + + when Iir_Kind_Object_Alias_Declaration => + Elab_Object_Alias_Declaration (Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_File_Declaration => + Elab_File_Declaration (Decl); + Need_Final := True; + + when Iir_Kind_Attribute_Declaration => + Chap3.Elab_Object_Subtype (Get_Type (Decl)); + + when Iir_Kind_Attribute_Specification => + Chap5.Elab_Attribute_Specification (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Info (Decl) /= null then + Chap2.Elab_Subprogram_Interfaces (Decl); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute => + Elab_Signal_Attribute (Decl); + + when Iir_Kind_Delayed_Attribute => + Elab_Signal_Delayed_Attribute (Decl); + + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + + when others => + Error_Kind ("elab_declaration_chain", Decl); + end case; + + Decl := Get_Chain (Decl); + end loop; + end Elab_Declaration_Chain; + + procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean) + is + Decl : Iir; + begin + Decl := Get_Declaration_Chain (Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_File_Declaration => + Final_File_Declaration (Decl); + when Iir_Kind_Variable_Declaration => + if Get_Kind (Get_Type (Decl)) + = Iir_Kind_Protected_Type_Declaration + then + Fini_Protected_Object (Decl); + end if; + if Deallocate then + Fini_Object (Decl); + end if; + when Iir_Kind_Constant_Declaration => + if Deallocate then + Fini_Object (Decl); + end if; + when others => + null; + end case; + + Decl := Get_Chain (Decl); + end loop; + end Final_Declaration_Chain; + + type Conv_Mode is (Conv_Mode_In, Conv_Mode_Out); + + -- Create subprogram for an association conversion. + -- STMT is the statement/block_header containing the association. + -- BLOCK is the architecture/block containing the instance. + -- ASSOC is the association and MODE the conversion to work on. + -- CONV_INFO is the result place holder. + -- BASE_BLOCK is the base architecture/block containing the instance. + -- ENTITY is the entity/component instantiated (null for block_stmt) + procedure Translate_Association_Subprogram + (Stmt : Iir; + Block : Iir; + Assoc : Iir; + Mode : Conv_Mode; + Conv_Info : in out Assoc_Conv_Info; + Base_Block : Iir; + Entity : Iir) + is + Formal : constant Iir := Get_Formal (Assoc); + Actual : constant Iir := Get_Actual (Assoc); + + Mark2, Mark3 : Id_Mark_Type; + Inter_List : O_Inter_List; + In_Type, Out_Type : Iir; + In_Info, Out_Info : Type_Info_Acc; + Itype : O_Tnode; + El_List : O_Element_List; + Block_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt_Info : Block_Info_Acc; + Entity_Info : Ortho_Info_Acc; + Var_Data : O_Dnode; + + -- Variables for body. + E : O_Enode; + V : O_Dnode; + V1 : O_Lnode; + V_Out : Mnode; + R : O_Enode; + Constr : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + Res : Mnode; + Imp : Iir; + Func : Iir; + begin + case Mode is + when Conv_Mode_In => + -- IN: from actual to formal. + Push_Identifier_Prefix (Mark2, "CONVIN"); + Out_Type := Get_Type (Formal); + In_Type := Get_Type (Actual); + Imp := Get_In_Conversion (Assoc); + + when Conv_Mode_Out => + -- OUT: from formal to actual. + Push_Identifier_Prefix (Mark2, "CONVOUT"); + In_Type := Get_Type (Formal); + Out_Type := Get_Type (Actual); + Imp := Get_Out_Conversion (Assoc); + + end case; + -- FIXME: individual assoc -> overload. + Push_Identifier_Prefix + (Mark3, Get_Identifier (Get_Association_Interface (Assoc))); + + -- Handle anonymous subtypes. + Chap3.Translate_Anonymous_Type_Definition (Out_Type, False); + Chap3.Translate_Anonymous_Type_Definition (In_Type, False); + Out_Info := Get_Info (Out_Type); + In_Info := Get_Info (In_Type); + + -- Start record containing data for the conversion function. + Start_Record_Type (El_List); + + -- Add instance field. + Conv_Info.Instance_Block := Base_Block; + New_Record_Field + (El_List, Conv_Info.Instance_Field, Wki_Instance, + Block_Info.Block_Decls_Ptr_Type); + + if Entity /= Null_Iir then + Conv_Info.Instantiated_Entity := Entity; + Entity_Info := Get_Info (Entity); + declare + Ptr : O_Tnode; + begin + if Entity_Info.Kind = Kind_Component then + Ptr := Entity_Info.Comp_Ptr_Type; + else + Ptr := Entity_Info.Block_Decls_Ptr_Type; + end if; + New_Record_Field + (El_List, Conv_Info.Instantiated_Field, + Get_Identifier ("instantiated"), Ptr); + end; + else + Conv_Info.Instantiated_Entity := Null_Iir; + Conv_Info.Instantiated_Field := O_Fnode_Null; + end if; + + -- Add input. + case In_Info.Type_Mode is + when Type_Mode_Thin => + Itype := In_Info.Ortho_Type (Mode_Signal); + when Type_Mode_Fat => + Itype := In_Info.Ortho_Ptr_Type (Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + New_Record_Field + (El_List, Conv_Info.In_Field, Get_Identifier ("val_in"), Itype); + + -- Add output. + New_Record_Field + (El_List, Conv_Info.Out_Field, Get_Identifier ("val_out"), + Get_Object_Type (Out_Info, Mode_Signal)); + Finish_Record_Type (El_List, Conv_Info.Record_Type); + New_Type_Decl (Create_Identifier ("DTYPE"), Conv_Info.Record_Type); + Conv_Info.Record_Ptr_Type := New_Access_Type (Conv_Info.Record_Type); + New_Type_Decl (Create_Identifier ("DPTR"), Conv_Info.Record_Ptr_Type); + + -- Declare the subprogram. + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Private); + New_Interface_Decl + (Inter_List, Var_Data, Get_Identifier ("data"), + Conv_Info.Record_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Conv_Info.Subprg); + + Start_Subprogram_Body (Conv_Info.Subprg); + Push_Local_Factory; + Open_Temp; + + -- Add an access to local block. + V := Create_Temp_Init + (Block_Info.Block_Decls_Ptr_Type, + New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Instance_Field)); + Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope, V); + + -- Add an access to instantiated entity. + -- This may be used to do some type checks. + if Conv_Info.Instantiated_Entity /= Null_Iir then + declare + Ptr_Type : O_Tnode; + begin + if Entity_Info.Kind = Kind_Component then + Ptr_Type := Entity_Info.Comp_Ptr_Type; + else + Ptr_Type := Entity_Info.Block_Decls_Ptr_Type; + end if; + V := Create_Temp_Init + (Ptr_Type, + New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Instantiated_Field)); + if Entity_Info.Kind = Kind_Component then + Set_Scope_Via_Param_Ptr (Entity_Info.Comp_Scope, V); + else + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V); + end if; + end; + end if; + + -- Add access to the instantiation-specific data. + -- This is used only for anonymous subtype variables. + -- FIXME: what if STMT is a binding_indication ? + Stmt_Info := Get_Info (Stmt); + if Stmt_Info /= null + and then Has_Scope_Type (Stmt_Info.Block_Scope) + then + Set_Scope_Via_Field (Stmt_Info.Block_Scope, + Stmt_Info.Block_Parent_Field, + Get_Info (Block).Block_Scope'Access); + end if; + + -- Read signal value. + E := New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.In_Field); + case Mode is + when Conv_Mode_In => + R := Chap7.Translate_Signal_Effective_Value (E, In_Type); + when Conv_Mode_Out => + R := Chap7.Translate_Signal_Driving_Value (E, In_Type); + end case; + + case Get_Kind (Imp) is + when Iir_Kind_Function_Call => + Func := Get_Implementation (Imp); + R := Chap7.Translate_Implicit_Conv + (R, In_Type, + Get_Type (Get_Interface_Declaration_Chain (Func)), + Mode_Value, Assoc); + + -- Create result value. + Subprg_Info := Get_Info (Func); + + if Subprg_Info.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + -- If we need to allocate, do it before starting the call! + declare + Res_Type : constant Iir := Get_Return_Type (Func); + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + begin + Res := Create_Temp (Res_Info); + if Res_Info.Type_Mode /= Type_Mode_Fat_Array then + Chap4.Allocate_Complex_Object + (Res_Type, Alloc_Stack, Res); + end if; + end; + end if; + + -- Call conversion function. + Start_Association (Constr, Subprg_Info.Ortho_Func); + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Association (Constr, M2E (Res)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Subprg_Info.Subprg_Instance); + + New_Association (Constr, R); + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + E := M2E (Res); + else + E := New_Function_Call (Constr); + end if; + Res := E2M + (Chap7.Translate_Implicit_Conv + (E, Get_Return_Type (Func), + Out_Type, Mode_Value, Imp), + Get_Info (Out_Type), Mode_Value); + + when Iir_Kind_Type_Conversion => + declare + Conv_Type : Iir; + begin + Conv_Type := Get_Type (Imp); + E := Chap7.Translate_Type_Conversion + (R, In_Type, Conv_Type, Assoc); + E := Chap7.Translate_Implicit_Conv + (E, Conv_Type, Out_Type, Mode_Value, Imp); + Res := E2M (E, Get_Info (Out_Type), Mode_Value); + end; + + when others => + Error_Kind ("Translate_Association_Subprogram", Imp); + end case; + + -- Assign signals. + V1 := New_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Out_Field); + V_Out := Lo2M (V1, Out_Info, Mode_Signal); + + case Mode is + when Conv_Mode_In => + Chap7.Set_Effective_Value (V_Out, Out_Type, Res); + when Conv_Mode_Out => + Chap7.Set_Driving_Value (V_Out, Out_Type, Res); + end case; + + Close_Temp; + if Stmt_Info /= null + and then Has_Scope_Type (Stmt_Info.Block_Scope) + then + Clear_Scope (Stmt_Info.Block_Scope); + end if; + if Conv_Info.Instantiated_Entity /= Null_Iir then + if Entity_Info.Kind = Kind_Component then + Clear_Scope (Entity_Info.Comp_Scope); + else + Clear_Scope (Entity_Info.Block_Scope); + end if; + end if; + Clear_Scope (Block_Info.Block_Scope); + + Pop_Local_Factory; + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark3); + Pop_Identifier_Prefix (Mark2); + end Translate_Association_Subprogram; + + -- ENTITY is null for block_statement. + procedure Translate_Association_Subprograms + (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir) + is + Assoc : Iir; + Info : Assoc_Info_Acc; + begin + Assoc := Get_Port_Map_Aspect_Chain (Stmt); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression + then + Info := null; + if Get_In_Conversion (Assoc) /= Null_Iir then + Info := Add_Info (Assoc, Kind_Assoc); + Translate_Association_Subprogram + (Stmt, Block, Assoc, Conv_Mode_In, Info.Assoc_In, + Base_Block, Entity); + end if; + if Get_Out_Conversion (Assoc) /= Null_Iir then + if Info = null then + Info := Add_Info (Assoc, Kind_Assoc); + end if; + Translate_Association_Subprogram + (Stmt, Block, Assoc, Conv_Mode_Out, Info.Assoc_Out, + Base_Block, Entity); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + end Translate_Association_Subprograms; + + procedure Elab_Conversion (Sig_In : Iir; + Sig_Out : Iir; + Reg_Subprg : O_Dnode; + Info : Assoc_Conv_Info; + Ndest : out Mnode) + is + Out_Type : Iir; + Out_Info : Type_Info_Acc; + Ssig : Mnode; + Constr : O_Assoc_List; + Var_Data : O_Dnode; + Data : Elab_Signal_Data; + begin + Out_Type := Get_Type (Sig_Out); + Out_Info := Get_Info (Out_Type); + + -- Allocate data for the subprogram. + Var_Data := Create_Temp (Info.Record_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Data), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Info.Record_Type, + Ghdl_Index_Type)), + Info.Record_Ptr_Type)); + + -- Set instance. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), Info.Instance_Field), + Get_Instance_Access (Info.Instance_Block)); + + -- Set instantiated unit instance (if any). + if Info.Instantiated_Entity /= Null_Iir then + declare + Inst_Addr : O_Enode; + Inst_Info : Ortho_Info_Acc; + begin + if Get_Kind (Info.Instantiated_Entity) + = Iir_Kind_Component_Declaration + then + Inst_Info := Get_Info (Info.Instantiated_Entity); + Inst_Addr := New_Address + (Get_Instance_Ref (Inst_Info.Comp_Scope), + Inst_Info.Comp_Ptr_Type); + else + Inst_Addr := Get_Instance_Access (Info.Instantiated_Entity); + end if; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Instantiated_Field), + Inst_Addr); + end; + end if; + + -- Set input. + Ssig := Chap6.Translate_Name (Sig_In); + Ssig := Stabilize (Ssig, True); + + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), Info.In_Field), + M2E (Ssig)); + + -- Create a copy of SIG_OUT. + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Chap4.Allocate_Complex_Object (Out_Type, Alloc_System, Ndest); + -- Note: NDEST will be assigned by ELAB_SIGNAL. + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Data := Elab_Signal_Data'(Has_Val => False, + Already_Resolved => True, + Val => Mnode_Null, + Check_Null => False, + If_Stmt => null); + Elab_Signal (Ndest, Out_Type, Data); + + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Ndest := Stabilize (Ndest, True); + + -- Register. + Start_Association (Constr, Reg_Subprg); + New_Association + (Constr, New_Lit (New_Subprogram_Address (Info.Subprg, + Ghdl_Ptr_Type))); + New_Association + (Constr, New_Convert_Ov (New_Obj_Value (Var_Data), Ghdl_Ptr_Type)); + + New_Association + (Constr, + New_Convert_Ov (M2E (Get_Leftest_Signal (Ssig, Get_Type (Sig_In))), + Ghdl_Signal_Ptr)); + New_Association (Constr, Get_Nbr_Signals (Ssig, Get_Type (Sig_In))); + + New_Association + (Constr, + New_Convert_Ov + (M2E (Get_Leftest_Signal (Ndest, Get_Type (Sig_Out))), + Ghdl_Signal_Ptr)); + New_Association (Constr, Get_Nbr_Signals (Ndest, Get_Type (Sig_Out))); + + New_Procedure_Call (Constr); + end Elab_Conversion; + + -- In conversion: from actual to formal. + procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode) + is + Assoc_Info : Assoc_Info_Acc; + begin + Assoc_Info := Get_Info (Assoc); + + Elab_Conversion + (Get_Actual (Assoc), Get_Formal (Assoc), + Ghdl_Signal_In_Conversion, Assoc_Info.Assoc_In, Ndest); + end Elab_In_Conversion; + + -- Out conversion: from formal to actual. + procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode) + is + Assoc_Info : Assoc_Info_Acc; + begin + Assoc_Info := Get_Info (Assoc); + + Elab_Conversion + (Get_Formal (Assoc), Get_Actual (Assoc), + Ghdl_Signal_Out_Conversion, Assoc_Info.Assoc_Out, Ndest); + end Elab_Out_Conversion; + + -- Create a record that describe thes location of an IIR node and + -- returns the address of it. + function Get_Location (N : Iir) return O_Dnode + is + Constr : O_Record_Aggr_List; + Aggr : O_Cnode; + Name : Name_Id; + Line : Natural; + Col : Natural; + C : O_Dnode; + begin + Files_Map.Location_To_Position (Get_Location (N), Name, Line, Col); + + New_Const_Decl (C, Create_Uniq_Identifier, O_Storage_Private, + Ghdl_Location_Type_Node); + Start_Const_Value (C); + Start_Record_Aggr (Constr, Ghdl_Location_Type_Node); + New_Record_Aggr_El + (Constr, New_Global_Address (Current_Filename_Node, Char_Ptr_Type)); + New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Line))); + New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Col))); + Finish_Record_Aggr (Constr, Aggr); + Finish_Const_Value (C, Aggr); + + return C; + --return New_Global_Address (C, Ghdl_Location_Ptr_Node); + end Get_Location; + end Chap4; + + package body Chap5 is + procedure Translate_Attribute_Specification + (Spec : Iir_Attribute_Specification) + is + Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + Atinfo : constant Type_Info_Acc := Get_Info (Get_Type (Attr)); + Mark : Id_Mark_Type; + Info : Object_Info_Acc; + begin + Push_Identifier_Prefix_Uniq (Mark); + Info := Add_Info (Spec, Kind_Object); + Info.Object_Var := Create_Var + (Create_Var_Identifier (Attr), + Chap4.Get_Object_Type (Atinfo, Mode_Value), + Global_Storage); + Pop_Identifier_Prefix (Mark); + end Translate_Attribute_Specification; + + procedure Elab_Attribute_Specification + (Spec : Iir_Attribute_Specification) + is + Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + begin + -- Kludge + Set_Info (Attr, Get_Info (Spec)); + Chap4.Elab_Object_Value (Attr, Get_Expression (Spec)); + Clear_Info (Attr); + end Elab_Attribute_Specification; + + procedure Gen_Elab_Disconnect_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Time : O_Dnode) + is + pragma Unreferenced (Targ_Type); + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Set_Disconnect); + New_Association + (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Time)); + New_Procedure_Call (Assoc); + end Gen_Elab_Disconnect_Non_Composite; + + function Gen_Elab_Disconnect_Prepare + (Targ : Mnode; Targ_Type : Iir; Time : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Time; + end Gen_Elab_Disconnect_Prepare; + + function Gen_Elab_Disconnect_Update_Data_Array (Time : O_Dnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ_Type, Index); + begin + return Time; + end Gen_Elab_Disconnect_Update_Data_Array; + + function Gen_Elab_Disconnect_Update_Data_Record + (Time : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Dnode + is + pragma Unreferenced (Targ_Type, El); + begin + return Time; + end Gen_Elab_Disconnect_Update_Data_Record; + + procedure Gen_Elab_Disconnect_Finish_Data_Composite + (Data : in out O_Dnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Elab_Disconnect_Finish_Data_Composite; + + procedure Gen_Elab_Disconnect is new Foreach_Non_Composite + (Data_Type => O_Dnode, + Composite_Data_Type => O_Dnode, + Do_Non_Composite => Gen_Elab_Disconnect_Non_Composite, + Prepare_Data_Array => Gen_Elab_Disconnect_Prepare, + Update_Data_Array => Gen_Elab_Disconnect_Update_Data_Array, + Finish_Data_Array => Gen_Elab_Disconnect_Finish_Data_Composite, + Prepare_Data_Record => Gen_Elab_Disconnect_Prepare, + Update_Data_Record => Gen_Elab_Disconnect_Update_Data_Record, + Finish_Data_Record => Gen_Elab_Disconnect_Finish_Data_Composite); + + procedure Elab_Disconnection_Specification + (Spec : Iir_Disconnection_Specification) + is + Val : O_Dnode; + List : constant Iir_List := Get_Signal_List (Spec); + El : Iir; + begin + Val := Create_Temp_Init + (Std_Time_Otype, + Chap7.Translate_Expression (Get_Expression (Spec))); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Gen_Elab_Disconnect (Chap6.Translate_Name (El), + Get_Type (El), Val); + end loop; + end Elab_Disconnection_Specification; + + type Connect_Mode is + ( + -- Actual is a source for the formal. + Connect_Source, + + -- Both. + Connect_Both, + + -- Effective value of actual is the effective value of the formal. + Connect_Effective, + + -- Actual is a value. + Connect_Value + ); + + type Connect_Data is record + Actual_Node : Mnode; + Actual_Type : Iir; + + -- Mode of the connection. + Mode : Connect_Mode; + + -- If true, formal signal is a copy of the actual. + By_Copy : Boolean; + end record; + + -- Connect_effective: FORMAL is set from ACTUAL. + -- Connect_Source: ACTUAL is set from FORMAL (source of ACTUAL). + procedure Connect_Scalar (Formal_Node : Mnode; + Formal_Type : Iir; + Data : Connect_Data) + is + Act_Node, Form_Node : Mnode; + begin + if Data.By_Copy then + New_Assign_Stmt (M2Lv (Formal_Node), M2E (Data.Actual_Node)); + return; + end if; + + case Data.Mode is + when Connect_Both => + Open_Temp; + Act_Node := Stabilize (Data.Actual_Node, True); + Form_Node := Stabilize (Formal_Node, True); + when Connect_Source + | Connect_Effective => + Act_Node := Data.Actual_Node; + Form_Node := Formal_Node; + when Connect_Value => + null; + end case; + + if Data.Mode in Connect_Source .. Connect_Both then + -- Formal is a source to actual. + declare + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Add_Source); + New_Association (Constr, New_Convert_Ov (M2E (Act_Node), + Ghdl_Signal_Ptr)); + New_Association (Constr, New_Convert_Ov (M2E (Form_Node), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode in Connect_Both .. Connect_Effective then + -- The effective value of formal is the effective value of actual. + declare + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Effective_Value); + New_Association (Constr, New_Convert_Ov (M2E (Form_Node), + Ghdl_Signal_Ptr)); + New_Association (Constr, New_Convert_Ov (M2E (Act_Node), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode = Connect_Value then + declare + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Constr : O_Assoc_List; + Conv : O_Tnode; + begin + Type_Info := Get_Info (Formal_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Associate_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Associate_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Associate_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 => + Subprg := Ghdl_Signal_Associate_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_Signal_Associate_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Associate_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("connect_scalar", Formal_Type); + end case; + Start_Association (Constr, Subprg); + New_Association (Constr, + New_Convert_Ov (New_Value (M2Lv (Formal_Node)), + Ghdl_Signal_Ptr)); + New_Association (Constr, + New_Convert_Ov (M2E (Data.Actual_Node), Conv)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode = Connect_Both then + Close_Temp; + end if; + end Connect_Scalar; + + function Connect_Prepare_Data_Composite + (Targ : Mnode; Formal_Type : Iir; Data : Connect_Data) + return Connect_Data + is + pragma Unreferenced (Targ, Formal_Type); + Res : Connect_Data; + Atype : Iir; + begin + Atype := Get_Base_Type (Data.Actual_Type); + if Get_Kind (Atype) = Iir_Kind_Record_Type_Definition then + Res := Data; + Stabilize (Res.Actual_Node); + return Res; + else + return Data; + end if; + end Connect_Prepare_Data_Composite; + + function Connect_Update_Data_Array (Data : Connect_Data; + Formal_Type : Iir; + Index : O_Dnode) + return Connect_Data + is + pragma Unreferenced (Formal_Type); + Res : Connect_Data; + begin + -- FIXME: should check matching elements! + Res := (Actual_Node => + Chap3.Index_Base (Chap3.Get_Array_Base (Data.Actual_Node), + Data.Actual_Type, New_Obj_Value (Index)), + Actual_Type => Get_Element_Subtype (Data.Actual_Type), + Mode => Data.Mode, + By_Copy => Data.By_Copy); + return Res; + end Connect_Update_Data_Array; + + function Connect_Update_Data_Record (Data : Connect_Data; + Formal_Type : Iir; + El : Iir_Element_Declaration) + return Connect_Data + is + pragma Unreferenced (Formal_Type); + Res : Connect_Data; + begin + Res := (Actual_Node => + Chap6.Translate_Selected_Element (Data.Actual_Node, El), + Actual_Type => Get_Type (El), + Mode => Data.Mode, + By_Copy => Data.By_Copy); + return Res; + end Connect_Update_Data_Record; + + procedure Connect_Finish_Data_Composite (Data : in out Connect_Data) + is + pragma Unreferenced (Data); + begin + null; + end Connect_Finish_Data_Composite; + + procedure Connect is new Foreach_Non_Composite + (Data_Type => Connect_Data, + Composite_Data_Type => Connect_Data, + Do_Non_Composite => Connect_Scalar, + Prepare_Data_Array => Connect_Prepare_Data_Composite, + Update_Data_Array => Connect_Update_Data_Array, + Finish_Data_Array => Connect_Finish_Data_Composite, + Prepare_Data_Record => Connect_Prepare_Data_Composite, + Update_Data_Record => Connect_Update_Data_Record, + Finish_Data_Record => Connect_Finish_Data_Composite); + + procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir) + is + Act_Node : Mnode; + Bounds : Mnode; + Tinfo : Type_Info_Acc; + Bound_Var : O_Dnode; + Actual_Type : Iir; + begin + Actual_Type := Get_Type (Actual); + Open_Temp; + if Is_Fully_Constrained_Type (Actual_Type) then + Chap3.Create_Array_Subtype (Actual_Type, False); + Tinfo := Get_Info (Actual_Type); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + if Get_Alloc_Kind_For_Var (Tinfo.T.Array_Bounds) = Alloc_Stack then + -- We need a copy. + Bound_Var := Create_Temp (Tinfo.T.Bounds_Ptr_Type); + New_Assign_Stmt + (New_Obj (Bound_Var), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Tinfo.T.Bounds_Ptr_Type)); + Gen_Memcpy (New_Obj_Value (Bound_Var), + M2Addr (Bounds), + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, + Ghdl_Index_Type))); + Bounds := Dp2M (Bound_Var, Tinfo, Mode_Value, + Tinfo.T.Bounds_Type, + Tinfo.T.Bounds_Ptr_Type); + end if; + else + Bounds := Chap3.Get_Array_Bounds (Chap6.Translate_Name (Actual)); + end if; + Act_Node := Chap6.Translate_Name (Port); + New_Assign_Stmt + (-- FIXME: this works only because it is not stabilized, + -- and therefore the bounds field is returned and not + -- a pointer to the bounds. + M2Lp (Chap3.Get_Array_Bounds (Act_Node)), + M2Addr (Bounds)); + Close_Temp; + end Elab_Unconstrained_Port; + + -- 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; + + procedure Elab_Port_Map_Aspect_Assoc (Assoc : Iir; By_Copy : Boolean) + is + Formal : constant Iir := Get_Formal (Assoc); + Actual : constant Iir := Get_Actual (Assoc); + Formal_Type : constant Iir := Get_Type (Formal); + Actual_Type : constant Iir := Get_Type (Actual); + Inter : constant Iir := Get_Association_Interface (Assoc); + Formal_Node, Actual_Node : Mnode; + Data : Connect_Data; + Mode : Connect_Mode; + begin + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + raise Internal_Error; + end if; + + Open_Temp; + if Get_In_Conversion (Assoc) = Null_Iir + and then Get_Out_Conversion (Assoc) = Null_Iir + then + Formal_Node := Chap6.Translate_Name (Formal); + if Get_Object_Kind (Formal_Node) /= Mode_Signal then + raise Internal_Error; + end if; + if Is_Signal (Actual) then + -- LRM93 4.3.1.2 + -- For a signal of a scalar type, each source is either + -- a driver or an OUT, INOUT, BUFFER or LINKAGE port of + -- a component instance or of a block statement with + -- which the signalis associated. + + -- LRM93 12.6.2 + -- For a scalar signal S, the effective value of S is + -- determined in the following manner: + -- * If S is [...] a port of mode BUFFER or [...], + -- then the effective value of S is the same as + -- the driving value of S. + -- * If S is a connected port of mode IN or INOUT, + -- then the effective value of S is the same as + -- the effective value of the actual part of the + -- association element that associates an actual + -- with S. + -- * [...] + case Get_Mode (Inter) is + when Iir_In_Mode => + Mode := Connect_Effective; + when Iir_Inout_Mode => + Mode := Connect_Both; + when Iir_Out_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + Mode := Connect_Source; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + + -- translate actual (abort if not a signal). + Actual_Node := Chap6.Translate_Name (Actual); + if Get_Object_Kind (Actual_Node) /= Mode_Signal then + raise Internal_Error; + end if; + else + declare + Actual_Val : O_Enode; + begin + Actual_Val := Chap7.Translate_Expression + (Actual, Formal_Type); + Actual_Node := E2M + (Actual_Val, Get_Info (Formal_Type), Mode_Value); + Mode := Connect_Value; + end; + end if; + + if Get_Kind (Formal_Type) in Iir_Kinds_Array_Type_Definition + then + -- Check length matches. + Stabilize (Formal_Node); + Stabilize (Actual_Node); + Chap3.Check_Array_Match (Formal_Type, Formal_Node, + Actual_Type, Actual_Node, + Assoc); + end if; + + Data := (Actual_Node => Actual_Node, + Actual_Type => Actual_Type, + Mode => Mode, + By_Copy => By_Copy); + Connect (Formal_Node, Formal_Type, Data); + else + if Get_In_Conversion (Assoc) /= Null_Iir then + Chap4.Elab_In_Conversion (Assoc, Actual_Node); + Formal_Node := Chap6.Translate_Name (Formal); + Data := (Actual_Node => Actual_Node, + Actual_Type => Formal_Type, + Mode => Connect_Effective, + By_Copy => False); + Connect (Formal_Node, Formal_Type, Data); + end if; + if Get_Out_Conversion (Assoc) /= Null_Iir then + -- flow: FORMAL to ACTUAL + Chap4.Elab_Out_Conversion (Assoc, Formal_Node); + Actual_Node := Chap6.Translate_Name (Actual); + Data := (Actual_Node => Actual_Node, + Actual_Type => Actual_Type, + Mode => Connect_Source, + By_Copy => False); + Connect (Formal_Node, Actual_Type, Data); + end if; + end if; + + Close_Temp; + end Elab_Port_Map_Aspect_Assoc; + + -- Return TRUE if the collapse_signal_flag is set for each individual + -- association. + function Inherit_Collapse_Flag (Assoc : Iir) return Boolean + is + El : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Individual => + El := Get_Individual_Association_Chain (Assoc); + while El /= Null_Iir loop + if Inherit_Collapse_Flag (El) = False then + return False; + end if; + El := Get_Chain (El); + end loop; + return True; + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_Name => + El := Assoc; + while El /= Null_Iir loop + if not Inherit_Collapse_Flag (Get_Associated_Expr (Assoc)) + then + return False; + end if; + El := Get_Chain (El); + end loop; + return True; + when Iir_Kind_Association_Element_By_Expression => + return Get_Collapse_Signal_Flag (Assoc); + when others => + Error_Kind ("inherit_collapse_flag", Assoc); + end case; + end Inherit_Collapse_Flag; + + procedure Elab_Generic_Map_Aspect (Mapping : Iir) + is + Assoc : Iir; + Formal : Iir; + begin + -- Elab generics, and associate. + Assoc := Get_Generic_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Open_Temp; + Formal := Get_Formal (Assoc); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + declare + Targ : Mnode; + begin + if Get_Whole_Association_Flag (Assoc) then + Chap4.Elab_Object_Storage (Formal); + Targ := Chap6.Translate_Name (Formal); + Chap4.Elab_Object_Init + (Targ, Formal, Get_Actual (Assoc)); + else + Targ := Chap6.Translate_Name (Formal); + Chap7.Translate_Assign + (Targ, Get_Actual (Assoc), Get_Type (Formal)); + end if; + end; + when Iir_Kind_Association_Element_Open => + Chap4.Elab_Object_Value (Formal, Get_Default_Value (Formal)); + when Iir_Kind_Association_Element_By_Individual => + -- Create the object. + declare + Formal_Type : constant Iir := Get_Type (Formal); + Obj_Info : constant Object_Info_Acc := Get_Info (Formal); + Obj_Type : constant Iir := Get_Actual_Type (Assoc); + Formal_Node : Mnode; + Type_Info : Type_Info_Acc; + Bounds : Mnode; + begin + Chap3.Elab_Object_Subtype (Formal_Type); + Type_Info := Get_Info (Formal_Type); + Formal_Node := Get_Var + (Obj_Info.Object_Var, Type_Info, Mode_Value); + Stabilize (Formal_Node); + if Obj_Type = Null_Iir then + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc_System, Formal_Node); + else + Chap3.Create_Array_Subtype (Obj_Type, False); + Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type); + Chap3.Translate_Object_Allocation + (Formal_Node, Alloc_System, Formal_Type, Bounds); + end if; + end; + when Iir_Kind_Association_Element_Package => + pragma Assert (Get_Kind (Formal) = + Iir_Kind_Interface_Package_Declaration); + declare + Uninst_Pkg : constant Iir := Get_Named_Entity + (Get_Uninstantiated_Package_Name (Formal)); + Uninst_Info : constant Ortho_Info_Acc := + Get_Info (Uninst_Pkg); + Formal_Info : constant Ortho_Info_Acc := + Get_Info (Formal); + Actual : constant Iir := Get_Named_Entity + (Get_Actual (Assoc)); + Actual_Info : constant Ortho_Info_Acc := + Get_Info (Actual); + begin + New_Assign_Stmt + (Get_Var (Formal_Info.Package_Instance_Spec_Var), + New_Address + (Get_Instance_Ref + (Actual_Info.Package_Instance_Spec_Scope), + Uninst_Info.Package_Spec_Ptr_Type)); + New_Assign_Stmt + (Get_Var (Formal_Info.Package_Instance_Body_Var), + New_Address + (Get_Instance_Ref + (Actual_Info.Package_Instance_Body_Scope), + Uninst_Info.Package_Body_Ptr_Type)); + end; + when others => + Error_Kind ("elab_generic_map_aspect(1)", Assoc); + end case; + Close_Temp; + Assoc := Get_Chain (Assoc); + end loop; + end Elab_Generic_Map_Aspect; + + procedure Elab_Port_Map_Aspect (Mapping : Iir; Block_Parent : Iir) + is + Assoc : Iir; + Formal : Iir; + Formal_Base : Iir; + Fb_Type : Iir; + Fbt_Info : Type_Info_Acc; + Collapse_Individual : Boolean := False; + begin + -- Ports. + Assoc := Get_Port_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + Formal_Base := Get_Association_Interface (Assoc); + Fb_Type := Get_Type (Formal_Base); + + Open_Temp; + -- Set bounds of unconstrained ports. + Fbt_Info := Get_Info (Fb_Type); + if Fbt_Info.Type_Mode = Type_Mode_Fat_Array then + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + Elab_Unconstrained_Port (Formal, Get_Actual (Assoc)); + end if; + when Iir_Kind_Association_Element_Open => + declare + Actual_Type : Iir; + Bounds : Mnode; + Formal_Node : Mnode; + begin + Actual_Type := + Get_Type (Get_Default_Value (Formal_Base)); + Chap3.Create_Array_Subtype (Actual_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Formal_Node := Chap6.Translate_Name (Formal); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), + M2Addr (Bounds)); + end; + when Iir_Kind_Association_Element_By_Individual => + declare + Actual_Type : Iir; + Bounds : Mnode; + Formal_Node : Mnode; + begin + Actual_Type := Get_Actual_Type (Assoc); + Chap3.Create_Array_Subtype (Actual_Type, False); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Formal_Node := Chap6.Translate_Name (Formal); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), + M2Addr (Bounds)); + end; + when others => + Error_Kind ("elab_map_aspect(2)", Assoc); + end case; + end if; + Close_Temp; + + -- Allocate storage of ports. + Open_Temp; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open => + Chap4.Elab_Signal_Declaration_Storage (Formal); + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + Chap4.Elab_Signal_Declaration_Storage (Formal); + end if; + when others => + Error_Kind ("elab_map_aspect(3)", Assoc); + end case; + Close_Temp; + + -- Create or copy signals. + Open_Temp; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + if Get_Collapse_Signal_Flag (Assoc) then + -- For collapsed association, copy signals. + Elab_Port_Map_Aspect_Assoc (Assoc, True); + else + -- Create non-collapsed signals. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + -- And associate. + Elab_Port_Map_Aspect_Assoc (Assoc, False); + end if; + else + -- By sub-element. + -- Either the whole signal is collapsed or it was already + -- created. + -- And associate. + Elab_Port_Map_Aspect_Assoc (Assoc, Collapse_Individual); + end if; + when Iir_Kind_Association_Element_Open => + -- Create non-collapsed signals. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + when Iir_Kind_Association_Element_By_Individual => + -- Inherit the collapse flag. + -- If it is set for all sub-associations, continue. + -- Otherwise, create signals and do not collapse. + -- FIXME: this may be slightly optimized. + if not Inherit_Collapse_Flag (Assoc) then + -- Create the formal. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + Collapse_Individual := False; + else + Collapse_Individual := True; + end if; + when others => + Error_Kind ("elab_map_aspect(4)", Assoc); + end case; + Close_Temp; + + Assoc := Get_Chain (Assoc); + end loop; + end Elab_Port_Map_Aspect; + + procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir) is + begin + -- The generic map must be done before the elaboration of + -- the ports, since a port subtype may depend on a generic. + Elab_Generic_Map_Aspect (Mapping); + + Elab_Port_Map_Aspect (Mapping, Block_Parent); + end Elab_Map_Aspect; + end Chap5; + + package body Chap6 is + function Get_Array_Bound_Length (Arr : Mnode; + Arr_Type : Iir; + Dim : Natural) + return O_Enode + is + Index_Type : constant Iir := Get_Index_Type (Arr_Type, Dim - 1); + Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); + Constraint : Iir; + begin + if Tinfo.Type_Locally_Constrained then + Constraint := Get_Range_Constraint (Index_Type); + return New_Lit (Chap7.Translate_Static_Range_Length (Constraint)); + else + return M2E + (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, Dim))); + end if; + end Get_Array_Bound_Length; + + procedure Gen_Bound_Error (Loc : Iir) + is + Constr : O_Assoc_List; + Name : Name_Id; + Line, Col : Natural; + begin + Files_Map.Location_To_Position (Get_Location (Loc), Name, Line, Col); + + Start_Association (Constr, Ghdl_Bound_Check_Failed_L1); + Assoc_Filename_Line (Constr, Line); + New_Procedure_Call (Constr); + end Gen_Bound_Error; + + procedure Gen_Program_Error (Loc : Iir; Code : Natural) + is + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Program_Error); + + if Current_Filename_Node = O_Dnode_Null then + New_Association (Assoc, New_Lit (New_Null_Access (Char_Ptr_Type))); + New_Association (Assoc, + New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0))); + else + Assoc_Filename_Line (Assoc, Get_Line_Number (Loc)); + end if; + New_Association + (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Code)))); + New_Procedure_Call (Assoc); + end Gen_Program_Error; + + -- Generate code to emit a failure if COND is TRUE, indicating an + -- index violation for dimension DIM of an array. LOC is usually + -- the expression which has computed the index and is used only for + -- its location. + procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural) + is + pragma Unreferenced (Dim); + If_Blk : O_If_Block; + begin + Start_If_Stmt (If_Blk, Cond); + Gen_Bound_Error (Loc); + Finish_If_Stmt (If_Blk); + end Check_Bound_Error; + + -- Return TRUE if an array whose index type is RNG_TYPE indexed by + -- an expression of type EXPR_TYPE needs a bound check. + function Need_Index_Check (Expr_Type : Iir; Rng_Type : Iir) + return Boolean + is + Rng : Iir; + begin + -- Do checks if type of the expression is not a subtype. + -- FIXME: EXPR_TYPE shound not be NULL_IIR (generate stmt) + if Expr_Type = Null_Iir then + return True; + end if; + case Get_Kind (Expr_Type) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + null; + when others => + return True; + end case; + + -- No check if the expression has the type of the index. + if Expr_Type = Rng_Type then + return False; + end if; + + -- No check for 'Range or 'Reverse_Range. + Rng := Get_Range_Constraint (Expr_Type); + if (Get_Kind (Rng) = Iir_Kind_Range_Array_Attribute + or Get_Kind (Rng) = Iir_Kind_Reverse_Range_Array_Attribute) + and then Get_Type (Rng) = Rng_Type + then + return False; + end if; + + return True; + end Need_Index_Check; + + procedure Get_Deep_Range_Expression + (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean) + is + T : Iir; + R : Iir; + begin + Is_Reverse := False; + + -- T is an integer/enumeration subtype. + T := Atype; + loop + case Get_Kind (T) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + -- These types have a range. + null; + when others => + Error_Kind ("get_deep_range_expression(1)", T); + end case; + + R := Get_Range_Constraint (T); + case Get_Kind (R) is + when Iir_Kind_Range_Expression => + Rng := R; + return; + when Iir_Kind_Range_Array_Attribute => + null; + when Iir_Kind_Reverse_Range_Array_Attribute => + Is_Reverse := not Is_Reverse; + when others => + Error_Kind ("get_deep_range_expression(2)", R); + end case; + T := Get_Index_Subtype (R); + if T = Null_Iir then + Rng := Null_Iir; + return; + end if; + end loop; + end Get_Deep_Range_Expression; + + function Translate_Index_To_Offset (Rng : Mnode; + Index : O_Enode; + Index_Expr : Iir; + Range_Type : Iir; + Loc : Iir) + return O_Enode + is + Need_Check : Boolean; + Dir : O_Enode; + If_Blk : O_If_Block; + Res : O_Dnode; + Off : O_Dnode; + Bound : O_Enode; + Cond1, Cond2: O_Enode; + Index_Node : O_Dnode; + Bound_Node : O_Dnode; + Index_Info : Type_Info_Acc; + Deep_Rng : Iir; + Deep_Reverse : Boolean; + begin + Index_Info := Get_Info (Get_Base_Type (Range_Type)); + if Index_Expr = Null_Iir then + Need_Check := True; + Deep_Rng := Null_Iir; + Deep_Reverse := False; + else + Need_Check := Need_Index_Check (Get_Type (Index_Expr), Range_Type); + Get_Deep_Range_Expression (Range_Type, Deep_Rng, Deep_Reverse); + end if; + + Res := Create_Temp (Ghdl_Index_Type); + + Open_Temp; + + Off := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + Bound := M2E (Chap3.Range_To_Left (Rng)); + + if Deep_Rng /= Null_Iir then + if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then + -- Direction TO: INDEX - LEFT. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + Index, Bound)); + else + -- Direction DOWNTO: LEFT - INDEX. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + Bound, Index)); + end if; + else + Index_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), Index); + Bound_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), Bound); + Dir := M2E (Chap3.Range_To_Dir (Rng)); + + -- Non-static direction. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, Dir, + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + -- Direction TO: INDEX - LEFT. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Index_Node), + New_Obj_Value (Bound_Node))); + New_Else_Stmt (If_Blk); + -- Direction DOWNTO: LEFT - INDEX. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Bound_Node), + New_Obj_Value (Index_Node))); + Finish_If_Stmt (If_Blk); + end if; + + -- Get the offset. + New_Assign_Stmt + (New_Obj (Res), New_Convert_Ov (New_Obj_Value (Off), + Ghdl_Index_Type)); + + -- Check bounds. + if Need_Check then + Cond1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Off), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + + Cond2 := New_Compare_Op + (ON_Ge, + New_Obj_Value (Res), + M2E (Chap3.Range_To_Length (Rng)), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + end if; + + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Index_To_Offset; + + -- Translate index EXPR in dimension DIM of thin array into an + -- offset. + -- This checks bounds. + function Translate_Thin_Index_Offset (Index_Type : Iir; + Dim : Natural; + Expr : Iir) + return O_Enode + is + Index_Range : constant Iir := Get_Range_Constraint (Index_Type); + Obound : O_Cnode; + Res : O_Dnode; + Cond2: O_Enode; + Index : O_Enode; + Index_Base_Type : Iir; + V : Iir_Int64; + B : Iir_Int64; + begin + B := Eval_Pos (Get_Left_Limit (Index_Range)); + if Get_Expr_Staticness (Expr) = Locally then + V := Eval_Pos (Eval_Static_Expr (Expr)); + if Get_Direction (Index_Range) = Iir_To then + B := V - B; + else + B := B - V; + end if; + return New_Lit + (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (B))); + else + Index_Base_Type := Get_Base_Type (Index_Type); + Index := Chap7.Translate_Expression (Expr, Index_Base_Type); + + if Get_Direction (Index_Range) = Iir_To then + -- Direction TO: INDEX - LEFT. + if B /= 0 then + Obound := Chap7.Translate_Static_Range_Left + (Index_Range, Index_Base_Type); + Index := New_Dyadic_Op (ON_Sub_Ov, Index, New_Lit (Obound)); + end if; + else + -- Direction DOWNTO: LEFT - INDEX. + Obound := Chap7.Translate_Static_Range_Left + (Index_Range, Index_Base_Type); + Index := New_Dyadic_Op (ON_Sub_Ov, New_Lit (Obound), Index); + end if; + + -- Get the offset. + Index := New_Convert_Ov (Index, Ghdl_Index_Type); + + -- Since the value is unsigned, both left and right bounds are + -- checked in the same time. + if Get_Type (Expr) /= Index_Type then + Res := Create_Temp_Init (Ghdl_Index_Type, Index); + + Cond2 := New_Compare_Op + (ON_Ge, New_Obj_Value (Res), + New_Lit (Chap7.Translate_Static_Range_Length (Index_Range)), + Ghdl_Bool_Type); + Check_Bound_Error (Cond2, Expr, Dim); + Index := New_Obj_Value (Res); + end if; + + return Index; + end if; + end Translate_Thin_Index_Offset; + + -- Translate an indexed name. + type Indexed_Name_Data is record + Offset : O_Dnode; + Res : Mnode; + end record; + + function Translate_Indexed_Name_Init (Prefix_Orig : Mnode; Expr : Iir) + return Indexed_Name_Data + is + Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + Prefix_Info : constant Type_Info_Acc := Get_Info (Prefix_Type); + Index_List : constant Iir_List := Get_Index_List (Expr); + Type_List : constant Iir_List := Get_Index_Subtype_List (Prefix_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Prefix : Mnode; + Index : Iir; + Offset : O_Dnode; + R : O_Enode; + Length : O_Enode; + Itype : Iir; + Ibasetype : Iir; + Range_Ptr : Mnode; + begin + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array => + Prefix := Stabilize (Prefix_Orig); + when Type_Mode_Array => + Prefix := Prefix_Orig; + when others => + raise Internal_Error; + end case; + Offset := Create_Temp (Ghdl_Index_Type); + for Dim in 1 .. Nbr_Dim loop + Index := Get_Nth_Element (Index_List, Dim - 1); + Itype := Get_Index_Type (Type_List, Dim - 1); + Ibasetype := Get_Base_Type (Itype); + Open_Temp; + -- Compute index for the current dimension. + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array => + Range_Ptr := Stabilize + (Chap3.Get_Array_Range (Prefix, Prefix_Type, Dim)); + R := Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression (Index, Ibasetype), + Null_Iir, Itype, Index); + when Type_Mode_Array => + if Prefix_Info.Type_Locally_Constrained then + R := Translate_Thin_Index_Offset (Itype, Dim, Index); + else + -- Manually extract range since there is no infos for + -- index subtype. + Range_Ptr := Chap3.Bounds_To_Range + (Chap3.Get_Array_Type_Bounds (Prefix_Type), + Prefix_Type, Dim); + Stabilize (Range_Ptr); + R := Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression (Index, Ibasetype), + Index, Itype, Index); + end if; + when others => + raise Internal_Error; + end case; + if Dim = 1 then + -- First dimension. + New_Assign_Stmt (New_Obj (Offset), R); + else + -- If there are more dimension(s) to follow, then multiply + -- the current offset by the length of the current dimension. + if Prefix_Info.Type_Locally_Constrained then + Length := New_Lit (Chap7.Translate_Static_Range_Length + (Get_Range_Constraint (Itype))); + else + Length := M2E (Chap3.Range_To_Length (Range_Ptr)); + end if; + New_Assign_Stmt + (New_Obj (Offset), + New_Dyadic_Op (ON_Add_Ov, + New_Dyadic_Op (ON_Mul_Ov, + New_Obj_Value (Offset), + Length), + R)); + end if; + Close_Temp; + end loop; + + return (Offset => Offset, + Res => Chap3.Index_Base + (Chap3.Get_Array_Base (Prefix), Prefix_Type, + New_Obj_Value (Offset))); + end Translate_Indexed_Name_Init; + + function Translate_Indexed_Name_Finish + (Prefix : Mnode; Expr : Iir; Data : Indexed_Name_Data) + return Mnode + is + begin + return Chap3.Index_Base (Chap3.Get_Array_Base (Prefix), + Get_Type (Get_Prefix (Expr)), + New_Obj_Value (Data.Offset)); + end Translate_Indexed_Name_Finish; + + function Translate_Indexed_Name (Prefix : Mnode; Expr : Iir) + return Mnode + is + begin + return Translate_Indexed_Name_Init (Prefix, Expr).Res; + end Translate_Indexed_Name; + + type Slice_Name_Data is record + Off : Unsigned_64; + Is_Off : Boolean; + + Unsigned_Diff : O_Dnode; + + -- Variable pointing to the prefix. + Prefix_Var : Mnode; + + -- Variable pointing to slice. + Slice_Range : Mnode; + end record; + + procedure Translate_Slice_Name_Init + (Prefix : Mnode; Expr : Iir_Slice_Name; Data : out Slice_Name_Data) + is + -- Type of the prefix. + Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + + -- Type info of the prefix. + Prefix_Info : Type_Info_Acc; + + -- Type of the first (and only) index of the prefix array type. + Index_Type : constant Iir := Get_Index_Type (Prefix_Type, 0); + + -- Type of the slice. + Slice_Type : constant Iir := Get_Type (Expr); + Slice_Info : Type_Info_Acc; + + -- True iff the direction of the slice is known at compile time. + Static_Range : Boolean; + + -- Suffix of the slice (discrete range). + Expr_Range : constant Iir := Get_Suffix (Expr); + + -- Variable pointing to the prefix. + Prefix_Var : Mnode; + + -- Type info of the range base type. + Index_Info : Type_Info_Acc; + + -- Variables pointing to slice and prefix ranges. + Slice_Range : Mnode; + Prefix_Range : Mnode; + + Diff : O_Dnode; + Unsigned_Diff : O_Dnode; + If_Blk, If_Blk1 : O_If_Block; + begin + -- Evaluate slice bounds. + Chap3.Create_Array_Subtype (Slice_Type, True); + + -- The info may have just been created. + Prefix_Info := Get_Info (Prefix_Type); + Slice_Info := Get_Info (Slice_Type); + + if Slice_Info.Type_Mode = Type_Mode_Array + and then Slice_Info.Type_Locally_Constrained + and then Prefix_Info.Type_Mode = Type_Mode_Array + and then Prefix_Info.Type_Locally_Constrained + then + Data.Is_Off := True; + Data.Prefix_Var := Prefix; + + -- Both prefix and result are constrained array. + declare + Prefix_Left, Slice_Left : Iir_Int64; + Off : Iir_Int64; + Slice_Index_Type : Iir; + Slice_Range : Iir; + Slice_Length : Iir_Int64; + Index_Range : Iir; + begin + Index_Range := Get_Range_Constraint (Index_Type); + Prefix_Left := Eval_Pos (Get_Left_Limit (Index_Range)); + Slice_Index_Type := Get_Index_Type (Slice_Type, 0); + Slice_Range := Get_Range_Constraint (Slice_Index_Type); + Slice_Left := Eval_Pos (Get_Left_Limit (Slice_Range)); + Slice_Length := Eval_Discrete_Range_Length (Slice_Range); + if Slice_Length = 0 then + -- Null slice. + Data.Off := 0; + return; + end if; + if Get_Direction (Index_Range) /= Get_Direction (Slice_Range) + then + -- This is allowed with vhdl87 + Off := 0; + Slice_Length := 0; + else + -- Both prefix and slice are thin array. + case Get_Direction (Index_Range) is + when Iir_To => + Off := Slice_Left - Prefix_Left; + when Iir_Downto => + Off := Prefix_Left - Slice_Left; + end case; + if Off < 0 then + -- Must have been caught by sem. + raise Internal_Error; + end if; + if Off + Slice_Length + > Eval_Discrete_Range_Length (Index_Range) + then + -- Must have been caught by sem. + raise Internal_Error; + end if; + end if; + Data.Off := Unsigned_64 (Off); + + return; + end; + end if; + + Data.Is_Off := False; + + -- Save prefix. + Prefix_Var := Stabilize (Prefix); + + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + + -- Save prefix bounds. + Prefix_Range := Stabilize + (Chap3.Get_Array_Range (Prefix_Var, Prefix_Type, 1)); + + -- Save slice bounds. + Slice_Range := Stabilize + (Chap3.Bounds_To_Range (Chap3.Get_Array_Type_Bounds (Slice_Type), + Slice_Type, 1)); + + -- TRUE if the direction of the slice is known. + Static_Range := Get_Kind (Expr_Range) = Iir_Kind_Range_Expression; + + -- Check direction against same direction, error if different. + -- FIXME: what about v87 -> if different then null slice + if not Static_Range + or else Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition + then + -- Check same direction. + Check_Bound_Error + (New_Compare_Op (ON_Neq, + M2E (Chap3.Range_To_Dir (Prefix_Range)), + M2E (Chap3.Range_To_Dir (Slice_Range)), + Ghdl_Bool_Type), + Expr, 1); + end if; + + Unsigned_Diff := Create_Temp (Ghdl_Index_Type); + + -- Check if not a null slice. + -- The bounds of a null slice may be out of range. So DIFF cannot + -- be computed by substraction. + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + M2E (Chap3.Range_To_Length (Slice_Range)), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Unsigned_Diff), New_Lit (Ghdl_Index_0)); + New_Else_Stmt (If_Blk); + Diff := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + -- Compute the offset in the prefix. + if not Static_Range then + Start_If_Stmt + (If_Blk1, New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Slice_Range)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + end if; + if not Static_Range or else Get_Direction (Expr_Range) = Iir_To then + -- Diff = slice - bounds. + New_Assign_Stmt + (New_Obj (Diff), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Chap3.Range_To_Left (Slice_Range)), + M2E (Chap3.Range_To_Left (Prefix_Range)))); + end if; + if not Static_Range then + New_Else_Stmt (If_Blk1); + end if; + if not Static_Range or else Get_Direction (Expr_Range) = Iir_Downto + then + -- Diff = bounds - slice. + New_Assign_Stmt + (New_Obj (Diff), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Chap3.Range_To_Left (Prefix_Range)), + M2E (Chap3.Range_To_Left (Slice_Range)))); + end if; + if not Static_Range then + Finish_If_Stmt (If_Blk1); + end if; + + -- Note: this also check for overflow. + New_Assign_Stmt + (New_Obj (Unsigned_Diff), + New_Convert_Ov (New_Obj_Value (Diff), Ghdl_Index_Type)); + + -- Check bounds. + declare + Err_1 : O_Enode; + Err_2 : O_Enode; + begin + -- Bounds error if left of slice is before left of prefix. + Err_1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Diff), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + -- Bounds error if right of slice is after right of prefix. + Err_2 := New_Compare_Op + (ON_Gt, + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Unsigned_Diff), + M2E (Chap3.Range_To_Length (Slice_Range))), + M2E (Chap3.Range_To_Length (Prefix_Range)), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Err_1, Err_2), Expr, 1); + end; + Finish_If_Stmt (If_Blk); + + Data.Slice_Range := Slice_Range; + Data.Prefix_Var := Prefix_Var; + Data.Unsigned_Diff := Unsigned_Diff; + Data.Is_Off := False; + end Translate_Slice_Name_Init; + + function Translate_Slice_Name_Finish + (Prefix : Mnode; Expr : Iir_Slice_Name; Data : Slice_Name_Data) + return Mnode + is + -- Type of the slice. + Slice_Type : constant Iir := Get_Type (Expr); + Slice_Info : constant Type_Info_Acc := Get_Info (Slice_Type); + + -- Object kind of the prefix. + Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); + + Res_D : O_Dnode; + begin + if Data.Is_Off then + return Chap3.Slice_Base + (Prefix, Slice_Type, New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Data.Off))); + else + -- Create the result (fat array) and assign the bounds field. + case Slice_Info.Type_Mode is + when Type_Mode_Fat_Array => + Res_D := Create_Temp (Slice_Info.Ortho_Type (Kind)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res_D), + Slice_Info.T.Bounds_Field (Kind)), + New_Value (M2Lp (Data.Slice_Range))); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res_D), + Slice_Info.T.Base_Field (Kind)), + M2E (Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, + New_Obj_Value (Data.Unsigned_Diff)))); + return Dv2M (Res_D, Slice_Info, Kind); + when Type_Mode_Array => + return Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, + New_Obj_Value (Data.Unsigned_Diff)); + when others => + raise Internal_Error; + end case; + end if; + end Translate_Slice_Name_Finish; + + function Translate_Slice_Name (Prefix : Mnode; Expr : Iir_Slice_Name) + return Mnode + is + Data : Slice_Name_Data; + begin + Translate_Slice_Name_Init (Prefix, Expr, Data); + return Translate_Slice_Name_Finish (Data.Prefix_Var, Expr, Data); + end Translate_Slice_Name; + + function Translate_Interface_Name + (Inter : Iir; Info : Ortho_Info_Acc; Kind : Object_Kind_Type) + return Mnode + is + Type_Info : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); + begin + case Info.Kind is + when Kind_Object => + -- For a generic or a port. + return Get_Var (Info.Object_Var, Type_Info, Kind); + when Kind_Interface => + -- For a parameter. + if Info.Interface_Field = O_Fnode_Null then + -- Normal case: the parameter was translated as an ortho + -- interface. + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Dv2M (Info.Interface_Node, Type_Info, Kind); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + -- Parameter is passed by reference. + return Dp2M (Info.Interface_Node, Type_Info, Kind); + end case; + else + -- The parameter was put somewhere else. + declare + Subprg : constant Iir := Get_Parent (Inter); + Subprg_Info : constant Subprg_Info_Acc := + Get_Info (Subprg); + Linter : O_Lnode; + begin + if Info.Interface_Node = O_Dnode_Null then + -- The parameter is passed via a field of the RESULT + -- record parameter. + if Subprg_Info.Res_Record_Var = Null_Var then + Linter := New_Obj (Subprg_Info.Res_Interface); + else + -- Unnesting case. + Linter := Get_Var (Subprg_Info.Res_Record_Var); + end if; + return Lv2M (New_Selected_Element + (New_Acc_Value (Linter), + Info.Interface_Field), + Type_Info, Kind); + else + -- Unnesting case: the parameter was copied in the + -- subprogram frame so that nested subprograms can + -- reference it. Use field in FRAME. + Linter := New_Selected_Element + (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Scope), + Info.Interface_Field); + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Lv2M (Linter, Type_Info, Kind); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + -- Parameter is passed by reference. + return Lp2M (Linter, Type_Info, Kind); + end case; + end if; + end; + end if; + when others => + raise Internal_Error; + end case; + end Translate_Interface_Name; + + function Translate_Selected_Element (Prefix : Mnode; + El : Iir_Element_Declaration) + return Mnode + is + El_Info : constant Field_Info_Acc := Get_Info (El); + El_Type : constant Iir := Get_Type (El); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); + Stable_Prefix : Mnode; + begin + if Is_Complex_Type (El_Tinfo) then + -- The element is in fact an offset. + Stable_Prefix := Stabilize (Prefix); + return E2M + (New_Unchecked_Address + (New_Slice + (New_Access_Element + (New_Unchecked_Address + (M2Lv (Stable_Prefix), Char_Ptr_Type)), + Chararray_Type, + New_Value + (New_Selected_Element (M2Lv (Stable_Prefix), + El_Info.Field_Node (Kind)))), + El_Tinfo.Ortho_Ptr_Type (Kind)), + El_Tinfo, Kind); + else + return Lv2M (New_Selected_Element (M2Lv (Prefix), + El_Info.Field_Node (Kind)), + El_Tinfo, Kind); + end if; + end Translate_Selected_Element; + +-- function Translate_Formal_Interface_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir; +-- Kind : Object_Kind_Type) +-- return Mnode +-- is +-- Type_Info : Type_Info_Acc; +-- Info : Ortho_Info_Acc; +-- Res : Mnode; +-- begin +-- Type_Info := Get_Info (Get_Type (Name)); +-- Info := Get_Info (Name); +-- Push_Scope_Soft (Scope_Type, Scope_Param); +-- Res := Get_Var (Info.Object_Var, Type_Info, Kind); +-- Clear_Scope_Soft (Scope_Type); +-- return Res; +-- end Translate_Formal_Interface_Name; + +-- function Translate_Formal_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir) +-- return Mnode +-- is +-- Prefix : Iir; +-- Prefix_Name : Mnode; +-- begin +-- case Get_Kind (Name) is +-- when Iir_Kind_Interface_Constant_Declaration => +-- return Translate_Formal_Interface_Name +-- (Scope_Type, Scope_Param, Name, Mode_Value); + +-- when Iir_Kind_Interface_Signal_Declaration => +-- return Translate_Formal_Interface_Name +-- (Scope_Type, Scope_Param, Name, Mode_Signal); + +-- when Iir_Kind_Indexed_Name => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Indexed_Name (Prefix_Name, Name); + +-- when Iir_Kind_Slice_Name => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Slice_Name (Prefix_Name, Name); + +-- when Iir_Kind_Selected_Element => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Selected_Element +-- (Prefix_Name, Get_Selected_Element (Name)); + +-- when others => +-- Error_Kind ("translate_generic_name", Name); +-- end case; +-- end Translate_Formal_Name; + + function Translate_Name (Name : Iir) return Mnode + is + Name_Type : constant Iir := Get_Type (Name); + Name_Info : constant Ortho_Info_Acc := Get_Info (Name); + Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); + begin + case Get_Kind (Name) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration => + return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Value); + + when Iir_Kind_Attribute_Name => + return Translate_Name (Get_Named_Entity (Name)); + when Iir_Kind_Attribute_Value => + return Get_Var + (Get_Info (Get_Attribute_Specification (Name)).Object_Var, + Type_Info, Mode_Value); + + when Iir_Kind_Object_Alias_Declaration => + -- Alias_Var is not like an object variable, since it is + -- always a pointer to the aliased object. + declare + R : O_Lnode; + begin + R := Get_Var (Name_Info.Alias_Var); + case Type_Info.Type_Mode is + when Type_Mode_Fat_Array => + return Get_Var (Name_Info.Alias_Var, Type_Info, + Name_Info.Alias_Kind); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Acc + | Type_Mode_Fat_Acc => + R := Get_Var (Name_Info.Alias_Var); + return Lp2M (R, Type_Info, Name_Info.Alias_Kind); + when Type_Mode_Scalar => + R := Get_Var (Name_Info.Alias_Var); + if Name_Info.Alias_Kind = Mode_Signal then + return Lv2M (R, Type_Info, Name_Info.Alias_Kind); + else + return Lp2M (R, Type_Info, Name_Info.Alias_Kind); + end if; + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Guard_Signal_Declaration => + return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); + + when Iir_Kind_Interface_Constant_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_File_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_Variable_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_Signal_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Signal); + + when Iir_Kind_Indexed_Name => + return Translate_Indexed_Name + (Translate_Name (Get_Prefix (Name)), Name); + + when Iir_Kind_Slice_Name => + return Translate_Slice_Name + (Translate_Name (Get_Prefix (Name)), Name); + + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + declare + Pfx : O_Enode; + begin + Pfx := Chap7.Translate_Expression (Get_Prefix (Name)); + -- FIXME: what about fat pointer ?? + return Lv2M (New_Access_Element (Pfx), + Type_Info, Mode_Value); + end; + + when Iir_Kind_Selected_Element => + return Translate_Selected_Element + (Translate_Name (Get_Prefix (Name)), + Get_Selected_Element (Name)); + + when Iir_Kind_Function_Call => + -- This can appear as a prefix of a name, therefore, the + -- result is always a composite type or an access type. + declare + Imp : constant Iir := Get_Implementation (Name); + Obj : Iir; + Assoc_Chain : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration + then + -- FIXME : to be done + raise Internal_Error; + else + Canon.Canon_Subprogram_Call (Name); + Assoc_Chain := Get_Parameter_Association_Chain (Name); + Obj := Get_Method_Object (Name); + return E2M + (Chap7.Translate_Function_Call (Imp, Assoc_Chain, Obj), + Type_Info, Mode_Value); + end if; + end; + + when Iir_Kind_Image_Attribute => + -- Can appear as a prefix. + return E2M (Chap14.Translate_Image_Attribute (Name), + Type_Info, Mode_Value); + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Translate_Name (Get_Named_Entity (Name)); + + when others => + Error_Kind ("translate_name", Name); + end case; + end Translate_Name; + + procedure Translate_Direct_Driver + (Name : Iir; Sig : out Mnode; Drv : out Mnode) + is + Name_Type : constant Iir := Get_Type (Name); + Name_Info : constant Ortho_Info_Acc := Get_Info (Name); + Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Translate_Direct_Driver (Get_Named_Entity (Name), Sig, Drv); + when Iir_Kind_Object_Alias_Declaration => + Translate_Direct_Driver (Get_Name (Name), Sig, Drv); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Sig := Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); + Drv := Get_Var (Name_Info.Object_Driver, Type_Info, Mode_Value); + when Iir_Kind_Slice_Name => + declare + Data : Slice_Name_Data; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + Translate_Slice_Name_Init (Pfx_Sig, Name, Data); + Sig := Translate_Slice_Name_Finish + (Data.Prefix_Var, Name, Data); + Drv := Translate_Slice_Name_Finish (Pfx_Drv, Name, Data); + end; + when Iir_Kind_Indexed_Name => + declare + Data : Indexed_Name_Data; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + Data := Translate_Indexed_Name_Init (Pfx_Sig, Name); + Sig := Data.Res; + Drv := Translate_Indexed_Name_Finish (Pfx_Drv, Name, Data); + end; + when Iir_Kind_Selected_Element => + declare + El : Iir; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + El := Get_Selected_Element (Name); + Sig := Translate_Selected_Element (Pfx_Sig, El); + Drv := Translate_Selected_Element (Pfx_Drv, El); + end; + when others => + Error_Kind ("translate_direct_driver", Name); + end case; + end Translate_Direct_Driver; + end Chap6; + + package body Chap7 is + function Is_Static_Constant (Decl : Iir_Constant_Declaration) + return Boolean + is + Expr : constant Iir := Get_Default_Value (Decl); + Atype : Iir; + Info : Iir; + begin + if Expr = Null_Iir + or else Get_Kind (Expr) = Iir_Kind_Overflow_Literal + then + -- Deferred constant. + return False; + end if; + + if Get_Expr_Staticness (Decl) = Locally then + return True; + end if; + + -- Only aggregates are handled. + if Get_Kind (Expr) /= Iir_Kind_Aggregate then + return False; + end if; + + Atype := Get_Type (Decl); + -- Bounds must be known (and static). + if Get_Type_Staticness (Atype) /= Locally then + return False; + end if; + + -- Currently, only array aggregates are handled. + if Get_Kind (Get_Base_Type (Atype)) /= Iir_Kind_Array_Type_Definition + then + return False; + end if; + + -- Aggregate elements must be locally static. + -- Note: this does not yet handled aggregates of aggregates. + if Get_Value_Staticness (Expr) /= Locally then + return False; + end if; + Info := Get_Aggregate_Info (Expr); + while Info /= Null_Iir loop + if Get_Aggr_Dynamic_Flag (Info) then + raise Internal_Error; + end if; + + -- Currently, only positionnal aggregates are handled. + if Get_Aggr_Named_Flag (Info) then + return False; + end if; + -- Currently, others choice are not handled. + if Get_Aggr_Others_Flag (Info) then + return False; + end if; + + Info := Get_Sub_Aggregate_Info (Info); + end loop; + return True; + end Is_Static_Constant; + + procedure Translate_Static_String_Literal_Inner + (List : in out O_Array_Aggr_List; + Str : Iir; + El_Type : Iir) + is + use Name_Table; + + Literal_List : Iir_List; + Lit : Iir; + Len : Nat32; + Ptr : String_Fat_Acc; + begin + Literal_List := + Get_Enumeration_Literal_List (Get_Base_Type (El_Type)); + Len := Get_String_Length (Str); + Ptr := Get_String_Fat_Acc (Str); + for I in 1 .. Len loop + Lit := Find_Name_In_List (Literal_List, Get_Identifier (Ptr (I))); + New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); + end loop; + end Translate_Static_String_Literal_Inner; + + procedure Translate_Static_Bit_String_Literal_Inner + (List : in out O_Array_Aggr_List; + Lit : Iir_Bit_String_Literal; + El_Type : Iir) + is + pragma Unreferenced (El_Type); + L_0 : O_Cnode; + L_1 : O_Cnode; + Ptr : String_Fat_Acc; + Len : Nat32; + V : O_Cnode; + begin + L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit)); + L_1 := Get_Ortho_Expr (Get_Bit_String_1 (Lit)); + Ptr := Get_String_Fat_Acc (Lit); + Len := Get_String_Length (Lit); + for I in 1 .. Len loop + case Ptr (I) is + when '0' => + V := L_0; + when '1' => + V := L_1; + when others => + raise Internal_Error; + end case; + New_Array_Aggr_El (List, V); + end loop; + end Translate_Static_Bit_String_Literal_Inner; + + procedure Translate_Static_Aggregate_1 (List : in out O_Array_Aggr_List; + Aggr : Iir; + Info : Iir; + El_Type : Iir) + is + Assoc : Iir; + N_Info : Iir; + Sub : Iir; + begin + N_Info := Get_Sub_Aggregate_Info (Info); + + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + Assoc := Get_Association_Choices_Chain (Aggr); + while Assoc /= Null_Iir loop + Sub := Get_Associated_Expr (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if N_Info = Null_Iir then + New_Array_Aggr_El + (List, + Translate_Static_Expression (Sub, El_Type)); + else + Translate_Static_Aggregate_1 + (List, Sub, N_Info, El_Type); + end if; + when others => + Error_Kind ("translate_static_aggregate_1(2)", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + when Iir_Kind_String_Literal => + if N_Info /= Null_Iir then + raise Internal_Error; + end if; + Translate_Static_String_Literal_Inner (List, Aggr, El_Type); + when Iir_Kind_Bit_String_Literal => + if N_Info /= Null_Iir then + raise Internal_Error; + end if; + Translate_Static_Bit_String_Literal_Inner (List, Aggr, El_Type); + when others => + Error_Kind ("translate_static_aggregate_1", Aggr); + end case; + end Translate_Static_Aggregate_1; + + function Translate_Static_Aggregate (Aggr : Iir) + return O_Cnode + is + Aggr_Type : constant Iir := Get_Type (Aggr); + El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); + Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); + + Translate_Static_Aggregate_1 + (List, Aggr, Get_Aggregate_Info (Aggr), El_Type); + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Aggregate; + + function Translate_Static_Simple_Aggregate (Aggr : Iir) + return O_Cnode + is + Aggr_Type : Iir; + El_List : Iir_List; + El : Iir; + El_Type : Iir; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Aggr_Type := Get_Type (Aggr); + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); + El_Type := Get_Element_Subtype (Aggr_Type); + El_List := Get_Simple_Aggregate_List (Aggr); + Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); + + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + New_Array_Aggr_El + (List, Translate_Static_Expression (El, El_Type)); + end loop; + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Simple_Aggregate; + + function Translate_Static_String_Literal (Str : Iir) + return O_Cnode + is + use Name_Table; + + Lit_Type : Iir; + Element_Type : Iir; + Arr_Type : O_Tnode; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Lit_Type := Get_Type (Str); + + Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value); + + Start_Array_Aggr (List, Arr_Type); + + Element_Type := Get_Element_Subtype (Lit_Type); + + Translate_Static_String_Literal_Inner (List, Str, Element_Type); + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_String_Literal; + + -- Create a variable (constant) for string or bit string literal STR. + -- The type of the literal element is ELEMENT_TYPE, and the ortho type + -- of the string (a constrained array type) is STR_TYPE. + function Create_String_Literal_Var_Inner + (Str : Iir; Element_Type : Iir; Str_Type : O_Tnode) + return Var_Type + is + use Name_Table; + + Val_Aggr : O_Array_Aggr_List; + Res : O_Cnode; + begin + Start_Array_Aggr (Val_Aggr, Str_Type); + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Translate_Static_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when Iir_Kind_Bit_String_Literal => + Translate_Static_Bit_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when others => + raise Internal_Error; + end case; + Finish_Array_Aggr (Val_Aggr, Res); + + return Create_Global_Const + (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res); + end Create_String_Literal_Var_Inner; + + -- Create a variable (constant) for string or bit string literal STR. + function Create_String_Literal_Var (Str : Iir) return Var_Type is + use Name_Table; + + Str_Type : constant Iir := Get_Type (Str); + Arr_Type : O_Tnode; + begin + -- Create the string value. + Arr_Type := New_Constrained_Array_Type + (Get_Info (Str_Type).T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Get_String_Length (Str)))); + + return Create_String_Literal_Var_Inner + (Str, Get_Element_Subtype (Str_Type), Arr_Type); + end Create_String_Literal_Var; + + -- Some strings literal have an unconstrained array type, + -- eg: 'image of constant. Its type is not constrained + -- because it is not so in VHDL! + function Translate_Non_Static_String_Literal (Str : Iir) + return O_Enode + is + use Name_Table; + + Lit_Type : constant Iir := Get_Type (Str); + Type_Info : constant Type_Info_Acc := Get_Info (Lit_Type); + Index_Type : constant Iir := Get_Index_Type (Lit_Type, 0); + Index_Type_Info : constant Type_Info_Acc := Get_Info (Index_Type); + Bound_Aggr : O_Record_Aggr_List; + Index_Aggr : O_Record_Aggr_List; + Res_Aggr : O_Record_Aggr_List; + Res : O_Cnode; + Len : Int32; + Val : Var_Type; + Bound : Var_Type; + R : O_Enode; + begin + -- Create the string value. + Len := Get_String_Length (Str); + Val := Create_String_Literal_Var (Str); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Create the string bound. + Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type); + Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal + (Index_Type_Info.Ortho_Type (Mode_Value), 0)); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), + Integer_64 (Len - 1))); + New_Record_Aggr_El + (Index_Aggr, Ghdl_Dir_To_Node); + New_Record_Aggr_El + (Index_Aggr, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + Finish_Record_Aggr (Index_Aggr, Res); + New_Record_Aggr_El (Bound_Aggr, Res); + Finish_Record_Aggr (Bound_Aggr, Res); + Bound := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.T.Bounds_Type, + O_Storage_Private, Res); + + -- The descriptor. + Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Val), + Type_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Bound), + Type_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (Res_Aggr, Res); + + Val := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + elsif Type_Info.Type_Mode = Type_Mode_Array then + -- Type of string literal isn't statically known; check the + -- length. + Chap6.Check_Bound_Error + (New_Compare_Op + (ON_Neq, + New_Lit (New_Index_Lit (Unsigned_64 (Len))), + Chap3.Get_Array_Type_Length (Lit_Type), + Ghdl_Bool_Type), + Str, 1); + else + raise Internal_Error; + end if; + + R := New_Address (Get_Var (Val), + Type_Info.Ortho_Ptr_Type (Mode_Value)); + return R; + end Translate_Non_Static_String_Literal; + + -- Only for Strings of STD.Character. + function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id) + return O_Cnode + is + use Name_Table; + + Literal_List : Iir_List; + Lit : Iir; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Str_Type, True); + + Start_Array_Aggr (List, Get_Ortho_Type (Str_Type, Mode_Value)); + + Literal_List := + Get_Enumeration_Literal_List (Character_Type_Definition); + Image (Str_Ident); + for I in 1 .. Name_Length loop + Lit := Get_Nth_Element (Literal_List, + Character'Pos (Name_Buffer (I))); + New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); + end loop; + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_String; + + function Translate_Static_Bit_String_Literal + (Lit : Iir_Bit_String_Literal) + return O_Cnode + is + Lit_Type : Iir; + Res : O_Cnode; + List : O_Array_Aggr_List; + begin + Lit_Type := Get_Type (Lit); + Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); + Translate_Static_Bit_String_Literal_Inner (List, Lit, Lit_Type); + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Bit_String_Literal; + + function Translate_String_Literal (Str : Iir) return O_Enode + is + Str_Type : constant Iir := Get_Type (Str); + Var : Var_Type; + Info : Type_Info_Acc; + Res : O_Cnode; + R : O_Enode; + begin + if Get_Constraint_State (Str_Type) = Fully_Constrained + and then + Get_Type_Staticness (Get_Index_Type (Str_Type, 0)) = Locally + then + Chap3.Create_Array_Subtype (Str_Type, True); + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Res := Translate_Static_String_Literal (Str); + when Iir_Kind_Bit_String_Literal => + Res := Translate_Static_Bit_String_Literal (Str); + when Iir_Kind_Simple_Aggregate => + Res := Translate_Static_Simple_Aggregate (Str); + when Iir_Kind_Simple_Name_Attribute => + Res := Translate_Static_String + (Get_Type (Str), Get_Simple_Name_Identifier (Str)); + when others => + raise Internal_Error; + end case; + Info := Get_Info (Str_Type); + Var := Create_Global_Const + (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); + return R; + else + return Translate_Non_Static_String_Literal (Str); + end if; + end Translate_String_Literal; + + function Translate_Static_Implicit_Conv + (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) return O_Cnode + is + Expr_Info : Type_Info_Acc; + Res_Info : Type_Info_Acc; + Val : Var_Type; + Res : O_Cnode; + List : O_Record_Aggr_List; + Bound : Var_Type; + begin + if Res_Type = Expr_Type then + return Expr; + end if; + if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then + raise Internal_Error; + end if; + if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition then + return Expr; + end if; + if Get_Kind (Res_Type) /= Iir_Kind_Array_Type_Definition then + raise Internal_Error; + end if; + Expr_Info := Get_Info (Expr_Type); + Res_Info := Get_Info (Res_Type); + Val := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Expr); + Bound := Expr_Info.T.Array_Bounds; + if Bound = Null_Var then + Bound := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type, + O_Storage_Private, + Chap3.Create_Static_Array_Subtype_Bounds (Expr_Type)); + Expr_Info.T.Array_Bounds := Bound; + end if; + + Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Val), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Bound), + Expr_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (List, Res); + return Res; + end Translate_Static_Implicit_Conv; + + function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) + return O_Cnode + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return New_Signed_Literal + (Res_Type, Integer_64 (Get_Value (Expr))); + + when Iir_Kind_Enumeration_Literal => + return Get_Ortho_Expr (Get_Enumeration_Decl (Expr)); + + when Iir_Kind_Floating_Point_Literal => + return New_Float_Literal + (Res_Type, IEEE_Float_64 (Get_Fp_Value (Expr))); + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return New_Signed_Literal + (Res_Type, Integer_64 (Get_Physical_Value (Expr))); + + when others => + Error_Kind ("translate_numeric_literal", Expr); + end case; + exception + when Constraint_Error => + -- Can be raised by Get_Physical_Unit_Value because of the kludge + -- on staticness. + Error_Msg_Elab ("numeric literal not in range", Expr); + return New_Signed_Literal (Res_Type, 0); + end Translate_Numeric_Literal; + + function Translate_Numeric_Literal (Expr : Iir; Res_Type : Iir) + return O_Cnode + is + Expr_Type : Iir; + Expr_Otype : O_Tnode; + Tinfo : Type_Info_Acc; + begin + Expr_Type := Get_Type (Expr); + Tinfo := Get_Info (Expr_Type); + if Res_Type /= Null_Iir then + Expr_Otype := Get_Ortho_Type (Res_Type, Mode_Value); + else + if Tinfo = null then + -- FIXME: this is a working kludge, in the case where EXPR_TYPE + -- is a subtype which was not yet translated. + -- (eg: evaluated array attribute) + Tinfo := Get_Info (Get_Base_Type (Expr_Type)); + end if; + Expr_Otype := Tinfo.Ortho_Type (Mode_Value); + end if; + return Translate_Numeric_Literal (Expr, Expr_Otype); + end Translate_Numeric_Literal; + + function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) + return O_Cnode + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Physical_Fp_Literal => + return Translate_Numeric_Literal (Expr, Res_Type); + + when Iir_Kind_String_Literal => + return Translate_Static_Implicit_Conv + (Translate_Static_String_Literal (Expr), Expr_Type, Res_Type); + when Iir_Kind_Bit_String_Literal => + return Translate_Static_Implicit_Conv + (Translate_Static_Bit_String_Literal (Expr), + Expr_Type, Res_Type); + when Iir_Kind_Simple_Aggregate => + return Translate_Static_Implicit_Conv + (Translate_Static_Simple_Aggregate (Expr), + Expr_Type, Res_Type); + when Iir_Kind_Aggregate => + return Translate_Static_Implicit_Conv + (Translate_Static_Aggregate (Expr), Expr_Type, Res_Type); + + when Iir_Kinds_Denoting_Name => + return Translate_Static_Expression + (Get_Named_Entity (Expr), Res_Type); + when others => + Error_Kind ("translate_static_expression", Expr); + end case; + end Translate_Static_Expression; + + function Translate_Static_Range_Left + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode + is + Left : O_Cnode; + Bound : Iir; + begin + Bound := Get_Left_Limit (Expr); + Left := Chap7.Translate_Static_Expression (Bound, Range_Type); +-- if Range_Type /= Null_Iir and then Get_Type (Bound) /= Range_Type then +-- Left := New_Convert_Ov +-- (Left, Get_Ortho_Type (Range_Type, Mode_Value)); +-- end if; + return Left; + end Translate_Static_Range_Left; + + function Translate_Static_Range_Right + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode + is + Right : O_Cnode; + begin + Right := Chap7.Translate_Static_Expression (Get_Right_Limit (Expr), + Range_Type); +-- if Range_Type /= Null_Iir then +-- Right := New_Convert_Ov +-- (Right, Get_Ortho_Type (Range_Type, Mode_Value)); +-- end if; + return Right; + end Translate_Static_Range_Right; + + function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode + is + begin + case Get_Direction (Expr) is + when Iir_To => + return Ghdl_Dir_To_Node; + when Iir_Downto => + return Ghdl_Dir_Downto_Node; + end case; + end Translate_Static_Range_Dir; + + function Translate_Static_Range_Length (Expr : Iir) return O_Cnode + is + Ulen : Unsigned_64; + begin + Ulen := Unsigned_64 (Eval_Discrete_Range_Length (Expr)); + return New_Unsigned_Literal (Ghdl_Index_Type, Ulen); + end Translate_Static_Range_Length; + + function Translate_Range_Expression_Left (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode + is + Left : O_Enode; + begin + Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); + if Range_Type /= Null_Iir then + Left := New_Convert_Ov (Left, + Get_Ortho_Type (Range_Type, Mode_Value)); + end if; + return Left; + end Translate_Range_Expression_Left; + + function Translate_Range_Expression_Right (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode + is + Right : O_Enode; + begin + Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); + if Range_Type /= Null_Iir then + Right := New_Convert_Ov (Right, + Get_Ortho_Type (Range_Type, Mode_Value)); + end if; + return Right; + end Translate_Range_Expression_Right; + + -- Compute the length of LEFT DIR (to/downto) RIGHT. + function Compute_Range_Length + (Left : O_Enode; Right : O_Enode; Dir : Iir_Direction) + return O_Enode + is + L : O_Enode; + R : O_Enode; + Val : O_Enode; + Tmp : O_Dnode; + Res : O_Dnode; + If_Blk : O_If_Block; + Rng_Type : O_Tnode; + begin + Rng_Type := Ghdl_I32_Type; + L := New_Convert_Ov (Left, Rng_Type); + R := New_Convert_Ov (Right, Rng_Type); + + case Dir is + when Iir_To => + Val := New_Dyadic_Op (ON_Sub_Ov, R, L); + when Iir_Downto => + Val := New_Dyadic_Op (ON_Sub_Ov, L, R); + end case; + + Res := Create_Temp (Ghdl_Index_Type); + Open_Temp; + Tmp := Create_Temp (Rng_Type); + New_Assign_Stmt (New_Obj (Tmp), Val); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Lt, New_Obj_Value (Tmp), + New_Lit (New_Signed_Literal (Rng_Type, 0)), + Ghdl_Bool_Type)); + Init_Var (Res); + New_Else_Stmt (If_Blk); + Val := New_Convert_Ov (New_Obj_Value (Tmp), Ghdl_Index_Type); + Val := New_Dyadic_Op (ON_Add_Ov, Val, New_Lit (Ghdl_Index_1)); + New_Assign_Stmt (New_Obj (Res), Val); + Finish_If_Stmt (If_Blk); + Close_Temp; + return New_Obj_Value (Res); + end Compute_Range_Length; + + function Translate_Range_Expression_Length (Expr : Iir) return O_Enode + is + Left, Right : O_Enode; + begin + if Get_Expr_Staticness (Expr) = Locally then + return New_Lit (Translate_Static_Range_Length (Expr)); + else + Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); + Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); + + return Compute_Range_Length (Left, Right, Get_Direction (Expr)); + end if; + end Translate_Range_Expression_Length; + + function Translate_Range_Length (Expr : Iir) return O_Enode is + begin + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + return Translate_Range_Expression_Length (Expr); + when Iir_Kind_Range_Array_Attribute => + return Chap14.Translate_Length_Array_Attribute (Expr, Null_Iir); + when others => + Error_Kind ("translate_range_length", Expr); + end case; + end Translate_Range_Length; + + function Translate_Association (Assoc : Iir) return O_Enode + is + Formal : constant Iir := Get_Formal (Assoc); + Formal_Base : constant Iir := Get_Association_Interface (Assoc); + Actual : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + when Iir_Kind_Association_Element_Open => + Actual := Get_Default_Value (Formal); + when others => + Error_Kind ("translate_association", Assoc); + end case; + + case Get_Kind (Formal_Base) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + return Chap3.Maybe_Insert_Scalar_Check + (Translate_Expression (Actual, Get_Type (Formal)), + Actual, Get_Type (Formal)); + when Iir_Kind_Interface_Signal_Declaration => + return Translate_Implicit_Conv + (M2E (Chap6.Translate_Name (Actual)), + Get_Type (Actual), + Get_Type (Formal_Base), + Mode_Signal, Assoc); + when others => + Error_Kind ("translate_association", Formal); + end case; + end Translate_Association; + + function Translate_Function_Call + (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) + return O_Enode + is + Info : constant Subprg_Info_Acc := Get_Info (Imp); + Constr : O_Assoc_List; + Assoc : Iir; + Res : Mnode; + begin + if Info.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + -- If we need to allocate, do it before starting the call! + declare + Res_Type : Iir; + Res_Info : Type_Info_Acc; + begin + Res_Type := Get_Return_Type (Imp); + Res_Info := Get_Info (Res_Type); + Res := Create_Temp (Res_Info); + if Res_Info.Type_Mode /= Type_Mode_Fat_Array then + Chap4.Allocate_Complex_Object (Res_Type, Alloc_Stack, Res); + end if; + end; + end if; + + Start_Association (Constr, Info.Ortho_Func); + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Association (Constr, M2E (Res)); + end if; + + -- If the subprogram is a method, pass the protected object. + if Obj /= Null_Iir then + New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + -- FIXME: evaluate expression before, because we + -- may allocate objects. + New_Association (Constr, Translate_Association (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + return M2E (Res); + else + return New_Function_Call (Constr); + end if; + end Translate_Function_Call; + + function Translate_Operator_Function_Call + (Imp : Iir; Left : Iir; Right : Iir; Res_Type : Iir) + return O_Enode + is + function Create_Assoc (Actual : Iir; Formal : Iir) + return Iir + is + R : Iir; + begin + R := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Location_Copy (R, Actual); + Set_Actual (R, Actual); + Set_Formal (R, Formal); + return R; + end Create_Assoc; + + Inter : Iir; + El_L : Iir; + El_R : Iir; + Res : O_Enode; + begin + Inter := Get_Interface_Declaration_Chain (Imp); + + El_L := Create_Assoc (Left, Inter); + + if Right /= Null_Iir then + Inter := Get_Chain (Inter); + El_R := Create_Assoc (Right, Inter); + Set_Chain (El_L, El_R); + end if; + + Res := Translate_Function_Call (Imp, El_L, Null_Iir); + + Free_Iir (El_L); + if Right /= Null_Iir then + Free_Iir (El_R); + end if; + + return Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Left); + end Translate_Operator_Function_Call; + + function Convert_Constrained_To_Unconstrained + (Expr : Mnode; Res_Type : Iir) + return Mnode + is + Type_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Expr); + Stable_Expr : Mnode; + Res : Mnode; + begin + Res := Create_Temp (Type_Info, Kind); + Stable_Expr := Stabilize (Expr); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (Stable_Expr)), + Type_Info.T.Base_Ptr_Type (Kind))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Stable_Expr))); + return Res; + end Convert_Constrained_To_Unconstrained; + + function Convert_Array_To_Thin_Array (Expr : Mnode; + Expr_Type : Iir; + Atype : Iir; + Loc : Iir) + return Mnode + is + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + Expr_Stable : Mnode; + Success_Label, Failure_Label : O_Snode; + begin + Expr_Stable := Stabilize (Expr); + + Open_Temp; + -- Check each dimension. + Start_Loop_Stmt (Success_Label); + Start_Loop_Stmt (Failure_Label); + for I in 1 .. Get_Nbr_Elements (Expr_Indexes) loop + Gen_Exit_When + (Failure_Label, + New_Compare_Op + (ON_Neq, + Chap6.Get_Array_Bound_Length + (Expr_Stable, Expr_Type, I), + Chap6.Get_Array_Bound_Length + (T2M (Atype, Get_Object_Kind (Expr_Stable)), Atype, I), + Ghdl_Bool_Type)); + end loop; + New_Exit_Stmt (Success_Label); + Finish_Loop_Stmt (Failure_Label); + Chap6.Gen_Bound_Error (Loc); + Finish_Loop_Stmt (Success_Label); + Close_Temp; + + return Chap3.Get_Array_Base (Expr_Stable); + end Convert_Array_To_Thin_Array; + + function Translate_Implicit_Array_Conversion + (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return Mnode + is + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + begin + pragma Assert + (Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition); + + if Res_Type = Expr_Type then + return Expr; + end if; + + Ainfo := Get_Info (Res_Type); + Einfo := Get_Info (Expr_Type); + case Ainfo.Type_Mode is + when Type_Mode_Fat_Array => + -- X to unconstrained. + case Einfo.Type_Mode is + when Type_Mode_Fat_Array => + -- unconstrained to unconstrained. + return Expr; + when Type_Mode_Array => + -- constrained to unconstrained. + return Convert_Constrained_To_Unconstrained + (Expr, Res_Type); + when others => + raise Internal_Error; + end case; + when Type_Mode_Array => + -- X to constrained. + if Einfo.Type_Locally_Constrained + and then Ainfo.Type_Locally_Constrained + then + -- FIXME: optimize static vs non-static + -- constrained to constrained. + if not Chap3.Locally_Array_Match (Expr_Type, Res_Type) then + -- FIXME: generate a bound error ? + -- Even if this is caught at compile-time, + -- the code is not required to run. + Chap6.Gen_Bound_Error (Loc); + end if; + return Expr; + else + -- Unbounded/bounded array to bounded array. + return Convert_Array_To_Thin_Array + (Expr, Expr_Type, Res_Type, Loc); + end if; + when others => + raise Internal_Error; + end case; + end Translate_Implicit_Array_Conversion; + + -- Convert (if necessary) EXPR translated from EXPR_ORIG to type ATYPE. + function Translate_Implicit_Conv (Expr : O_Enode; + Expr_Type : Iir; + Atype : Iir; + Is_Sig : Object_Kind_Type; + Loc : Iir) + return O_Enode is + begin + -- Same type: nothing to do. + if Atype = Expr_Type then + return Expr; + end if; + + if Expr_Type = Universal_Integer_Type_Definition then + return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); + elsif Expr_Type = Universal_Real_Type_Definition then + return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); + elsif Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition then + return M2E (Translate_Implicit_Array_Conversion + (E2M (Expr, Get_Info (Expr_Type), Is_Sig), + Expr_Type, Atype, Loc)); + else + return Expr; + end if; + end Translate_Implicit_Conv; + + type Predefined_To_Onop_Type is array (Iir_Predefined_Functions) + of ON_Op_Kind; + Predefined_To_Onop : constant Predefined_To_Onop_Type := + (Iir_Predefined_Boolean_Or => ON_Or, + Iir_Predefined_Boolean_Not => ON_Not, + Iir_Predefined_Boolean_And => ON_And, + Iir_Predefined_Boolean_Xor => ON_Xor, + + Iir_Predefined_Bit_Not => ON_Not, + Iir_Predefined_Bit_And => ON_And, + Iir_Predefined_Bit_Or => ON_Or, + Iir_Predefined_Bit_Xor => ON_Xor, + + Iir_Predefined_Integer_Equality => ON_Eq, + Iir_Predefined_Integer_Inequality => ON_Neq, + Iir_Predefined_Integer_Less_Equal => ON_Le, + Iir_Predefined_Integer_Less => ON_Lt, + Iir_Predefined_Integer_Greater => ON_Gt, + Iir_Predefined_Integer_Greater_Equal => ON_Ge, + Iir_Predefined_Integer_Plus => ON_Add_Ov, + Iir_Predefined_Integer_Minus => ON_Sub_Ov, + Iir_Predefined_Integer_Mul => ON_Mul_Ov, + Iir_Predefined_Integer_Rem => ON_Rem_Ov, + Iir_Predefined_Integer_Mod => ON_Mod_Ov, + Iir_Predefined_Integer_Div => ON_Div_Ov, + Iir_Predefined_Integer_Absolute => ON_Abs_Ov, + Iir_Predefined_Integer_Negation => ON_Neg_Ov, + + Iir_Predefined_Enum_Equality => ON_Eq, + Iir_Predefined_Enum_Inequality => ON_Neq, + Iir_Predefined_Enum_Greater_Equal => ON_Ge, + Iir_Predefined_Enum_Greater => ON_Gt, + Iir_Predefined_Enum_Less => ON_Lt, + Iir_Predefined_Enum_Less_Equal => ON_Le, + + Iir_Predefined_Physical_Equality => ON_Eq, + Iir_Predefined_Physical_Inequality => ON_Neq, + Iir_Predefined_Physical_Less => ON_Lt, + Iir_Predefined_Physical_Less_Equal => ON_Le, + Iir_Predefined_Physical_Greater => ON_Gt, + Iir_Predefined_Physical_Greater_Equal => ON_Ge, + Iir_Predefined_Physical_Negation => ON_Neg_Ov, + Iir_Predefined_Physical_Absolute => ON_Abs_Ov, + Iir_Predefined_Physical_Minus => ON_Sub_Ov, + Iir_Predefined_Physical_Plus => ON_Add_Ov, + + Iir_Predefined_Floating_Greater => ON_Gt, + Iir_Predefined_Floating_Greater_Equal => ON_Ge, + Iir_Predefined_Floating_Less => ON_Lt, + Iir_Predefined_Floating_Less_Equal => ON_Le, + Iir_Predefined_Floating_Equality => ON_Eq, + Iir_Predefined_Floating_Inequality => ON_Neq, + Iir_Predefined_Floating_Minus => ON_Sub_Ov, + Iir_Predefined_Floating_Plus => ON_Add_Ov, + Iir_Predefined_Floating_Mul => ON_Mul_Ov, + Iir_Predefined_Floating_Div => ON_Div_Ov, + Iir_Predefined_Floating_Negation => ON_Neg_Ov, + Iir_Predefined_Floating_Absolute => ON_Abs_Ov, + + others => ON_Nil); + + function Translate_Shortcut_Operator + (Imp : Iir_Implicit_Function_Declaration; Left, Right : Iir) + return O_Enode + is + Rtype : Iir; + Res : O_Dnode; + Res_Type : O_Tnode; + If_Blk : O_If_Block; + Val : Integer; + V : O_Cnode; + Kind : Iir_Predefined_Functions; + Invert : Boolean; + begin + Rtype := Get_Return_Type (Imp); + Res_Type := Get_Ortho_Type (Rtype, Mode_Value); + Res := Create_Temp (Res_Type); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Left)); + Close_Temp; + Kind := Get_Implicit_Definition (Imp); + + -- Short cut: RIGHT is the result (and must be evaluated) iff + -- LEFT is equal to VAL (ie '0' or false for 0, '1' or true for 1). + case Kind is + when Iir_Predefined_Bit_And + | Iir_Predefined_Boolean_And => + Invert := False; + Val := 1; + when Iir_Predefined_Bit_Nand + | Iir_Predefined_Boolean_Nand => + Invert := True; + Val := 1; + when Iir_Predefined_Bit_Or + | Iir_Predefined_Boolean_Or => + Invert := False; + Val := 0; + when Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_Nor => + Invert := True; + Val := 0; + when others => + Ada.Text_IO.Put_Line + ("translate_shortcut_operator: cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + end case; + + V := Get_Ortho_Expr + (Get_Nth_Element (Get_Enumeration_Literal_List (Rtype), Val)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Res), New_Lit (V), + Ghdl_Bool_Type)); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Right)); + Close_Temp; + Finish_If_Stmt (If_Blk); + if Invert then + return New_Monadic_Op (ON_Not, New_Obj_Value (Res)); + else + return New_Obj_Value (Res); + end if; + end Translate_Shortcut_Operator; + + function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Func); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + return New_Function_Call (Constr); + end Translate_Lib_Operator; + + function Translate_Predefined_Lib_Operator + (Left, Right : O_Enode; Func : Iir_Implicit_Function_Declaration) + return O_Enode + is + Info : constant Subprg_Info_Acc := Get_Info (Func); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + return New_Function_Call (Constr); + end Translate_Predefined_Lib_Operator; + + function Translate_Predefined_Array_Operator + (Left, Right : O_Enode; Func : Iir) + return O_Enode + is + Res : O_Dnode; + Constr : O_Assoc_List; + Info : Type_Info_Acc; + Func_Info : Subprg_Info_Acc; + begin + Create_Temp_Stack2_Mark; + Info := Get_Info (Get_Return_Type (Func)); + Res := Create_Temp (Info.Ortho_Type (Mode_Value)); + Func_Info := Get_Info (Func); + Start_Association (Constr, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Func_Info.Subprg_Instance); + New_Association (Constr, + New_Address (New_Obj (Res), + Info.Ortho_Ptr_Type (Mode_Value))); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), Info.Ortho_Ptr_Type (Mode_Value)); + end Translate_Predefined_Array_Operator; + + function Translate_Predefined_Array_Operator_Convert + (Left, Right : O_Enode; Func : Iir; Res_Type : Iir) + return O_Enode + is + Res : O_Enode; + Ret_Type : Iir; + begin + Ret_Type := Get_Return_Type (Func); + Res := Translate_Predefined_Array_Operator (Left, Right, Func); + return Translate_Implicit_Conv + (Res, Ret_Type, Res_Type, Mode_Value, Func); + end Translate_Predefined_Array_Operator_Convert; + + -- Create an array aggregate containing one element, EL. + function Translate_Element_To_Array (El : O_Enode; Arr_Type : Iir) + return O_Enode + is + Res : O_Dnode; + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + V : O_Dnode; + begin + Ainfo := Get_Info (Arr_Type); + Einfo := Get_Info (Get_Element_Subtype (Arr_Type)); + Res := Create_Temp (Ainfo.Ortho_Type (Mode_Value)); + if Is_Composite (Einfo) then + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Base_Field (Mode_Value)), + New_Convert_Ov (El, Ainfo.T.Base_Ptr_Type (Mode_Value))); + else + V := Create_Temp_Init (Einfo.Ortho_Type (Mode_Value), El); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Base_Field (Mode_Value)), + New_Convert_Ov (New_Address (New_Obj (V), + Einfo.Ortho_Ptr_Type (Mode_Value)), + Ainfo.T.Base_Ptr_Type (Mode_Value))); + end if; + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Bounds_Field (Mode_Value)), + New_Address (Get_Var (Ainfo.T.Array_1bound), + Ainfo.T.Bounds_Ptr_Type)); + return New_Address (New_Obj (Res), Ainfo.Ortho_Ptr_Type (Mode_Value)); + end Translate_Element_To_Array; + + function Translate_Concat_Operator + (Left_Tree, Right_Tree : O_Enode; + Imp : Iir_Implicit_Function_Declaration; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Ret_Type : constant Iir := Get_Return_Type (Imp); + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Arr_El1 : O_Enode; + Arr_El2 : O_Enode; + Res : O_Enode; + begin + case Kind is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Arr_El1 := Translate_Element_To_Array (Left_Tree, Ret_Type); + when others => + Arr_El1 := Left_Tree; + end case; + case Kind is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Arr_El2 := Translate_Element_To_Array (Right_Tree, Ret_Type); + when others => + Arr_El2 := Right_Tree; + end case; + Res := Translate_Predefined_Array_Operator (Arr_El1, Arr_El2, Imp); + return Translate_Implicit_Conv + (Res, Ret_Type, Res_Type, Mode_Value, Loc); + end Translate_Concat_Operator; + + function Translate_Scalar_Min_Max + (Op : ON_Op_Kind; + Left, Right : Iir; + Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + Res, L, R : O_Dnode; + If_Blk : O_If_Block; + begin + -- Create a variable for the result. + Res := Create_Temp (Res_Otype); + + Open_Temp; + L := Create_Temp_Init + (Res_Otype, Translate_Expression (Left, Res_Type)); + R := Create_Temp_Init + (Res_Otype, Translate_Expression (Right, Res_Type)); + + Start_If_Stmt (If_Blk, New_Compare_Op (Op, + New_Obj_Value (L), + New_Obj_Value (R), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (L)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (R)); + Finish_If_Stmt (If_Blk); + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Scalar_Min_Max; + + function Translate_Predefined_Vector_Min_Max (Is_Min : Boolean; + Left : Iir; + Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + Left_Type : constant Iir := Get_Type (Left); + Res, El, Len : O_Dnode; + Arr : Mnode; + If_Blk : O_If_Block; + Label : O_Snode; + Op : ON_Op_Kind; + begin + -- Create a variable for the result. + Res := Create_Temp (Res_Otype); + + Open_Temp; + if Is_Min then + Op := ON_Lt; + else + Op := ON_Gt; + end if; + New_Assign_Stmt + (New_Obj (Res), + Chap14.Translate_High_Low_Type_Attribute (Res_Type, Is_Min)); + + El := Create_Temp (Res_Otype); + Arr := Stabilize (E2M (Translate_Expression (Left), + Get_Info (Left_Type), Mode_Value)); + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Left_Type, 1)))); + + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- if ARR[LEN] </> RES then + -- RES := ARR[LEN]; + -- end if; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Obj (El), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Left_Type, New_Obj_Value (Len)))); + Start_If_Stmt (If_Blk, New_Compare_Op (Op, + New_Obj_Value (El), + New_Obj_Value (Res), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (El)); + Finish_If_Stmt (If_Blk); + Finish_Loop_Stmt (Label); + + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Predefined_Vector_Min_Max; + + function Translate_Std_Ulogic_Match (Func : O_Dnode; + L, R : O_Enode; + Res_Type : O_Tnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Func); + New_Association (Constr, New_Convert_Ov (L, Ghdl_I32_Type)); + New_Association (Constr, New_Convert_Ov (R, Ghdl_I32_Type)); + return New_Convert_Ov (New_Function_Call (Constr), Res_Type); + end Translate_Std_Ulogic_Match; + + function Translate_To_String (Subprg : O_Dnode; + Res_Type : Iir; + Loc : Iir; + Val : O_Enode; + Arg2 : O_Enode := O_Enode_Null; + Arg3 : O_Enode := O_Enode_Null) + return O_Enode + is + Val_Type : constant Iir := Get_Base_Type (Res_Type); + Res : O_Dnode; + Assoc : O_Assoc_List; + begin + Res := Create_Temp (Std_String_Node); + Create_Temp_Stack2_Mark; + Start_Association (Assoc, Subprg); + New_Association (Assoc, + New_Address (New_Obj (Res), Std_String_Ptr_Node)); + New_Association (Assoc, Val); + if Arg2 /= O_Enode_Null then + New_Association (Assoc, Arg2); + if Arg3 /= O_Enode_Null then + New_Association (Assoc, Arg3); + end if; + end if; + New_Procedure_Call (Assoc); + return M2E (Translate_Implicit_Array_Conversion + (Dv2M (Res, Get_Info (Val_Type), Mode_Value), + Val_Type, Res_Type, Loc)); + end Translate_To_String; + + function Translate_Bv_To_String (Subprg : O_Dnode; + Val : O_Enode; + Val_Type : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Arr : Mnode; + begin + Arr := Stabilize (E2M (Val, Get_Info (Val_Type), Mode_Value)); + return Translate_To_String + (Subprg, Res_Type, Loc, + M2E (Chap3.Get_Array_Base (Arr)), + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Val_Type, 1)))); + end Translate_Bv_To_String; + + subtype Predefined_Boolean_Logical is Iir_Predefined_Functions range + Iir_Predefined_Boolean_And .. Iir_Predefined_Boolean_Xnor; + + function Translate_Predefined_Logical + (Op : Predefined_Boolean_Logical; Left, Right : O_Enode) + return O_Enode is + begin + case Op is + when Iir_Predefined_Boolean_And => + return New_Dyadic_Op (ON_And, Left, Right); + when Iir_Predefined_Boolean_Or => + return New_Dyadic_Op (ON_Or, Left, Right); + when Iir_Predefined_Boolean_Nand => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_And, Left, Right)); + when Iir_Predefined_Boolean_Nor => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_Or, Left, Right)); + when Iir_Predefined_Boolean_Xor => + return New_Dyadic_Op (ON_Xor, Left, Right); + when Iir_Predefined_Boolean_Xnor => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_Xor, Left, Right)); + end case; + end Translate_Predefined_Logical; + + function Translate_Predefined_TF_Array_Element + (Op : Predefined_Boolean_Logical; + Left, Right : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Type (Left); + Res_Btype : constant Iir := Get_Base_Type (Res_Type); + Res_Info : constant Type_Info_Acc := Get_Info (Res_Btype); + Base_Ptr_Type : constant O_Tnode := + Res_Info.T.Base_Ptr_Type (Mode_Value); + Arr : Mnode; + El : O_Dnode; + Base : O_Dnode; + Len : O_Dnode; + Label : O_Snode; + Res : Mnode; + begin + -- Translate the array. + Arr := Stabilize (E2M (Translate_Expression (Left), + Get_Info (Arr_Type), Mode_Value)); + + -- Extract its length. + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); + + -- Allocate the result array. + Base := Create_Temp_Init + (Base_Ptr_Type, + Gen_Alloc (Alloc_Stack, New_Obj_Value (Len), Base_Ptr_Type)); + + Open_Temp; + -- Translate the element. + El := Create_Temp_Init (Get_Ortho_Type (Get_Type (Right), Mode_Value), + Translate_Expression (Right)); + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- BASE[LEN] := EL op ARR[LEN]; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Base), + New_Obj_Value (Len)), + Translate_Predefined_Logical + (Op, + New_Obj_Value (El), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Arr_Type, New_Obj_Value (Len))))); + Finish_Loop_Stmt (Label); + Close_Temp; + + Res := Create_Temp (Res_Info, Mode_Value); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), + New_Obj_Value (Base)); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Arr))); + + return Translate_Implicit_Conv (M2E (Res), Res_Btype, Res_Type, + Mode_Value, Loc); + end Translate_Predefined_TF_Array_Element; + + function Translate_Predefined_TF_Reduction + (Op : ON_Op_Kind; Operand : Iir; Res_Type : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Type (Operand); + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Res_Type)); + Init_Enum : Iir; + + Res : O_Dnode; + Arr_Expr : O_Enode; + Arr : Mnode; + Len : O_Dnode; + Label : O_Snode; + begin + if Op = ON_And then + Init_Enum := Get_Nth_Element (Enums, 1); + else + Init_Enum := Get_Nth_Element (Enums, 0); + end if; + + Res := Create_Temp_Init (Get_Ortho_Type (Res_Type, Mode_Value), + New_Lit (Get_Ortho_Expr (Init_Enum))); + + Open_Temp; + -- Translate the array. Note that Translate_Expression may create + -- the info for the array type, so be sure to call it before calling + -- Get_Info. + Arr_Expr := Translate_Expression (Operand); + Arr := Stabilize (E2M (Arr_Expr, Get_Info (Arr_Type), Mode_Value)); + + -- Extract its length. + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); + + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- RES := RES op ARR[LEN]; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Obj (Res), + New_Dyadic_Op + (Op, + New_Obj_Value (Res), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Arr_Type, New_Obj_Value (Len))))); + Finish_Loop_Stmt (Label); + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Predefined_TF_Reduction; + + function Translate_Predefined_Array_Min_Max + (Is_Min : Boolean; + Left, Right : O_Enode; + Left_Type, Right_Type : Iir; + Res_Type : Iir; + Imp : Iir; + Loc : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Base_Type (Left_Type); + Arr_Info : constant Type_Info_Acc := Get_Info (Arr_Type); + L, R : Mnode; + If_Blk : O_If_Block; + Res : Mnode; + begin + Res := Create_Temp (Arr_Info, Mode_Value); + L := Stabilize (E2M (Left, Get_Info (Left_Type), Mode_Value)); + R := Stabilize (E2M (Right, Get_Info (Right_Type), Mode_Value)); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (M2E (L), M2E (R), Imp), + New_Lit (Ghdl_Compare_Lt), + Std_Boolean_Type_Node)); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + end if; + New_Else_Stmt (If_Blk); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + end if; + Finish_If_Stmt (If_Blk); + + return M2E (Translate_Implicit_Array_Conversion + (Res, Arr_Type, Res_Type, Loc)); + end Translate_Predefined_Array_Min_Max; + + function Translate_Predefined_TF_Edge + (Is_Rising : Boolean; Left : Iir) + return O_Enode + is + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Left))); + Name : Mnode; + begin + Name := Stabilize (Chap6.Translate_Name (Left), True); + return New_Dyadic_Op + (ON_And, + New_Value (Chap14.Get_Signal_Field + (Name, Ghdl_Signal_Event_Field)), + New_Compare_Op + (ON_Eq, + New_Value (New_Access_Element (M2E (Name))), + New_Lit (Get_Ortho_Expr + (Get_Nth_Element (Enums, Boolean'Pos (Is_Rising)))), + Std_Boolean_Type_Node)); + end Translate_Predefined_TF_Edge; + + function Translate_Predefined_Std_Ulogic_Array_Match + (Subprg : O_Dnode; Left, Right : Iir; Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + L_Type : constant Iir := Get_Type (Left); + R_Type : constant Iir := Get_Type (Right); + L_Expr, R_Expr : O_Enode; + L, R : Mnode; + Assoc : O_Assoc_List; + + Res : O_Dnode; + begin + Res := Create_Temp (Ghdl_I32_Type); + + Open_Temp; + -- Translate the arrays. Note that Translate_Expression may create + -- the info for the array type, so be sure to call it before calling + -- Get_Info. + L_Expr := Translate_Expression (Left); + L := Stabilize (E2M (L_Expr, Get_Info (L_Type), Mode_Value)); + + R_Expr := Translate_Expression (Right); + R := Stabilize (E2M (R_Expr, Get_Info (R_Type), Mode_Value)); + + Start_Association (Assoc, Subprg); + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (L)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, L_Type, 1)))); + + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (R)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, R_Type, 1)))); + + New_Assign_Stmt (New_Obj (Res), New_Function_Call (Assoc)); + + Close_Temp; + + return New_Convert_Ov (New_Obj_Value (Res), Res_Otype); + end Translate_Predefined_Std_Ulogic_Array_Match; + + function Translate_Predefined_Operator + (Imp : Iir_Implicit_Function_Declaration; + Left, Right : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Left_Tree : O_Enode; + Right_Tree : O_Enode; + Left_Type : Iir; + Right_Type : Iir; + Res_Otype : O_Tnode; + Op : ON_Op_Kind; + Inter : Iir; + Res : O_Enode; + begin + case Kind is + when Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor => + -- Right operand of shortcur operators may not be evaluated. + return Translate_Shortcut_Operator (Imp, Left, Right); + + -- Operands of min/max are evaluated in a declare block. + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Integer_Minimum + | Iir_Predefined_Floating_Minimum + | Iir_Predefined_Physical_Minimum => + return Translate_Scalar_Min_Max (ON_Le, Left, Right, Res_Type); + when Iir_Predefined_Enum_Maximum + | Iir_Predefined_Integer_Maximum + | Iir_Predefined_Floating_Maximum + | Iir_Predefined_Physical_Maximum => + return Translate_Scalar_Min_Max (ON_Ge, Left, Right, Res_Type); + + -- Avoid implicit conversion of the array parameters to the + -- unbounded type for optimizing purpose. FIXME: should do the + -- same for the result. + when Iir_Predefined_TF_Array_Element_And => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_And => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Or => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Or => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Nand => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Nand => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Nor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Nor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Xor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Xor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Xnor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Xnor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Loc); + + -- Avoid implicit conversion of the array parameters to the + -- unbounded type for optimizing purpose. + when Iir_Predefined_TF_Reduction_And => + return Translate_Predefined_TF_Reduction + (ON_And, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Or => + return Translate_Predefined_TF_Reduction + (ON_Or, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Nand => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_And, Left, Res_Type)); + when Iir_Predefined_TF_Reduction_Nor => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Or, Left, Res_Type)); + when Iir_Predefined_TF_Reduction_Xor => + return Translate_Predefined_TF_Reduction + (ON_Xor, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Xnor => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Xor, Left, Res_Type)); + + when Iir_Predefined_Vector_Minimum => + return Translate_Predefined_Vector_Min_Max + (True, Left, Res_Type); + when Iir_Predefined_Vector_Maximum => + return Translate_Predefined_Vector_Min_Max + (False, Left, Res_Type); + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Translate_Predefined_TF_Edge (True, Left); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Translate_Predefined_TF_Edge (False, Left); + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Eq, Left, Right, Res_Type); + when Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Ne, Left, Right, Res_Type); + + when others => + null; + end case; + + -- Evaluate parameters. + Res_Otype := Get_Ortho_Type (Res_Type, Mode_Value); + Inter := Get_Interface_Declaration_Chain (Imp); + if Left = Null_Iir then + Left_Tree := O_Enode_Null; + else + Left_Type := Get_Type (Inter); + Left_Tree := Translate_Expression (Left, Left_Type); + end if; + + if Right = Null_Iir then + Right_Tree := O_Enode_Null; + else + Right_Type := Get_Type (Get_Chain (Inter)); + Right_Tree := Translate_Expression (Right, Right_Type); + end if; + + Op := Predefined_To_Onop (Kind); + if Op /= ON_Nil then + case Op is + when ON_Eq + | ON_Neq + | ON_Ge + | ON_Gt + | ON_Le + | ON_Lt => + Res := New_Compare_Op (Op, Left_Tree, Right_Tree, + Std_Boolean_Type_Node); + when ON_Add_Ov + | ON_Sub_Ov + | ON_Mul_Ov + | ON_Div_Ov + | ON_Rem_Ov + | ON_Mod_Ov + | ON_Xor => + Res := New_Dyadic_Op (Op, Left_Tree, Right_Tree); + when ON_Abs_Ov + | ON_Neg_Ov + | ON_Not => + Res := New_Monadic_Op (Op, Left_Tree); + when others => + Ada.Text_IO.Put_Line + ("translate_predefined_operator: cannot handle " + & ON_Op_Kind'Image (Op)); + raise Internal_Error; + end case; + Res := Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Loc); + return Res; + end if; + + case Kind is + when Iir_Predefined_Bit_Xnor + | Iir_Predefined_Boolean_Xnor => + return Translate_Predefined_Logical + (Iir_Predefined_Boolean_Xnor, Left_Tree, Right_Tree); + when Iir_Predefined_Bit_Match_Equality => + return New_Compare_Op (ON_Eq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + when Iir_Predefined_Bit_Match_Inequality => + return New_Compare_Op (ON_Neq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + + when Iir_Predefined_Bit_Condition => + return New_Compare_Op + (ON_Eq, Left_Tree, New_Lit (Get_Ortho_Expr (Bit_1)), + Std_Boolean_Type_Node); + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Physical_Identity => + return Translate_Implicit_Conv + (Left_Tree, Left_Type, Res_Type, Mode_Value, Loc); + + when Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality => + if Is_Composite (Get_Info (Left_Type)) then + -- a fat pointer. + declare + T : Type_Info_Acc; + B : Type_Info_Acc; + L, R : O_Dnode; + V1, V2 : O_Enode; + Op1, Op2 : ON_Op_Kind; + begin + if Kind = Iir_Predefined_Access_Equality then + Op1 := ON_Eq; + Op2 := ON_And; + else + Op1 := ON_Neq; + Op2 := ON_Or; + end if; + T := Get_Info (Left_Type); + B := Get_Info (Get_Designated_Type (Left_Type)); + L := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); + R := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (L), Left_Tree); + New_Assign_Stmt (New_Obj (R), Right_Tree); + V1 := New_Compare_Op + (Op1, + New_Value_Selected_Acc_Value + (New_Obj (L), B.T.Base_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (R), B.T.Base_Field (Mode_Value)), + Std_Boolean_Type_Node); + V2 := New_Compare_Op + (Op1, + New_Value_Selected_Acc_Value + (New_Obj (L), B.T.Bounds_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (R), B.T.Bounds_Field (Mode_Value)), + Std_Boolean_Type_Node); + return New_Dyadic_Op (Op2, V1, V2); + end; + else + -- a thin pointer. + if Kind = Iir_Predefined_Access_Equality then + return New_Compare_Op + (ON_Eq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); + else + return New_Compare_Op + (ON_Neq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); + end if; + end if; + + when Iir_Predefined_Physical_Integer_Div => + return New_Dyadic_Op (ON_Div_Ov, Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + when Iir_Predefined_Physical_Physical_Div => + return New_Convert_Ov + (New_Dyadic_Op (ON_Div_Ov, Left_Tree, Right_Tree), Res_Otype); + + -- LRM 7.2.6 + -- Multiplication of a value P of a physical type Tp by a + -- value I of type INTEGER is equivalent to the following + -- computation: Tp'Val (Tp'Pos (P) * I) + -- FIXME: this is not what is really done... + when Iir_Predefined_Integer_Physical_Mul => + return New_Dyadic_Op (ON_Mul_Ov, + New_Convert_Ov (Left_Tree, Res_Otype), + Right_Tree); + when Iir_Predefined_Physical_Integer_Mul => + return New_Dyadic_Op (ON_Mul_Ov, Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + + -- LRM 7.2.6 + -- Multiplication of a value P of a physical type Tp by a + -- value F of type REAL is equivalten to the following + -- computation: Tp'Val (INTEGER (REAL (Tp'Pos (P)) * F)) + -- FIXME: we do not restrict with INTEGER. + when Iir_Predefined_Physical_Real_Mul => + declare + Right_Otype : O_Tnode; + begin + Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, + New_Convert_Ov (Left_Tree, Right_Otype), + Right_Tree), + Res_Otype); + end; + when Iir_Predefined_Physical_Real_Div => + declare + Right_Otype : O_Tnode; + begin + Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Div_Ov, + New_Convert_Ov (Left_Tree, Right_Otype), + Right_Tree), + Res_Otype); + end; + when Iir_Predefined_Real_Physical_Mul => + declare + Left_Otype : O_Tnode; + begin + Left_Otype := Get_Ortho_Type (Left_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, + Left_Tree, + New_Convert_Ov (Right_Tree, Left_Otype)), + Res_Otype); + end; + + when Iir_Predefined_Universal_R_I_Mul => + return New_Dyadic_Op (ON_Mul_Ov, + Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + + when Iir_Predefined_Floating_Exp => + Res := Translate_Lib_Operator + (New_Convert_Ov (Left_Tree, Std_Real_Otype), + Right_Tree, Ghdl_Real_Exp); + return New_Convert_Ov (Res, Res_Otype); + when Iir_Predefined_Integer_Exp => + Res := Translate_Lib_Operator + (New_Convert_Ov (Left_Tree, Std_Integer_Otype), + Right_Tree, + Ghdl_Integer_Exp); + return New_Convert_Ov (Res, Res_Otype); + + when Iir_Predefined_Array_Inequality + | Iir_Predefined_Record_Inequality => + return New_Monadic_Op + (ON_Not, Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp)); + when Iir_Predefined_Array_Equality + | Iir_Predefined_Record_Equality => + return Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp); + + when Iir_Predefined_Array_Greater => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Gt), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Greater_Equal => + return New_Compare_Op + (ON_Ge, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Eq), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Less => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Lt), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Less_Equal => + return New_Compare_Op + (ON_Le, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Eq), + Std_Boolean_Type_Node); + + when Iir_Predefined_TF_Array_And + | Iir_Predefined_TF_Array_Or + | Iir_Predefined_TF_Array_Nand + | Iir_Predefined_TF_Array_Nor + | Iir_Predefined_TF_Array_Xor + | Iir_Predefined_TF_Array_Xnor + | Iir_Predefined_TF_Array_Not + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + return Translate_Predefined_Array_Operator_Convert + (Left_Tree, Right_Tree, Imp, Res_Type); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Right_Tree := New_Monadic_Op (ON_Neg_Ov, Right_Tree); + return Translate_Predefined_Array_Operator_Convert + (Left_Tree, Right_Tree, Imp, Res_Type); + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + return Translate_Concat_Operator + (Left_Tree, Right_Tree, Imp, Res_Type, Loc); + + when Iir_Predefined_Endfile => + return Translate_Lib_Operator + (Left_Tree, O_Enode_Null, Ghdl_File_Endfile); + + when Iir_Predefined_Now_Function => + return New_Obj_Value (Ghdl_Now); + + when Iir_Predefined_Std_Ulogic_Match_Equality => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Eq, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Inequality => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Ne, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Less => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Lt, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Less_Equal => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Le, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Greater => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Lt, + Right_Tree, Left_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Le, + Right_Tree, Left_Tree, Res_Otype); + + when Iir_Predefined_Bit_Array_Match_Equality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_True_Node), + Res_Otype); + when Iir_Predefined_Bit_Array_Match_Inequality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_False_Node), + Res_Otype); + + when Iir_Predefined_Array_Minimum => + return Translate_Predefined_Array_Min_Max + (True, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + when Iir_Predefined_Array_Maximum => + return Translate_Predefined_Array_Min_Max + (False, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + + when Iir_Predefined_Integer_To_String => + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_I32 => + return Translate_To_String + (Ghdl_To_String_I32, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_I32_Type)); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_To_String => + -- LRM08 5.7 String representations + -- - For a given value of type CHARACTER, [...] + -- + -- So special case for character. + if Get_Base_Type (Left_Type) = Character_Type_Definition then + return Translate_To_String + (Ghdl_To_String_Char, Res_Type, Loc, Left_Tree); + end if; + + -- LRM08 5.7 String representations + -- - For a given value of type other than CHARACTER, [...] + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_To_String_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_To_String_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_To_String_E32; + Conv := Ghdl_I32_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Floating_To_String => + return Translate_To_String + (Ghdl_To_String_F64, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type)); + when Iir_Predefined_Real_To_String_Digits => + return Translate_To_String + (Ghdl_To_String_F64_Digits, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type), + New_Convert_Ov (Right_Tree, Ghdl_I32_Type)); + when Iir_Predefined_Real_To_String_Format => + return Translate_To_String + (Ghdl_To_String_F64_Format, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type), + Right_Tree); + when Iir_Predefined_Physical_To_String => + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_P32 => + Subprg := Ghdl_To_String_P32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_To_String_P64; + Conv := Ghdl_I64_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Time_To_String_Unit => + return Translate_To_String + (Ghdl_Time_To_String_Unit, Res_Type, Loc, + Left_Tree, Right_Tree, + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + when Iir_Predefined_Bit_Vector_To_Ostring => + return Translate_Bv_To_String + (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Loc); + when Iir_Predefined_Bit_Vector_To_Hstring => + return Translate_Bv_To_String + (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Loc); + when Iir_Predefined_Array_Char_To_String => + declare + El_Type : constant Iir := Get_Element_Subtype (Left_Type); + Subprg : O_Dnode; + Arg : Mnode; + begin + Arg := Stabilize + (E2M (Left_Tree, Get_Info (Left_Type), Mode_Value)); + case Get_Info (El_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Array_Char_To_String_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Array_Char_To_String_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Array_Char_To_String_E32; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (Arg)), + Ghdl_Ptr_Type), + Chap3.Get_Array_Length (Arg, Left_Type), + New_Lit (Rtis.New_Rti_Address + (Get_Info (El_Type).Type_Rti))); + end; + + when others => + Ada.Text_IO.Put_Line + ("translate_predefined_operator(2): cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + return O_Enode_Null; + end case; + end Translate_Predefined_Operator; + + -- Assign EXPR to TARGET. + procedure Translate_Assign + (Target : Mnode; + Val : O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir) + is + T_Info : constant Type_Info_Acc := Get_Info (Target_Type); + begin + case T_Info.Type_Mode is + when Type_Mode_Scalar => + New_Assign_Stmt + (M2Lv (Target), + Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type)); + when Type_Mode_Acc + | Type_Mode_File => + New_Assign_Stmt (M2Lv (Target), Val); + when Type_Mode_Fat_Acc => + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Fat_Array => + declare + T : Mnode; + E : O_Dnode; + begin + T := Stabilize (Target); + E := Create_Temp_Init + (T_Info.Ortho_Ptr_Type (Mode_Value), Val); + Chap3.Check_Array_Match + (Target_Type, T, + Get_Type (Expr), Dp2M (E, T_Info, Mode_Value), Loc); + Chap3.Translate_Object_Copy + (T, New_Obj_Value (E), Target_Type); + end; + when Type_Mode_Array => + -- Source is of type TARGET_TYPE, so no length check is + -- necessary. + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Record => + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Assign; + + procedure Translate_Assign + (Target : Mnode; Expr : Iir; Target_Type : Iir) + is + Val : O_Enode; + begin + if Get_Kind (Expr) = Iir_Kind_Aggregate then + -- FIXME: handle overlap between TARGET and EXPR. + Translate_Aggregate (Target, Target_Type, Expr); + else + Open_Temp; + Val := Chap7.Translate_Expression (Expr, Target_Type); + Translate_Assign (Target, Val, Expr, Target_Type, Expr); + Close_Temp; + end if; + end Translate_Assign; + + -- If AGGR is of the form (others => (others => EXPR)) (where the + -- number of (others => ) sub-aggregate is at least 1, return EXPR + -- otherwise return NULL_IIR. + function Is_Aggregate_Others (Aggr : Iir_Aggregate) return Iir + is + Chain : Iir; + Aggr1 : Iir; + --Type_Info : Type_Info_Acc; + begin + Aggr1 := Aggr; + -- Do not use translate_aggregate_others for a complex type. + --Type_Info := Get_Info (Get_Type (Aggr)); + --if Type_Info.C /= null and then Type_Info.C.Builder_Need_Func then + -- return Null_Iir; + --end if; + loop + Chain := Get_Association_Choices_Chain (Aggr1); + if not Is_Chain_Length_One (Chain) then + return Null_Iir; + end if; + if Get_Kind (Chain) /= Iir_Kind_Choice_By_Others then + return Null_Iir; + end if; + Aggr1 := Get_Associated_Expr (Chain); + case Get_Kind (Aggr1) is + when Iir_Kind_Aggregate => + if Get_Type (Aggr1) /= Null_Iir then + -- Stop when a sub-aggregate is in fact an aggregate. + return Aggr1; + end if; + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return Null_Iir; + --Error_Kind ("is_aggregate_others", Aggr1); + when others => + return Aggr1; + end case; + end loop; + end Is_Aggregate_Others; + + -- Generate code for (others => EL). + procedure Translate_Aggregate_Others + (Target : Mnode; Target_Type : Iir; El : Iir) + is + Base_Ptr : Mnode; + Info : Type_Info_Acc; + It : O_Dnode; + Len : O_Dnode; + Len_Val : O_Enode; + Label : O_Snode; + Arr_Var : Mnode; + El_Node : Mnode; + begin + Open_Temp; + + Info := Get_Info (Target_Type); + case Info.Type_Mode is + when Type_Mode_Fat_Array => + Arr_Var := Stabilize (Target); + Base_Ptr := Stabilize (Chap3.Get_Array_Base (Arr_Var)); + Len_Val := Chap3.Get_Array_Length (Arr_Var, Target_Type); + when Type_Mode_Array => + Base_Ptr := Stabilize (Chap3.Get_Array_Base (Target)); + Len_Val := Chap3.Get_Array_Type_Length (Target_Type); + when others => + raise Internal_Error; + end case; + -- FIXME: use this (since this use one variable instead of two): + -- I := length; + -- loop + -- exit when I = 0; + -- I := I - 1; + -- A[I] := xxx; + -- end loop; + Len := Create_Temp_Init (Ghdl_Index_Type, Len_Val); + if True then + It := Create_Temp (Ghdl_Index_Type); + else + New_Var_Decl (It, Wki_I, O_Storage_Local, Ghdl_Index_Type); + end if; + Init_Var (It); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Eq, + New_Obj_Value (It), New_Obj_Value (Len), + Ghdl_Bool_Type)); + El_Node := Chap3.Index_Base (Base_Ptr, Target_Type, + New_Obj_Value (It)); + --New_Assign_Stmt (El_Node, Chap7.Translate_Expression (El)); + Translate_Assign (El_Node, El, Get_Element_Subtype (Target_Type)); + Inc_Var (It); + Finish_Loop_Stmt (Label); + + Close_Temp; + end Translate_Aggregate_Others; + + procedure Translate_Array_Aggregate_Gen + (Base_Ptr : Mnode; + Bounds_Ptr : Mnode; + Aggr : Iir; + Aggr_Type : Iir; + Dim : Natural; + Var_Index : O_Dnode) + is + Index_List : Iir_List; + Expr_Type : Iir; + Final : Boolean; + + procedure Do_Assign (Expr : Iir) + is + begin + if Final then + Translate_Assign (Chap3.Index_Base (Base_Ptr, Aggr_Type, + New_Obj_Value (Var_Index)), + Expr, Expr_Type); + Inc_Var (Var_Index); + else + Translate_Array_Aggregate_Gen + (Base_Ptr, Bounds_Ptr, Expr, Aggr_Type, Dim + 1, Var_Index); + end if; + end Do_Assign; + + P : Natural; + El : Iir; + begin + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + -- Continue below. + null; + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + declare + Len : constant Nat32 := Get_String_Length (Aggr); + + -- Type of the unconstrained array type. + Arr_Type : O_Tnode; + + -- Type of the constrained array type. + Str_Type : O_Tnode; + + Cst : Var_Type; + Var_I : O_Dnode; + Label : O_Snode; + begin + Expr_Type := Get_Element_Subtype (Aggr_Type); + + -- Create a constant for the string. + -- First, create its type, because the literal has no + -- type (subaggregate). + Arr_Type := New_Array_Type + (Get_Ortho_Type (Expr_Type, Mode_Value), + Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Arr_Type); + Str_Type := New_Constrained_Array_Type + (Arr_Type, New_Index_Lit (Unsigned_64 (Len))); + Cst := Create_String_Literal_Var_Inner + (Aggr, Expr_Type, Str_Type); + + -- Copy it. + Open_Temp; + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Lit (New_Index_Lit (Nat32'Pos (Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt + (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, + New_Obj_Value (Var_Index))), + New_Value (New_Indexed_Element (Get_Var (Cst), + New_Obj_Value (Var_I)))); + Inc_Var (Var_I); + Inc_Var (Var_Index); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + return; + when others => + raise Internal_Error; + end case; + + Index_List := Get_Index_Subtype_List (Aggr_Type); + + -- FINAL is true if the elements of the aggregate are elements of + -- the array. + if Get_Nbr_Elements (Index_List) = Dim then + Expr_Type := Get_Element_Subtype (Aggr_Type); + Final:= True; + else + Final := False; + end if; + + El := Get_Association_Choices_Chain (Aggr); + + -- First, assign positionnal association. + -- FIXME: count the number of positionnal association and generate + -- an error if there is more positionnal association than elements + -- in the array. + P := 0; + loop + if El = Null_Iir then + -- There is only positionnal associations. + return; + end if; + exit when Get_Kind (El) /= Iir_Kind_Choice_By_None; + Do_Assign (Get_Associated_Expr (El)); + P := P + 1; + El := Get_Chain (El); + end loop; + + -- Then, assign named or others association. + if Get_Chain (El) = Null_Iir then + -- There is only one choice + case Get_Kind (El) is + when Iir_Kind_Choice_By_Others => + -- falltrough... + null; + when Iir_Kind_Choice_By_Expression => + Do_Assign (Get_Associated_Expr (El)); + return; + when Iir_Kind_Choice_By_Range => + declare + Var_Length : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + begin + Open_Temp; + Var_Length := Create_Temp_Init + (Ghdl_Index_Type, + Chap7.Translate_Range_Length (Get_Choice_Range (El))); + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Do_Assign (Get_Associated_Expr (El)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + return; + when others => + Error_Kind ("translate_array_aggregate_gen", El); + end case; + end if; + + -- Several choices.. + declare + Range_Type : Iir; + Var_Pos : O_Dnode; + Var_Len : O_Dnode; + Range_Ptr : Mnode; + Rtinfo : Type_Info_Acc; + If_Blk : O_If_Block; + Case_Blk : O_Case_Block; + Label : O_Snode; + El_Assoc : Iir; + Len_Tmp : O_Enode; + begin + Open_Temp; + -- Create a loop from left +- number of positionnals associations + -- to/downto right. + Range_Type := + Get_Base_Type (Get_Nth_Element (Index_List, Dim - 1)); + Rtinfo := Get_Info (Range_Type); + Var_Pos := Create_Temp (Rtinfo.Ortho_Type (Mode_Value)); + Range_Ptr := Stabilize + (Chap3.Bounds_To_Range (Bounds_Ptr, Aggr_Type, Dim)); + New_Assign_Stmt (New_Obj (Var_Pos), + M2E (Chap3.Range_To_Left (Range_Ptr))); + Var_Len := Create_Temp (Ghdl_Index_Type); + if P /= 0 then + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (P), + Range_Type); + New_Else_Stmt (If_Blk); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (P), + Range_Type); + Finish_If_Stmt (If_Blk); + end if; + + Len_Tmp := M2E (Chap3.Range_To_Length (Range_Ptr)); + if P /= 0 then + Len_Tmp := New_Dyadic_Op + (ON_Sub_Ov, + Len_Tmp, + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (P)))); + end if; + New_Assign_Stmt (New_Obj (Var_Len), Len_Tmp); + + -- Start loop. + Start_Loop_Stmt (Label); + -- Check if end of loop. + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + + -- convert aggr into a case statement. + Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Pos)); + El_Assoc := Null_Iir; + while El /= Null_Iir loop + Start_Choice (Case_Blk); + Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk); + if Get_Associated_Expr (El) /= Null_Iir then + El_Assoc := Get_Associated_Expr (El); + end if; + Finish_Choice (Case_Blk); + Do_Assign (El_Assoc); + P := P + 1; + El := Get_Chain (El); + end loop; + Finish_Case_Stmt (Case_Blk); + -- Update var_pos + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (1), + Range_Type); + New_Else_Stmt (If_Blk); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (1), + Range_Type); + Finish_If_Stmt (If_Blk); + New_Assign_Stmt + (New_Obj (Var_Len), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Len), + New_Lit (Ghdl_Index_1))); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + end Translate_Array_Aggregate_Gen; + + procedure Translate_Record_Aggregate (Target : Mnode; Aggr : Iir) + is + Targ : Mnode; + Aggr_Type : constant Iir := Get_Type (Aggr); + Aggr_Base_Type : constant Iir_Record_Type_Definition := + Get_Base_Type (Aggr_Type); + El_List : constant Iir_List := + Get_Elements_Declaration_List (Aggr_Base_Type); + El_Index : Natural; + Nbr_El : constant Natural := Get_Nbr_Elements (El_List); + + -- Record which elements of the record have been set. The 'others' + -- clause applies to all elements not already set. + type Bool_Array_Type is array (0 .. Nbr_El - 1) of Boolean; + pragma Pack (Bool_Array_Type); + Set_Array : Bool_Array_Type := (others => False); + + -- The expression associated. + El_Expr : Iir; + + -- Set an elements. + procedure Set_El (El : Iir_Element_Declaration) is + begin + Translate_Assign (Chap6.Translate_Selected_Element (Targ, El), + El_Expr, Get_Type (El)); + Set_Array (Natural (Get_Element_Position (El))) := True; + end Set_El; + + Assoc : Iir; + N_El_Expr : Iir; + begin + Open_Temp; + Targ := Stabilize (Target); + El_Index := 0; + Assoc := Get_Association_Choices_Chain (Aggr); + while Assoc /= Null_Iir loop + N_El_Expr := Get_Associated_Expr (Assoc); + if N_El_Expr /= Null_Iir then + El_Expr := N_El_Expr; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + Set_El (Get_Nth_Element (El_List, El_Index)); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Set_El (Get_Choice_Name (Assoc)); + El_Index := Natural'Last; + when Iir_Kind_Choice_By_Others => + for J in Set_Array'Range loop + if not Set_Array (J) then + Set_El (Get_Nth_Element (El_List, J)); + end if; + end loop; + when others => + Error_Kind ("translate_record_aggregate", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + Close_Temp; + end Translate_Record_Aggregate; + + procedure Translate_Array_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir) + is + Aggr_Type : constant Iir := Get_Type (Aggr); + Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); + Targ_Index_List : constant Iir_List := + Get_Index_Subtype_List (Target_Type); + + Aggr_Info : Iir_Aggregate_Info; + Base : Mnode; + Bounds : Mnode; + Var_Index : O_Dnode; + Targ : Mnode; + + Rinfo : Type_Info_Acc; + Bt : Iir; + + -- Generate code for: (LVAL lop RNG.left) or (RVAL rop RNG.right) + function Check_Value (Lval : Iir; + Lop : ON_Op_Kind; + Rval : Iir; + Rop : ON_Op_Kind; + Rng : Mnode) + return O_Enode + is + L, R : O_Enode; + begin + L := New_Compare_Op + (Lop, + New_Lit (Translate_Static_Expression (Lval, Bt)), + M2E (Chap3.Range_To_Left (Rng)), + Ghdl_Bool_Type); + R := New_Compare_Op + (Rop, + New_Lit (Translate_Static_Expression (Rval, Bt)), + M2E (Chap3.Range_To_Right (Rng)), + Ghdl_Bool_Type); + return New_Dyadic_Op (ON_Or, L, R); + end Check_Value; + + Range_Ptr : Mnode; + Subtarg_Type : Iir; + Subaggr_Type : Iir; + L, H : Iir; + Min : Iir_Int32; + Has_Others : Boolean; + + Var_Err : O_Dnode; + E : O_Enode; + If_Blk : O_If_Block; + Op : ON_Op_Kind; + begin + Open_Temp; + Targ := Stabilize (Target); + Base := Stabilize (Chap3.Get_Array_Base (Targ)); + Bounds := Stabilize (Chap3.Get_Array_Bounds (Targ)); + Aggr_Info := Get_Aggregate_Info (Aggr); + + -- Check type + for I in Natural loop + Subaggr_Type := Get_Index_Type (Index_List, I); + exit when Subaggr_Type = Null_Iir; + Subtarg_Type := Get_Index_Type (Targ_Index_List, I); + + Bt := Get_Base_Type (Subaggr_Type); + Rinfo := Get_Info (Bt); + + if Get_Aggr_Dynamic_Flag (Aggr_Info) then + -- Dynamic range, must evaluate it. + Open_Temp; + declare + A_Range : O_Dnode; + Rng_Ptr : O_Dnode; + begin + -- Evaluate the range. + Chap3.Translate_Anonymous_Type_Definition + (Subaggr_Type, True); + + A_Range := Create_Temp (Rinfo.T.Range_Type); + Rng_Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, New_Obj (A_Range)); + Chap7.Translate_Range_Ptr + (Rng_Ptr, + Get_Range_Constraint (Subaggr_Type), + Subaggr_Type); + + -- Check range length VS target length. + Chap6.Check_Bound_Error + (New_Compare_Op + (ON_Neq, + M2E (Chap3.Range_To_Length + (Dv2M (A_Range, + Rinfo, + Mode_Value, + Rinfo.T.Range_Type, + Rinfo.T.Range_Ptr_Type))), + M2E (Chap3.Range_To_Length + (Chap3.Bounds_To_Range + (Bounds, Target_Type, I + 1))), + Ghdl_Bool_Type), + Aggr, I); + end; + Close_Temp; + elsif Get_Type_Staticness (Subaggr_Type) /= Locally + or else Subaggr_Type /= Subtarg_Type + then + -- Note: if the aggregate has no others, then the bounds + -- must be the same, otherwise, aggregate bounds must be + -- inside type bounds. + Has_Others := Get_Aggr_Others_Flag (Aggr_Info); + Min := Get_Aggr_Min_Length (Aggr_Info); + L := Get_Aggr_Low_Limit (Aggr_Info); + + if Min > 0 or L /= Null_Iir then + Open_Temp; + + -- Pointer to the range. + Range_Ptr := Stabilize + (Chap3.Bounds_To_Range (Bounds, Target_Type, I + 1)); + Var_Err := Create_Temp (Ghdl_Bool_Type); + H := Get_Aggr_High_Limit (Aggr_Info); + + if L /= Null_Iir then + -- Check the index range of the aggregrate is equal + -- (or within in presence of 'others') the index range + -- of the target. + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + if Has_Others then + E := Check_Value (L, ON_Lt, H, ON_Gt, Range_Ptr); + else + E := Check_Value (L, ON_Neq, H, ON_Neq, Range_Ptr); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + New_Else_Stmt (If_Blk); + if Has_Others then + E := Check_Value (H, ON_Gt, L, ON_Lt, Range_Ptr); + else + E := Check_Value (H, ON_Neq, L, ON_Neq, Range_Ptr); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + Finish_If_Stmt (If_Blk); + -- If L and H are greather than the minimum length, + -- then there is no need to check with min. + if Iir_Int32 (Eval_Pos (H) - Eval_Pos (L) + 1) >= Min then + Min := 0; + end if; + end if; + + if Min > 0 then + -- Check the number of elements is equal (or less in + -- presence of 'others') than the length of the index + -- range of the target. + if Has_Others then + Op := ON_Lt; + else + Op := ON_Neq; + end if; + E := New_Compare_Op + (Op, + M2E (Chap3.Range_To_Length (Range_Ptr)), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Min))), + Ghdl_Bool_Type); + if L /= Null_Iir then + E := New_Dyadic_Op (ON_Or, E, New_Obj_Value (Var_Err)); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + end if; + Chap6.Check_Bound_Error (New_Obj_Value (Var_Err), Aggr, I); + Close_Temp; + end if; + end if; + + -- Next dimension. + Aggr_Info := Get_Sub_Aggregate_Info (Aggr_Info); + end loop; + + Var_Index := Create_Temp_Init + (Ghdl_Index_Type, New_Lit (Ghdl_Index_0)); + Translate_Array_Aggregate_Gen + (Base, Bounds, Aggr, Aggr_Type, 1, Var_Index); + Close_Temp; + + -- FIXME: creating aggregate subtype is expensive and rarely used. + -- (one of the current use - only ? - is check_array_match). + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False); + end Translate_Array_Aggregate; + + procedure Translate_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir) + is + Aggr_Type : constant Iir := Get_Type (Aggr); + El : Iir; + begin + case Get_Kind (Aggr_Type) is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + El := Is_Aggregate_Others (Aggr); + if El /= Null_Iir then + Translate_Aggregate_Others (Target, Target_Type, El); + else + Translate_Array_Aggregate (Target, Target_Type, Aggr); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Record_Aggregate (Target, Aggr); + when others => + Error_Kind ("translate_aggregate", Aggr_Type); + end case; + end Translate_Aggregate; + + function Translate_Allocator_By_Expression (Expr : Iir) + return O_Enode + is + Val : O_Enode; + Val_M : Mnode; + A_Type : constant Iir := Get_Type (Expr); + A_Info : constant Type_Info_Acc := Get_Info (A_Type); + D_Type : constant Iir := Get_Designated_Type (A_Type); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + R : Mnode; + Rtype : O_Tnode; + begin + -- Compute the expression. + Val := Translate_Expression (Get_Expression (Expr), D_Type); + -- Allocate memory for the object. + case A_Info.Type_Mode is + when Type_Mode_Fat_Acc => + R := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), + D_Info, Mode_Value); + Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); + Chap3.Translate_Object_Allocation + (R, Alloc_Heap, D_Type, + Chap3.Get_Array_Bounds (Val_M)); + Val := M2E (Val_M); + Rtype := A_Info.Ortho_Ptr_Type (Mode_Value); + when Type_Mode_Acc => + R := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), + D_Info, Mode_Value); + Chap3.Translate_Object_Allocation + (R, Alloc_Heap, D_Type, Mnode_Null); + Rtype := A_Info.Ortho_Type (Mode_Value); + when others => + raise Internal_Error; + end case; + Chap3.Translate_Object_Copy (R, Val, D_Type); + return New_Convert_Ov (M2Addr (R), Rtype); + end Translate_Allocator_By_Expression; + + function Translate_Allocator_By_Subtype (Expr : Iir) + return O_Enode + is + P_Type : constant Iir := Get_Type (Expr); + P_Info : constant Type_Info_Acc := Get_Info (P_Type); + D_Type : constant Iir := Get_Designated_Type (P_Type); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + Sub_Type : Iir; + Bounds : Mnode; + Res : Mnode; + Rtype : O_Tnode; + begin + case P_Info.Type_Mode is + when Type_Mode_Fat_Acc => + Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), + D_Info, Mode_Value); + -- FIXME: should allocate bounds, and directly set bounds + -- from the range. + Sub_Type := Get_Subtype_Indication (Expr); + Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); + Chap3.Create_Array_Subtype (Sub_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Sub_Type); + Rtype := P_Info.Ortho_Ptr_Type (Mode_Value); + when Type_Mode_Acc => + Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), + D_Info, Mode_Value); + Bounds := Mnode_Null; + Rtype := P_Info.Ortho_Type (Mode_Value); + when others => + raise Internal_Error; + end case; + Chap3.Translate_Object_Allocation (Res, Alloc_Heap, D_Type, Bounds); + Chap4.Init_Object (Res, D_Type); + return New_Convert_Ov (M2Addr (Res), Rtype); + end Translate_Allocator_By_Subtype; + + function Translate_Fat_Array_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode; + + function Translate_Array_Subtype_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + E : Mnode; + begin + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); + case Res_Info.Type_Mode is + when Type_Mode_Array => + Chap3.Check_Array_Match + (Res_Type, T2M (Res_Type, Mode_Value), + Expr_Type, E, + Loc); + return New_Convert_Ov + (M2Addr (Chap3.Get_Array_Base (E)), + Res_Info.Ortho_Ptr_Type (Mode_Value)); + when Type_Mode_Fat_Array => + declare + Res : Mnode; + begin + Res := Create_Temp (Res_Info); + Copy_Fat_Pointer (Res, E); + Chap3.Check_Array_Match (Res_Type, Res, Expr_Type, E, Loc); + return M2Addr (Res); + end; + when others => + Error_Kind ("translate_array_subtype_conversion", Res_Type); + end case; + end Translate_Array_Subtype_Conversion; + + function Translate_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Res : O_Enode; + begin + case Get_Kind (Res_Type) is + when Iir_Kinds_Scalar_Type_Definition => + Res := New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); + if Chap3.Need_Range_Check (Null_Iir, Res_Type) then + Res := Chap3.Insert_Scalar_Check + (Res, Null_Iir, Res_Type, Loc); + end if; + return Res; + when Iir_Kinds_Array_Type_Definition => + if Get_Constraint_State (Res_Type) = Fully_Constrained then + return Translate_Array_Subtype_Conversion + (Expr, Expr_Type, Res_Type, Loc); + else + return Translate_Fat_Array_Type_Conversion + (Expr, Expr_Type, Res_Type, Loc); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Expr; + when others => + Error_Kind ("translate_type_conversion", Res_Type); + end case; + end Translate_Type_Conversion; + + function Translate_Fat_Array_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + Res_Indexes : constant Iir_List := + Get_Index_Subtype_List (Res_Type); + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + + Res_Base_Type : constant Iir := Get_Base_Type (Res_Type); + Expr_Base_Type : constant Iir := Get_Base_Type (Expr_Type); + Res_Base_Indexes : constant Iir_List := + Get_Index_Subtype_List (Res_Base_Type); + Expr_Base_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Base_Type); + Res : Mnode; + E : Mnode; + Bounds : O_Dnode; + R_El : Iir; + E_El : Iir; + begin + Res := Create_Temp (Res_Info, Mode_Value); + Bounds := Create_Temp (Res_Info.T.Bounds_Type); + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); + Open_Temp; + -- Set base. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (E)), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + -- Set bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + New_Address (New_Obj (Bounds), Res_Info.T.Bounds_Ptr_Type)); + + -- Convert bounds. + for I in Natural loop + R_El := Get_Index_Type (Res_Indexes, I); + E_El := Get_Index_Type (Expr_Indexes, I); + exit when R_El = Null_Iir; + declare + Rb_Ptr : Mnode; + Eb_Ptr : Mnode; + Ee : O_Enode; + Same_Index_Type : constant Boolean := + (Get_Index_Type (Res_Base_Indexes, I) + = Get_Index_Type (Expr_Base_Indexes, I)); + begin + Open_Temp; + Rb_Ptr := Stabilize + (Chap3.Get_Array_Range (Res, Res_Type, I + 1)); + Eb_Ptr := Stabilize + (Chap3.Get_Array_Range (E, Expr_Type, I + 1)); + -- Convert left and right (unless they have the same type - + -- this is an optimization but also this deals with null + -- array in common cases). + Ee := M2E (Chap3.Range_To_Left (Eb_Ptr)); + if not Same_Index_Type then + Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); + end if; + New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Rb_Ptr)), Ee); + Ee := M2E (Chap3.Range_To_Right (Eb_Ptr)); + if not Same_Index_Type then + Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); + end if; + New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Rb_Ptr)), Ee); + -- Copy Dir and Length. + New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Rb_Ptr)), + M2E (Chap3.Range_To_Dir (Eb_Ptr))); + New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Rb_Ptr)), + M2E (Chap3.Range_To_Length (Eb_Ptr))); + Close_Temp; + end; + end loop; + Close_Temp; + return M2E (Res); + end Translate_Fat_Array_Type_Conversion; + + function Sig2val_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + if Get_Type_Info (Data).Type_Mode = Type_Mode_Fat_Array then + return Stabilize (Chap3.Get_Array_Base (Data)); + else + return Stabilize (Data); + end if; + end Sig2val_Prepare_Composite; + + function Sig2val_Update_Data_Array + (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) return Mnode + is + begin + return Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index)); + end Sig2val_Update_Data_Array; + + function Sig2val_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return Mnode + is + pragma Unreferenced (Targ_Type); + begin + return Chap6.Translate_Selected_Element (Val, El); + end Sig2val_Update_Data_Record; + + procedure Sig2val_Finish_Data_Composite (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Sig2val_Finish_Data_Composite; + + procedure Translate_Signal_Assign_Effective_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Mnode) + is + pragma Unreferenced (Targ_Type); + begin + New_Assign_Stmt (New_Access_Element (M2E (Targ)), M2E (Data)); + end Translate_Signal_Assign_Effective_Non_Composite; + + procedure Translate_Signal_Assign_Effective is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Assign_Effective_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + procedure Translate_Signal_Assign_Driving_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data: Mnode) + is + begin + New_Assign_Stmt + (Chap14.Get_Signal_Value_Field (M2E (Targ), Targ_Type, + Ghdl_Signal_Driving_Value_Field), + M2E (Data)); + end Translate_Signal_Assign_Driving_Non_Composite; + + procedure Translate_Signal_Assign_Driving is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Assign_Driving_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + procedure Translate_Signal_Non_Composite + (Targ : Mnode; + Targ_Type : Iir; + Data : Mnode) + is + begin + New_Assign_Stmt (M2Lv (Targ), + Read_Value (M2E (Data), Targ_Type)); + end Translate_Signal_Non_Composite; + + procedure Translate_Signal_Target is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Info (Sig_Type); + if Tinfo.Type_Mode in Type_Mode_Scalar then + return Read_Value (Sig, Sig_Type); + else + declare + Res : Mnode; + Var_Val : Mnode; + begin + -- allocate result array + if Tinfo.Type_Mode = Type_Mode_Fat_Array then + Res := Create_Temp (Tinfo); + + Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); + + -- Copy bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Var_Val))); + + -- Allocate base. + Chap3.Allocate_Fat_Array_Base (Alloc_Stack, Res, Sig_Type); + elsif Is_Complex_Type (Tinfo) then + Res := Create_Temp (Tinfo); + Chap4.Allocate_Complex_Object (Sig_Type, Alloc_Stack, Res); + else + Res := Create_Temp (Tinfo); + end if; + + Open_Temp; + + if Tinfo.Type_Mode /= Type_Mode_Fat_Array then + Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); + end if; + + Translate_Signal_Target (Res, Sig_Type, Var_Val); + Close_Temp; + return M2Addr (Res); + end; + end if; + end Translate_Signal_Value; + + -- Get the effective value of a simple signal SIG. + function Read_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + pragma Unreferenced (Sig_Type); + begin + return New_Value (New_Access_Element (Sig)); + end Read_Signal_Value; + + -- Get the value of signal SIG. + function Translate_Signal is new Translate_Signal_Value + (Read_Value => Read_Signal_Value); + + function Translate_Signal_Effective_Value + (Sig : O_Enode; Sig_Type : Iir) return O_Enode + renames Translate_Signal; + + function Read_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode is + begin + return New_Value (Chap14.Get_Signal_Value_Field + (Sig, Sig_Type, Ghdl_Signal_Driving_Value_Field)); + end Read_Signal_Driving_Value; + + function Translate_Signal_Driving_Value_1 is new Translate_Signal_Value + (Read_Value => Read_Signal_Driving_Value); + + function Translate_Signal_Driving_Value + (Sig : O_Enode; Sig_Type : Iir) return O_Enode + renames Translate_Signal_Driving_Value_1; + + procedure Set_Effective_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode) + renames Translate_Signal_Assign_Effective; + procedure Set_Driving_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode) + renames Translate_Signal_Assign_Driving; + + function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) + return O_Enode + is + Imp : Iir; + Expr_Type : Iir; + Res_Type : Iir; + Res : O_Enode; + begin + Expr_Type := Get_Type (Expr); + if Rtype = Null_Iir then + Res_Type := Expr_Type; + else + Res_Type := Rtype; + end if; + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal => + return New_Lit (Translate_Static_Expression (Expr, Rtype)); + + when Iir_Kind_Physical_Int_Literal => + declare + Unit : Iir; + Unit_Info : Object_Info_Acc; + begin + Unit := Get_Unit_Name (Expr); + Unit_Info := Get_Info (Unit); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + return New_Dyadic_Op + (ON_Mul_Ov, + New_Lit (New_Signed_Literal + (Get_Ortho_Type (Expr_Type, Mode_Value), + Integer_64 (Get_Value (Expr)))), + New_Value (Get_Var (Unit_Info.Object_Var))); + end if; + end; + + when Iir_Kind_Physical_Fp_Literal => + declare + Unit : Iir; + Unit_Info : Object_Info_Acc; + L, R : O_Enode; + begin + Unit := Get_Unit_Name (Expr); + Unit_Info := Get_Info (Unit); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + L := New_Lit + (New_Float_Literal + (Ghdl_Real_Type, IEEE_Float_64 (Get_Fp_Value (Expr)))); + R := New_Convert_Ov + (New_Value (Get_Var (Unit_Info.Object_Var)), + Ghdl_Real_Type); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, L, R), + Get_Ortho_Type (Expr_Type, Mode_Value)); + end if; + end; + + when Iir_Kind_Unit_Declaration => + declare + Unit_Info : Object_Info_Acc; + begin + Unit_Info := Get_Info (Expr); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + return New_Value (Get_Var (Unit_Info.Object_Var)); + end if; + end; + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Simple_Name_Attribute => + Res := Translate_String_Literal (Expr); + + when Iir_Kind_Aggregate => + declare + Aggr_Type : Iir; + Tinfo : Type_Info_Acc; + Mres : Mnode; + begin + -- Extract the type of the aggregate. Use the type of the + -- context if it is fully constrained. + pragma Assert (Rtype /= Null_Iir); + if Is_Fully_Constrained_Type (Rtype) then + Aggr_Type := Rtype; + else + Aggr_Type := Expr_Type; + end if; + if Get_Kind (Aggr_Type) = Iir_Kind_Array_Subtype_Definition + then + Chap3.Create_Array_Subtype (Aggr_Type, True); + end if; + + -- FIXME: this may be not necessary + Tinfo := Get_Info (Aggr_Type); + + -- The result area has to be created + if Is_Complex_Type (Tinfo) then + Mres := Create_Temp (Tinfo); + Chap4.Allocate_Complex_Object + (Aggr_Type, Alloc_Stack, Mres); + else + -- if thin array/record: + -- create result + Mres := Create_Temp (Tinfo); + end if; + + Translate_Aggregate (Mres, Aggr_Type, Expr); + Res := M2E (Mres); + + if Aggr_Type /= Rtype then + Res := Translate_Implicit_Conv + (Res, Aggr_Type, Rtype, Mode_Value, Expr); + end if; + return Res; + end; + + when Iir_Kind_Null_Literal => + declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); + L : O_Dnode; + B : Type_Info_Acc; + begin + if Tinfo.Type_Mode = Type_Mode_Fat_Acc then + -- Create a fat null pointer. + -- FIXME: should be optimized!! + L := Create_Temp (Otype); + B := Get_Info (Get_Designated_Type (Expr_Type)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (L), + B.T.Base_Field (Mode_Value)), + New_Lit + (New_Null_Access (B.T.Base_Ptr_Type (Mode_Value)))); + New_Assign_Stmt + (New_Selected_Element + (New_Obj (L), B.T.Bounds_Field (Mode_Value)), + New_Lit (New_Null_Access (B.T.Bounds_Ptr_Type))); + return New_Address (New_Obj (L), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + else + return New_Lit (New_Null_Access (Otype)); + end if; + end; + + when Iir_Kind_Overflow_Literal => + declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); + L : O_Dnode; + begin + -- Generate the error message + Chap6.Gen_Bound_Error (Expr); + + -- Create a dummy value + L := Create_Temp (Otype); + if Tinfo.Type_Mode = Type_Mode_Fat_Acc then + return New_Address (New_Obj (L), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + else + return New_Obj_Value (L); + end if; + end; + + when Iir_Kind_Parenthesis_Expression => + return Translate_Expression (Get_Expression (Expr), Rtype); + + when Iir_Kind_Allocator_By_Expression => + return Translate_Allocator_By_Expression (Expr); + when Iir_Kind_Allocator_By_Subtype => + return Translate_Allocator_By_Subtype (Expr); + + when Iir_Kind_Qualified_Expression => + -- FIXME: check type. + Res := Translate_Expression (Get_Expression (Expr), Expr_Type); + + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Attribute_Name => + declare + L : Mnode; + begin + L := Chap6.Translate_Name (Expr); + + Res := M2E (L); + if Get_Object_Kind (L) = Mode_Signal then + Res := Translate_Signal (Res, Expr_Type); + end if; + end; + + when Iir_Kind_Iterator_Declaration => + declare + Expr_Info : Ortho_Info_Acc; + begin + Expr_Info := Get_Info (Expr); + Res := New_Value (Get_Var (Expr_Info.Iterator_Var)); + if Rtype /= Null_Iir then + Res := New_Convert_Ov + (Res, Get_Ortho_Type (Rtype, Mode_Value)); + end if; + return Res; + end; + + when Iir_Kinds_Dyadic_Operator => + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then + return Translate_Predefined_Operator + (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type, Expr); + else + return Translate_Operator_Function_Call + (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type); + end if; + when Iir_Kinds_Monadic_Operator => + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then + return Translate_Predefined_Operator + (Imp, Get_Operand (Expr), Null_Iir, Res_Type, Expr); + else + return Translate_Operator_Function_Call + (Imp, Get_Operand (Expr), Null_Iir, Res_Type); + end if; + when Iir_Kind_Function_Call => + Imp := Get_Implementation (Expr); + declare + Assoc_Chain : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration + then + declare + Left, Right : Iir; + begin + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + if Assoc_Chain = Null_Iir then + Left := Null_Iir; + Right := Null_Iir; + else + Left := Get_Actual (Assoc_Chain); + Assoc_Chain := Get_Chain (Assoc_Chain); + if Assoc_Chain = Null_Iir then + Right := Null_Iir; + else + Right := Get_Actual (Assoc_Chain); + end if; + end if; + return Translate_Predefined_Operator + (Imp, Left, Right, Res_Type, Expr); + end; + else + Canon.Canon_Subprogram_Call (Expr); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Res := Translate_Function_Call + (Imp, Assoc_Chain, Get_Method_Object (Expr)); + Expr_Type := Get_Return_Type (Imp); + end if; + end; + + when Iir_Kind_Type_Conversion => + declare + Conv_Expr : Iir; + begin + Conv_Expr := Get_Expression (Expr); + Res := Translate_Type_Conversion + (Translate_Expression (Conv_Expr), Get_Type (Conv_Expr), + Expr_Type, Expr); + end; + + when Iir_Kind_Length_Array_Attribute => + return Chap14.Translate_Length_Array_Attribute + (Expr, Res_Type); + when Iir_Kind_Low_Array_Attribute => + return Chap14.Translate_Low_Array_Attribute (Expr); + when Iir_Kind_High_Array_Attribute => + return Chap14.Translate_High_Array_Attribute (Expr); + when Iir_Kind_Left_Array_Attribute => + return Chap14.Translate_Left_Array_Attribute (Expr); + when Iir_Kind_Right_Array_Attribute => + return Chap14.Translate_Right_Array_Attribute (Expr); + when Iir_Kind_Ascending_Array_Attribute => + return Chap14.Translate_Ascending_Array_Attribute (Expr); + + when Iir_Kind_Val_Attribute => + return Chap14.Translate_Val_Attribute (Expr); + when Iir_Kind_Pos_Attribute => + return Chap14.Translate_Pos_Attribute (Expr, Res_Type); + + when Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute => + return Chap14.Translate_Succ_Pred_Attribute (Expr); + + when Iir_Kind_Image_Attribute => + Res := Chap14.Translate_Image_Attribute (Expr); + + when Iir_Kind_Value_Attribute => + return Chap14.Translate_Value_Attribute (Expr); + + when Iir_Kind_Event_Attribute => + return Chap14.Translate_Event_Attribute (Expr); + when Iir_Kind_Active_Attribute => + return Chap14.Translate_Active_Attribute (Expr); + when Iir_Kind_Last_Value_Attribute => + Res := Chap14.Translate_Last_Value_Attribute (Expr); + + when Iir_Kind_High_Type_Attribute => + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), True); + when Iir_Kind_Low_Type_Attribute => + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), False); + when Iir_Kind_Left_Type_Attribute => + return M2E + (Chap3.Range_To_Left + (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), + Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); + when Iir_Kind_Right_Type_Attribute => + return M2E + (Chap3.Range_To_Right + (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), + Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); + + when Iir_Kind_Last_Event_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Event_Field); + when Iir_Kind_Last_Active_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Active_Field); + + when Iir_Kind_Driving_Value_Attribute => + Res := Chap14.Translate_Driving_Value_Attribute (Expr); + when Iir_Kind_Driving_Attribute => + Res := Chap14.Translate_Driving_Attribute (Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + Res := Chap14.Translate_Path_Instance_Name_Attribute (Expr); + + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Selected_Name => + return Translate_Expression (Get_Named_Entity (Expr), Rtype); + + when others => + Error_Kind ("translate_expression", Expr); + end case; + + -- Quick test to avoid useless calls. + if Expr_Type /= Res_Type then + Res := Translate_Implicit_Conv + (Res, Expr_Type, Res_Type, Mode_Value, Expr); + end if; + + return Res; + end Translate_Expression; + + -- Check if RNG is of the form: + -- 1 to T'length + -- or T'Length downto 1 + -- or 0 to T'length - 1 + -- or T'Length - 1 downto 0 + -- In either of these cases, return T'Length + function Is_Length_Range_Expression (Rng : Iir_Range_Expression) + return Iir + is + -- Pattern of a bound. + type Length_Pattern is + ( + Pat_Unknown, + Pat_Length, + Pat_Length_1, -- Length - 1 + Pat_1, + Pat_0 + ); + Length_Attr : Iir := Null_Iir; + + -- Classify the bound. + -- Set LENGTH_ATTR is the pattern is Pat_Length. + function Get_Length_Pattern (Expr : Iir; Recurse : Boolean) + return Length_Pattern + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Length_Array_Attribute => + Length_Attr := Expr; + return Pat_Length; + when Iir_Kind_Integer_Literal => + case Get_Value (Expr) is + when 0 => + return Pat_0; + when 1 => + return Pat_1; + when others => + return Pat_Unknown; + end case; + when Iir_Kind_Substraction_Operator => + if not Recurse then + return Pat_Unknown; + end if; + if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length + and then + Get_Length_Pattern (Get_Right (Expr), False) = Pat_1 + then + return Pat_Length_1; + else + return Pat_Unknown; + end if; + when others => + return Pat_Unknown; + end case; + end Get_Length_Pattern; + Left_Pat, Right_Pat : Length_Pattern; + begin + Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True); + if Left_Pat = Pat_Unknown then + return Null_Iir; + end if; + Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True); + if Right_Pat = Pat_Unknown then + return Null_Iir; + end if; + case Get_Direction (Rng) is + when Iir_To => + if (Left_Pat = Pat_1 and Right_Pat = Pat_Length) + or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1) + then + return Length_Attr; + end if; + when Iir_Downto => + if (Left_Pat = Pat_Length and Right_Pat = Pat_1) + or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0) + then + return Length_Attr; + end if; + end case; + return Null_Iir; + end Is_Length_Range_Expression; + + procedure Translate_Range_Expression_Ptr + (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir) + is + T_Info : Type_Info_Acc; + Length_Attr : Iir; + begin + T_Info := Get_Info (Range_Type); + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Left), + Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Right), + Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Dir), + New_Lit (Chap7.Translate_Static_Range_Dir (Expr))); + if T_Info.T.Range_Length /= O_Fnode_Null then + if Get_Expr_Staticness (Expr) = Locally then + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + New_Lit (Translate_Static_Range_Length (Expr))); + else + Length_Attr := Is_Length_Range_Expression (Expr); + if Length_Attr = Null_Iir then + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Compute_Range_Length + (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Right), + Get_Direction (Expr))); + Close_Temp; + else + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Chap14.Translate_Length_Array_Attribute + (Length_Attr, Null_Iir)); + end if; + end if; + end if; + Close_Temp; + end Translate_Range_Expression_Ptr; + + -- Reverse range ARANGE. + procedure Translate_Reverse_Range_Ptr + (Res_Ptr : O_Dnode; Arange : O_Lnode; Range_Type : Iir) + is + Rinfo : Type_Info_Acc; + Ptr : O_Dnode; + If_Blk : O_If_Block; + begin + Rinfo := Get_Info (Get_Base_Type (Range_Type)); + Open_Temp; + Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, Arange); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Right)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Right), + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Left)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Length), + New_Value_Selected_Acc_Value (New_Obj (Ptr), + Rinfo.T.Range_Length)); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_Downto_Node)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end Translate_Reverse_Range_Ptr; + + procedure Copy_Range (Dest_Ptr : O_Dnode; + Src_Ptr : O_Dnode; + Info : Type_Info_Acc) + is + begin + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Left)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Right), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Right)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Dir), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Dir)); + if Info.T.Range_Length /= O_Fnode_Null then + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), + Info.T.Range_Length), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Length)); + end if; + end Copy_Range; + + procedure Translate_Range_Ptr + (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir) + is + begin + case Get_Kind (Arange) is + when Iir_Kind_Range_Array_Attribute => + declare + Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Get_Base_Type (Range_Type)); + Open_Temp; + Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, + Chap14.Translate_Range_Array_Attribute (Arange)); + Copy_Range (Res_Ptr, Ptr, Rinfo); + Close_Temp; + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + Translate_Reverse_Range_Ptr + (Res_Ptr, + Chap14.Translate_Range_Array_Attribute (Arange), + Range_Type); + when Iir_Kind_Range_Expression => + Translate_Range_Expression_Ptr (Res_Ptr, Arange, Range_Type); + when others => + Error_Kind ("translate_range_ptr", Arange); + end case; + end Translate_Range_Ptr; + + procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir) + is + begin + case Get_Kind (Arange) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + if not Is_Anonymous_Type_Definition (Arange) then + declare + Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Arange); + Open_Temp; + Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, Get_Var (Rinfo.T.Range_Var)); + Copy_Range (Res_Ptr, Ptr, Rinfo); + Close_Temp; + end; + else + Translate_Range_Ptr (Res_Ptr, + Get_Range_Constraint (Arange), + Get_Base_Type (Arange)); + end if; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Range_Expression => + Translate_Range_Ptr (Res_Ptr, Arange, Get_Type (Arange)); + when others => + Error_Kind ("translate_discrete_range_ptr", Arange); + end case; + end Translate_Discrete_Range_Ptr; + + function Translate_Range (Arange : Iir; Range_Type : Iir) + return O_Lnode is + begin + case Get_Kind (Arange) is + when Iir_Kinds_Denoting_Name => + return Translate_Range (Get_Named_Entity (Arange), Range_Type); + when Iir_Kind_Subtype_Declaration => + -- Must be a scalar subtype. Range of types is static. + return Get_Var (Get_Info (Get_Type (Arange)).T.Range_Var); + when Iir_Kind_Range_Array_Attribute => + return Chap14.Translate_Range_Array_Attribute (Arange); + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + Res : O_Dnode; + Res_Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Range_Type); + Res := Create_Temp (Rinfo.T.Range_Type); + Open_Temp; + Res_Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, + New_Obj (Res)); + Translate_Reverse_Range_Ptr + (Res_Ptr, + Chap14.Translate_Range_Array_Attribute (Arange), + Range_Type); + Close_Temp; + return New_Obj (Res); + end; + when Iir_Kind_Range_Expression => + declare + Res : O_Dnode; + Ptr : O_Dnode; + T_Info : Type_Info_Acc; + begin + T_Info := Get_Info (Range_Type); + Res := Create_Temp (T_Info.T.Range_Type); + Open_Temp; + Ptr := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, + New_Obj (Res)); + Translate_Range_Expression_Ptr (Ptr, Arange, Range_Type); + Close_Temp; + return New_Obj (Res); + end; + when others => + Error_Kind ("translate_range", Arange); + end case; + return O_Lnode_Null; + end Translate_Range; + + function Translate_Static_Range (Arange : Iir; Range_Type : Iir) + return O_Cnode + is + Constr : O_Record_Aggr_List; + Res : O_Cnode; + T_Info : Type_Info_Acc; + begin + T_Info := Get_Info (Range_Type); + Start_Record_Aggr (Constr, T_Info.T.Range_Type); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Left (Arange, Range_Type)); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Right (Arange, Range_Type)); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Dir (Arange)); + if T_Info.T.Range_Length /= O_Fnode_Null then + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Length (Arange)); + end if; + Finish_Record_Aggr (Constr, Res); + return Res; + end Translate_Static_Range; + + procedure Translate_Predefined_Array_Compare (Subprg : Iir) + is + procedure Gen_Compare (L, R : O_Dnode) + is + If_Blk1, If_Blk2 : O_If_Block; + begin + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Neq, New_Obj_Value (L), New_Obj_Value (R), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Gt, New_Obj_Value (L), New_Obj_Value (R), + Ghdl_Bool_Type)); + New_Return_Stmt (New_Lit (Ghdl_Compare_Gt)); + New_Else_Stmt (If_Blk2); + New_Return_Stmt (New_Lit (Ghdl_Compare_Lt)); + Finish_If_Stmt (If_Blk2); + Finish_If_Stmt (If_Blk1); + end Gen_Compare; + + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info : Subprg_Info_Acc; + L, R : O_Dnode; + Interface_List : O_Inter_List; + If_Blk : O_If_Block; + Var_L_Len, Var_R_Len : O_Dnode; + Var_L_El, Var_R_El : O_Dnode; + Var_I, Var_Len : O_Dnode; + Label : O_Snode; + El_Otype : O_Tnode; + begin + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_CMP"), + Global_Storage, Ghdl_Compare_Type); + New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + El_Otype := Get_Ortho_Type + (Get_Element_Subtype (Arr_Type), Mode_Value); + Start_Subprogram_Body (F_Info.Ortho_Func); + -- Compute length of L and R. + New_Var_Decl (Var_L_Len, Wki_L_Len, + O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Wki_R_Len, + O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Obj (Var_L_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); + New_Assign_Stmt (New_Obj (Var_R_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1)); + -- Find the minimum length. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_L_Len), + New_Obj_Value (Var_R_Len), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_R_Len)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_L_Len)); + Finish_If_Stmt (If_Blk); + + -- for each element, compare elements; if not equal return the + -- comparaison result. + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Len), + Ghdl_Bool_Type)); + -- Compare the length and return the result. + Gen_Compare (Var_L_Len, Var_R_Len); + New_Return_Stmt (New_Lit (Ghdl_Compare_Eq)); + Finish_If_Stmt (If_Blk); + Start_Declare_Stmt; + New_Var_Decl (Var_L_El, Get_Identifier ("l_el"), O_Storage_Local, + El_Otype); + New_Var_Decl (Var_R_El, Get_Identifier ("r_el"), O_Storage_Local, + El_Otype); + New_Assign_Stmt + (New_Obj (Var_L_El), + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); + New_Assign_Stmt + (New_Obj (Var_R_El), + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); + Gen_Compare (Var_L_El, Var_R_El); + Finish_Declare_Stmt; + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Compare; + + -- Find the declaration of the predefined function IMP in type + -- definition BASE_TYPE. + function Find_Predefined_Function + (Base_Type : Iir; Imp : Iir_Predefined_Functions) + return Iir + is + El : Iir; + begin + El := Get_Chain (Get_Type_Declarator (Base_Type)); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + if Get_Implicit_Definition (El) = Imp then + return El; + else + El := Get_Chain (El); + end if; + when others => + raise Internal_Error; + end case; + end loop; + raise Internal_Error; + end Find_Predefined_Function; + + function Translate_Equality (L, R : Mnode; Etype : Iir) + return O_Enode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (L); + case Tinfo.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc => + return New_Compare_Op (ON_Eq, M2E (L), M2E (R), + Ghdl_Bool_Type); + when Type_Mode_Fat_Acc => + -- a fat pointer. + declare + B : Type_Info_Acc; + Ln, Rn : Mnode; + V1, V2 : O_Enode; + begin + B := Get_Info (Get_Designated_Type (Etype)); + Ln := Stabilize (L); + Rn := Stabilize (R); + V1 := New_Compare_Op + (ON_Eq, + New_Value (New_Selected_Element + (M2Lv (Ln), B.T.Base_Field (Mode_Value))), + New_Value (New_Selected_Element + (M2Lv (Rn), B.T.Base_Field (Mode_Value))), + Std_Boolean_Type_Node); + V2 := New_Compare_Op + (ON_Eq, + New_Value (New_Selected_Element + (M2Lv (Ln), B.T.Bounds_Field (Mode_Value))), + New_Value (New_Selected_Element + (M2Lv (Rn), B.T.Bounds_Field (Mode_Value))), + Std_Boolean_Type_Node); + return New_Dyadic_Op (ON_And, V1, V2); + end; + + when Type_Mode_Array => + declare + Lc, Rc : O_Enode; + Base_Type : Iir_Array_Type_Definition; + Func : Iir; + begin + Base_Type := Get_Base_Type (Etype); + Lc := Translate_Implicit_Conv + (M2E (L), Etype, Base_Type, Mode_Value, Null_Iir); + Rc := Translate_Implicit_Conv + (M2E (R), Etype, Base_Type, Mode_Value, Null_Iir); + Func := Find_Predefined_Function + (Base_Type, Iir_Predefined_Array_Equality); + return Translate_Predefined_Lib_Operator (Lc, Rc, Func); + end; + + when Type_Mode_Record => + declare + Func : Iir; + begin + Func := Find_Predefined_Function + (Get_Base_Type (Etype), Iir_Predefined_Record_Equality); + return Translate_Predefined_Lib_Operator + (M2E (L), M2E (R), Func); + end; + + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Equality; + + procedure Translate_Predefined_Array_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + Indexes : Iir_List; + Nbr_Indexes : Natural; + If_Blk : O_If_Block; + Var_I : O_Dnode; + Var_Len : O_Dnode; + Label : O_Snode; + Le, Re : Mnode; + El_Type : Iir; + begin + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + El_Type := Get_Element_Subtype (Arr_Type); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + Indexes := Get_Index_Subtype_List (Arr_Type); + Nbr_Indexes := Get_Nbr_Elements (Indexes); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + -- for each dimension: if length mismatch: return false + for I in 1 .. Nbr_Indexes loop + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Neq, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, Arr_Type, I))), + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, Arr_Type, I))), + Std_Boolean_Type_Node)); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + end loop; + + -- for each element: if element is not equal, return false + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + Open_Temp; + New_Assign_Stmt (New_Obj (Var_Len), + Chap3.Get_Array_Length (L, Arr_Type)); + Close_Temp; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + -- If the end of the array is reached, return TRUE. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Len), + Ghdl_Bool_Type)); + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (If_Blk); + Open_Temp; + Le := Chap3.Index_Base (Chap3.Get_Array_Base (L), Arr_Type, + New_Obj_Value (Var_I)); + Re := Chap3.Index_Base (Chap3.Get_Array_Base (R), Arr_Type, + New_Obj_Value (Var_I)); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, Translate_Equality (Le, Re, El_Type))); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Equality; + + procedure Translate_Predefined_Record_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Rec_Type : Iir_Record_Type_Definition; + Rec_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + If_Blk : O_If_Block; + Le, Re : Mnode; + + El_List : Iir_List; + El : Iir_Element_Declaration; + begin + Rec_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info := Get_Info (Rec_Type); + Id := Get_Identifier (Get_Type_Declarator (Rec_Type)); + Rec_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Rec_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Rec_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + -- Compare each element. + El_List := Get_Elements_Declaration_List (Rec_Type); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Le := Chap6.Translate_Selected_Element (L, El); + Re := Chap6.Translate_Selected_Element (R, El); + + Open_Temp; + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, + Translate_Equality (Le, Re, Get_Type (El)))); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end loop; + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Record_Equality; + + procedure Translate_Predefined_Array_Array_Concat (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + + -- Info for the array type. + Info : Type_Info_Acc; + + -- Info for the index type. + Iinfo : Type_Info_Acc; + Index_Type : Iir; + + Index_Otype : O_Tnode; + Id : Name_Id; + Interface_List : O_Inter_List; + Var_Res, Var_L, Var_R : O_Dnode; + Res, L, R : Mnode; + Var_Length, Var_L_Len, Var_R_Len : O_Dnode; + Var_Bounds, Var_Right : O_Dnode; + V_Bounds : Mnode; + If_Blk : O_If_Block; + begin + Arr_Type := Get_Return_Type (Subprg); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + F_Info.Use_Stack2 := True; + + -- Create function. + Start_Procedure_Decl + (Interface_List, Create_Identifier (Id, "_CONCAT"), Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a concatenation returns its value without + -- the use of the record. + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Index_Type := Get_Index_Type (Arr_Type, 0); + Iinfo := Get_Info (Index_Type); + Index_Otype := Iinfo.Ortho_Type (Mode_Value); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_L_Len, Wki_L_Len, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Wki_R_Len, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Bounds, Get_Identifier ("bounds"), O_Storage_Local, + Info.T.Bounds_Ptr_Type); + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + Res := Dp2M (Var_Res, Info, Mode_Value); + V_Bounds := Dp2M (Var_Bounds, Info, Mode_Value, + Info.T.Bounds_Type, Info.T.Bounds_Ptr_Type); + + -- Compute length. + New_Assign_Stmt + (New_Obj (Var_L_Len), Chap3.Get_Array_Length (L, Arr_Type)); + New_Assign_Stmt + (New_Obj (Var_R_Len), Chap3.Get_Array_Length (R, Arr_Type)); + New_Assign_Stmt + (New_Obj (Var_Length), New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_L_Len), + New_Obj_Value (Var_R_Len))); + + -- Check case where the result is the right operand. + declare + Len : O_Enode; + begin + if Flags.Vhdl_Std = Vhdl_87 then + -- LRM87 7.2.4 + -- [...], unless the left operand is a null array, in which + -- case the result of the concatenation is the right operand. + Len := New_Obj_Value (Var_L_Len); + + else + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + -- GHDL: since the length type is unsigned, then both operands + -- are null arrays iff the result is a null array. + Len := New_Obj_Value (Var_Length); + end if; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + Len, + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Copy_Fat_Pointer (Res, R); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + end; + + -- Allocate bounds. + New_Assign_Stmt + (New_Obj (Var_Bounds), + Gen_Alloc (Alloc_Return, + New_Lit (New_Sizeof (Info.T.Bounds_Type, + Ghdl_Index_Type)), + Info.T.Bounds_Ptr_Type)); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), New_Obj_Value (Var_Bounds)); + + -- Set bound. + if Flags.Vhdl_Std = Vhdl_87 then + -- Set length. + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Length + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Length)); + + -- Set direction, left bound and right bound. + -- LRM87 7.2.4 + -- The left bound of this result is the left bound of the left + -- operand, unless the left operand is a null array, in which + -- case the result of the concatenation is the right operand. + -- The direction of the result is the direction of the left + -- operand, unless the left operand is a null array, in which + -- case the direction of the result is that of the right operand. + declare + Var_Dir, Var_Left : O_Dnode; + Var_Length1 : O_Dnode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), + O_Storage_Local, Index_Otype); + New_Var_Decl (Var_Dir, Wki_Dir, O_Storage_Local, + Ghdl_Dir_Type_Node); + New_Var_Decl (Var_Left, Get_Identifier ("left_bound"), + O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); + New_Var_Decl (Var_Length1, Get_Identifier ("length_1"), + O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Var_Dir), + M2E (Chap3.Range_To_Dir + (Chap3.Get_Array_Range (L, Arr_Type, 1)))); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Dir + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Dir)); + New_Assign_Stmt + (New_Obj (Var_Left), + M2E (Chap3.Range_To_Left + (Chap3.Get_Array_Range (L, Arr_Type, 1)))); + -- Note this substraction cannot overflow, since LENGTH >= 1. + New_Assign_Stmt + (New_Obj (Var_Length1), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_1))); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Left + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Left)); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, New_Obj_Value (Var_Dir), + New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Var_Right), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Left), + New_Convert_Ov (New_Obj_Value (Var_Length1), + Index_Otype))); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Obj (Var_Right), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Left), + New_Convert_Ov (New_Obj_Value (Var_Length1), + Index_Otype))); + Finish_If_Stmt (If_Blk); + -- Check the right bounds is inside the bounds of the + -- index type. + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Subprg); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Right + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Right)); + Finish_Declare_Stmt; + end; + else + -- LRM93 7.2.4 + -- [...], the direction and bounds of the result are determined + -- as follows: Let S be the index subtype of the base type of the + -- result. The direction of the result of the concatenation is + -- the direction of S, and the left bound of the result is + -- S'LEFT. + declare + Var_Range_Ptr : O_Dnode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_Range_Ptr, Get_Identifier ("range_ptr"), + O_Storage_Local, Iinfo.T.Range_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Range_Ptr), + M2Addr (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))); + Chap3.Create_Range_From_Length + (Index_Type, Var_Length, Var_Range_Ptr, Subprg); + Finish_Declare_Stmt; + end; + end if; + + -- Allocate array base. + Chap3.Allocate_Fat_Array_Base (Alloc_Return, Res, Arr_Type); + + -- Copy left. + declare + V_Arr : O_Dnode; + Var_Arr : Mnode; + begin + Open_Temp; + V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); + Var_Arr := Dv2M (V_Arr, Info, Mode_Value); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), + M2Addr (Chap3.Get_Array_Bounds (L))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Var_Arr)), + M2Addr (Chap3.Get_Array_Base (Res))); + Chap3.Translate_Object_Copy + (Var_Arr, New_Obj_Value (Var_L), Arr_Type); + Close_Temp; + end; + + -- Copy right. + declare + V_Arr : O_Dnode; + Var_Arr : Mnode; + begin + Open_Temp; + V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); + Var_Arr := Dv2M (V_Arr, Info, Mode_Value); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), + M2Addr (Chap3.Get_Array_Bounds (R))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Var_Arr)), + M2Addr (Chap3.Slice_Base (Chap3.Get_Array_Base (Res), + Arr_Type, + New_Obj_Value (Var_L_Len)))); + Chap3.Translate_Object_Copy + (Var_Arr, New_Obj_Value (Var_R), Arr_Type); + Close_Temp; + end; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Array_Concat; + + procedure Translate_Predefined_Array_Logical (Subprg : Iir) + is + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); + -- Info for the array type. + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + -- Identifier of the type. + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + F_Info : Subprg_Info_Acc; + Interface_List : O_Inter_List; + Var_Res : O_Dnode; + Res : Mnode; + L, R : O_Dnode; + Var_Length, Var_I : O_Dnode; + Var_Base, Var_L_Base, Var_R_Base : O_Dnode; + If_Blk : O_If_Block; + Label : O_Snode; + Name : O_Ident; + Is_Monadic : Boolean; + El, L_El : O_Enode; + Op : ON_Op_Kind; + Do_Invert : Boolean; + begin + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := True; + + Is_Monadic := False; + case Get_Implicit_Definition (Subprg) is + when Iir_Predefined_TF_Array_And => + Name := Create_Identifier (Id, "_AND"); + Op := ON_And; + Do_Invert := False; + when Iir_Predefined_TF_Array_Or => + Name := Create_Identifier (Id, "_OR"); + Op := ON_Or; + Do_Invert := False; + when Iir_Predefined_TF_Array_Nand => + Name := Create_Identifier (Id, "_NAND"); + Op := ON_And; + Do_Invert := True; + when Iir_Predefined_TF_Array_Nor => + Name := Create_Identifier (Id, "_NOR"); + Op := ON_Or; + Do_Invert := True; + when Iir_Predefined_TF_Array_Xor => + Name := Create_Identifier (Id, "_XOR"); + Op := ON_Xor; + Do_Invert := False; + when Iir_Predefined_TF_Array_Xnor => + Name := Create_Identifier (Id, "_XNOR"); + Op := ON_Xor; + Do_Invert := True; + when Iir_Predefined_TF_Array_Not => + Name := Create_Identifier (Id, "_NOT"); + Is_Monadic := True; + Op := ON_Not; + Do_Invert := False; + when others => + raise Internal_Error; + end case; + + -- Create function. + Start_Procedure_Decl (Interface_List, Name, Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a concatenation returns its value without + -- the use of the record. + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); + if not Is_Monadic then + New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); + end if; + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Base, Get_Identifier ("base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + if not Is_Monadic then + New_Var_Decl + (Var_R_Base, Get_Identifier ("r_base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + end if; + Open_Temp; + -- Get length of LEFT. + New_Assign_Stmt (New_Obj (Var_Length), + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); + -- If dyadic, check RIGHT has the same length. + if not Is_Monadic then + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Neq, + New_Obj_Value (Var_Length), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1), + Ghdl_Bool_Type), + Subprg, 0); + end if; + + -- Create the result from LEFT bound. + Res := Dp2M (Var_Res, Info, Mode_Value); + Chap3.Translate_Object_Allocation + (Res, Alloc_Return, Arr_Type, + Chap3.Get_Array_Bounds (Dp2M (L, Info, Mode_Value))); + New_Assign_Stmt + (New_Obj (Var_Base), M2Addr (Chap3.Get_Array_Base (Res))); + New_Assign_Stmt + (New_Obj (Var_L_Base), + M2Addr (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)))); + if not Is_Monadic then + New_Assign_Stmt + (New_Obj (Var_R_Base), + M2Addr (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)))); + end if; + + -- Do the logical operation on each element. + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + L_El := New_Value (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_L_Base)), + New_Obj_Value (Var_I))); + if Is_Monadic then + El := New_Monadic_Op (Op, L_El); + else + El := New_Dyadic_Op + (Op, L_El, + New_Value (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_R_Base)), + New_Obj_Value (Var_I)))); + end if; + if Do_Invert then + El := New_Monadic_Op (ON_Not, El); + end if; + + New_Assign_Stmt (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_Base)), + New_Obj_Value (Var_I)), + El); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + Finish_Subprogram_Body; + end Translate_Predefined_Array_Logical; + + procedure Translate_Predefined_Array_Shift (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Inter : Iir; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Int_Type : O_Tnode; + -- Info for the array type. + Info : Type_Info_Acc; + Id : Name_Id; + Interface_List : O_Inter_List; + Var_Res : O_Dnode; + Var_L, Var_R : O_Dnode; + Name : O_Ident; + + type Shift_Kind is (Sh_Logical, Sh_Arith, Rotation); + Shift : Shift_Kind; + + -- Body; + Var_Length, Var_I, Var_I1 : O_Dnode; + Var_Res_Base, Var_L_Base : O_Dnode; + Var_Rl : O_Dnode; + Var_E : O_Dnode; + L : Mnode; + If_Blk, If_Blk1 : O_If_Block; + Label : O_Snode; + Res : Mnode; + + procedure Do_Shift (To_Right : Boolean) + is + Tmp : O_Enode; + begin + -- LEFT: + -- * I := 0; + if not To_Right then + Init_Var (Var_I); + end if; + + -- * If R < LENGTH then + Start_If_Stmt (If_Blk1, + New_Compare_Op (ON_Lt, + New_Obj_Value (Var_Rl), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + -- Shift the elements (that remains in the result). + -- RIGHT: + -- * for I = R to LENGTH - 1 loop + -- * RES[I] := L[I - R] + -- LEFT: + -- * for I = 0 to LENGTH - R loop + -- * RES[I] := L[R + I] + if To_Right then + New_Assign_Stmt (New_Obj (Var_I), New_Obj_Value (Var_Rl)); + Init_Var (Var_I1); + else + New_Assign_Stmt (New_Obj (Var_I1), New_Obj_Value (Var_Rl)); + end if; + Start_Loop_Stmt (Label); + if To_Right then + Tmp := New_Obj_Value (Var_I); + else + Tmp := New_Obj_Value (Var_I1); + end if; + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + Tmp, + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), + New_Value + (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + New_Obj_Value (Var_I1)))); + Inc_Var (Var_I); + Inc_Var (Var_I1); + Finish_Loop_Stmt (Label); + -- RIGHT: + -- * else + -- * R := LENGTH; + if To_Right then + New_Else_Stmt (If_Blk1); + New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); + end if; + Finish_If_Stmt (If_Blk1); + + -- Pad the result. + -- RIGHT: + -- * For I = 0 to R - 1 + -- * RES[I] := 0/L[0/LENGTH-1] + -- LEFT: + -- * For I = LENGTH - R to LENGTH - 1 + -- * RES[I] := 0/L[0/LENGTH-1] + if To_Right then + Init_Var (Var_I); + else + -- I is yet correctly set. + null; + end if; + if Shift = Sh_Arith then + if To_Right then + Tmp := New_Lit (Ghdl_Index_0); + else + Tmp := New_Dyadic_Op + (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_1)); + end if; + New_Assign_Stmt + (New_Obj (Var_E), + New_Value (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + Tmp))); + end if; + Start_Loop_Stmt (Label); + if To_Right then + Tmp := New_Obj_Value (Var_Rl); + else + Tmp := New_Obj_Value (Var_Length); + end if; + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + Tmp, + Ghdl_Bool_Type)); + case Shift is + when Sh_Logical => + declare + Enum_List : Iir_List; + begin + Enum_List := Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Arr_Type))); + Tmp := New_Lit + (Get_Ortho_Expr (Get_First_Element (Enum_List))); + end; + when Sh_Arith => + Tmp := New_Obj_Value (Var_E); + when Rotation => + raise Internal_Error; + end case; + + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), Tmp); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + end Do_Shift; + begin + Inter := Get_Interface_Declaration_Chain (Subprg); + + Info := Get_Info (Get_Type (Get_Chain (Inter))); + Int_Type := Info.Ortho_Type (Mode_Value); + + Arr_Type := Get_Type (Inter); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := True; + + case Get_Implicit_Definition (Subprg) is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + -- Shift logical. + Name := Create_Identifier (Id, "_SHL"); + Shift := Sh_Logical; + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + -- Shift arithmetic. + Name := Create_Identifier (Id, "_SHA"); + Shift := Sh_Arith; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + -- Rotation + Name := Create_Identifier (Id, "_ROT"); + Shift := Rotation; + when others => + raise Internal_Error; + end case; + + -- Create function. + Start_Procedure_Decl (Interface_List, Name, Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a shift returns its value without + -- the use of the record. + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Int_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Body + Start_Subprogram_Body (F_Info.Ortho_Func); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + if Shift /= Rotation then + New_Var_Decl (Var_Rl, Get_Identifier ("rl"), O_Storage_Local, + Ghdl_Index_Type); + end if; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_I1, Get_Identifier ("I1"), O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_Res_Base, Get_Identifier ("res_base"), + O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); + New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), + O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); + if Shift = Sh_Arith then + New_Var_Decl (Var_E, Get_Identifier ("E"), O_Storage_Local, + Get_Info (Get_Element_Subtype (Arr_Type)). + Ortho_Type (Mode_Value)); + end if; + Res := Dp2M (Var_Res, Info, Mode_Value); + L := Dp2M (Var_L, Info, Mode_Value); + + -- LRM93 7.2.3 + -- The index subtypes of the return values of all shift operators is + -- the same as the index subtype of their left arguments. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (L))); + + -- Get length of LEFT. + New_Assign_Stmt (New_Obj (Var_Length), + Chap3.Get_Array_Length (L, Arr_Type)); + + -- LRM93 7.2.3 [6 times] + -- That is, if R is 0 or L is a null array, the return value is L. + Start_If_Stmt + (If_Blk, + New_Dyadic_Op + (ON_Or, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_R), + New_Lit (New_Signed_Literal (Int_Type, 0)), + Ghdl_Bool_Type), + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + M2Addr (Chap3.Get_Array_Base (L))); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + + -- Allocate base. + New_Assign_Stmt + (New_Obj (Var_Res_Base), + Gen_Alloc (Alloc_Return, New_Obj_Value (Var_Length), + Info.T.Base_Ptr_Type (Mode_Value))); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), + New_Obj_Value (Var_Res_Base)); + + New_Assign_Stmt (New_Obj (Var_L_Base), + M2Addr (Chap3.Get_Array_Base (L))); + + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Gt, + New_Obj_Value (Var_R), + New_Lit (New_Signed_Literal (Int_Type, + 0)), + Ghdl_Bool_Type)); + -- R > 0. + -- Ie, to the right + case Shift is + when Rotation => + -- * I1 := LENGTH - (R mod LENGTH) + New_Assign_Stmt + (New_Obj (Var_I1), + New_Dyadic_Op + (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Dyadic_Op (ON_Mod_Ov, + New_Convert_Ov (New_Obj_Value (Var_R), + Ghdl_Index_Type), + New_Obj_Value (Var_Length)))); + + when Sh_Logical + | Sh_Arith => + -- Real SRL or SRA. + New_Assign_Stmt + (New_Obj (Var_Rl), + New_Convert_Ov (New_Obj_Value (Var_R), Ghdl_Index_Type)); + + Do_Shift (True); + end case; + + New_Else_Stmt (If_Blk); + + -- R < 0, to the left. + case Shift is + when Rotation => + -- * I1 := (-R) mod LENGTH + New_Assign_Stmt + (New_Obj (Var_I1), + New_Dyadic_Op (ON_Mod_Ov, + New_Convert_Ov + (New_Monadic_Op (ON_Neg_Ov, + New_Obj_Value (Var_R)), + Ghdl_Index_Type), + New_Obj_Value (Var_Length))); + when Sh_Logical + | Sh_Arith => + -- Real SLL or SLA. + New_Assign_Stmt + (New_Obj (Var_Rl), + New_Convert_Ov (New_Monadic_Op (ON_Neg_Ov, + New_Obj_Value (Var_R)), + Ghdl_Index_Type)); + + Do_Shift (False); + end case; + Finish_If_Stmt (If_Blk); + + if Shift = Rotation then + -- * If I1 = LENGTH then + -- * I1 := 0 + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I1), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Init_Var (Var_I1); + Finish_If_Stmt (If_Blk); + + -- * for I = 0 to LENGTH - 1 loop + -- * RES[I] := L[I1]; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), + New_Value + (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + New_Obj_Value (Var_I1)))); + Inc_Var (Var_I); + -- * I1 := I1 + 1 + Inc_Var (Var_I1); + -- * If I1 = LENGTH then + -- * I1 := 0 + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I1), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Init_Var (Var_I1); + Finish_If_Stmt (If_Blk); + Finish_Loop_Stmt (Label); + end if; + Finish_Subprogram_Body; + end Translate_Predefined_Array_Shift; + + procedure Translate_File_Subprogram (Subprg : Iir; File_Type : Iir) + is + Etype : Iir; + Tinfo : Type_Info_Acc; + Kind : Iir_Predefined_Functions; + F_Info : Subprg_Info_Acc; + Name : O_Ident; + Inter_List : O_Inter_List; + Id : Name_Id; + Var_File : O_Dnode; + Var_Val : O_Dnode; + + procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode); + + procedure Translate_Rw_Array + (Val : Mnode; Val_Type : Iir; Var_Max : O_Dnode; Proc : O_Dnode) + is + Var_It : O_Dnode; + Label : O_Snode; + begin + Var_It := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_It); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_It), + New_Obj_Value (Var_Max), + Ghdl_Bool_Type)); + Translate_Rw + (Chap3.Index_Base (Val, Val_Type, New_Obj_Value (Var_It)), + Get_Element_Subtype (Val_Type), Proc); + Inc_Var (Var_It); + Finish_Loop_Stmt (Label); + end Translate_Rw_Array; + + procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode) + is + Val_Info : Type_Info_Acc; + Assocs : O_Assoc_List; + begin + Val_Info := Get_Type_Info (Val); + case Val_Info.Type_Mode is + when Type_Mode_Scalar => + Start_Association (Assocs, Proc); + -- compute file parameter (get an index) + New_Association (Assocs, New_Obj_Value (Var_File)); + -- compute the value. + New_Association + (Assocs, New_Convert_Ov (M2Addr (Val), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, + New_Lit (New_Sizeof (Val_Info.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + when Type_Mode_Record => + declare + El_List : Iir_List; + El : Iir; + Val1 : Mnode; + begin + Open_Temp; + Val1 := Stabilize (Val); + El_List := Get_Elements_Declaration_List + (Get_Base_Type (Val_Type)); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Translate_Rw + (Chap6.Translate_Selected_Element (Val1, El), + Get_Type (El), Proc); + end loop; + Close_Temp; + end; + when Type_Mode_Array => + declare + Var_Max : O_Dnode; + begin + Open_Temp; + Var_Max := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Var_Max), + Chap3.Get_Array_Type_Length (Val_Type)); + Translate_Rw_Array (Val, Val_Type, Var_Max, Proc); + Close_Temp; + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Fat_Array + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Rw; + + procedure Translate_Rw_Length (Var_Length : O_Dnode; Proc : O_Dnode) + is + Assocs : O_Assoc_List; + begin + Start_Association (Assocs, Proc); + New_Association (Assocs, New_Obj_Value (Var_File)); + New_Association + (Assocs, New_Unchecked_Address (New_Obj (Var_Length), + Ghdl_Ptr_Type)); + New_Association + (Assocs, + New_Lit (New_Sizeof (Ghdl_Index_Type, Ghdl_Index_Type))); + New_Procedure_Call (Assocs); + end Translate_Rw_Length; + + Var : Mnode; + begin + Etype := Get_Type (Get_File_Type_Mark (File_Type)); + Tinfo := Get_Info (Etype); + if Tinfo.Type_Mode in Type_Mode_Scalar then + -- Intrinsic. + return; + end if; + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := False; + + Id := Get_Identifier (Get_Type_Declarator (File_Type)); + Kind := Get_Implicit_Definition (Subprg); + case Kind is + when Iir_Predefined_Write => + Name := Create_Identifier (Id, "_WRITE"); + when Iir_Predefined_Read + | Iir_Predefined_Read_Length => + Name := Create_Identifier (Id, "_READ"); + when others => + raise Internal_Error; + end case; + + -- Create function. + if Kind = Iir_Predefined_Read_Length then + Start_Function_Decl + (Inter_List, Name, Global_Storage, Std_Integer_Otype); + else + Start_Procedure_Decl (Inter_List, Name, Global_Storage); + end if; + Chap2.Create_Subprg_Instance (Inter_List, Subprg); + + New_Interface_Decl + (Inter_List, Var_File, Get_Identifier ("FILE"), + Ghdl_File_Index_Type); + New_Interface_Decl + (Inter_List, Var_Val, Wki_Val, + Tinfo.Ortho_Ptr_Type (Mode_Value)); + Finish_Subprogram_Decl (Inter_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + Push_Local_Factory; + + Var := Dp2M (Var_Val, Tinfo, Mode_Value); + + case Kind is + when Iir_Predefined_Write => + if Tinfo.Type_Mode = Type_Mode_Fat_Array then + declare + Var_Max : O_Dnode; + begin + Open_Temp; + Var_Max := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Array_Length (Var, Etype)); + Translate_Rw_Length (Var_Max, Ghdl_Write_Scalar); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Max, Ghdl_Write_Scalar); + Close_Temp; + end; + else + Translate_Rw (Var, Etype, Ghdl_Write_Scalar); + end if; + when Iir_Predefined_Read => + Translate_Rw (Var, Etype, Ghdl_Read_Scalar); + + when Iir_Predefined_Read_Length => + declare + Var_Len : O_Dnode; + begin + Open_Temp; + Var_Len := Create_Temp (Ghdl_Index_Type); + Translate_Rw_Length (Var_Len, Ghdl_Read_Scalar); + + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Gt, + New_Obj_Value (Var_Len), + Chap3.Get_Array_Length (Var, Etype), + Ghdl_Bool_Type), + Subprg, 1); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Len, Ghdl_Read_Scalar); + New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_Len), + Std_Integer_Otype)); + Close_Temp; + end; + when others => + raise Internal_Error; + end case; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_File_Subprogram; + + procedure Init_Implicit_Subprogram_Infos + (Infos : out Implicit_Subprogram_Infos) is + begin + -- Be independant of declaration order since the same subprogram + -- may be used for several implicit operators (eg. array comparaison) + Infos.Arr_Eq_Info := null; + Infos.Arr_Cmp_Info := null; + Infos.Arr_Concat_Info := null; + Infos.Rec_Eq_Info := null; + Infos.Arr_Shl_Info := null; + Infos.Arr_Sha_Info := null; + Infos.Arr_Rot_Info := null; + end Init_Implicit_Subprogram_Infos; + + procedure Translate_Implicit_Subprogram + (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos) + is + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Subprg); + begin + if Predefined_To_Onop (Kind) /= ON_Nil then + -- Intrinsic. + return; + end if; + + case Kind is + when Iir_Predefined_Error => + raise Internal_Error; + when Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Xor + | Iir_Predefined_Boolean_Not + | Iir_Predefined_Enum_Equality + | Iir_Predefined_Enum_Inequality + | Iir_Predefined_Enum_Less + | Iir_Predefined_Enum_Less_Equal + | Iir_Predefined_Enum_Greater + | Iir_Predefined_Enum_Greater_Equal + | Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Xor + | Iir_Predefined_Bit_Not + | Iir_Predefined_Integer_Equality + | Iir_Predefined_Integer_Inequality + | Iir_Predefined_Integer_Less + | Iir_Predefined_Integer_Less_Equal + | Iir_Predefined_Integer_Greater + | Iir_Predefined_Integer_Greater_Equal + | Iir_Predefined_Integer_Negation + | Iir_Predefined_Integer_Absolute + | Iir_Predefined_Integer_Plus + | Iir_Predefined_Integer_Minus + | Iir_Predefined_Integer_Mul + | Iir_Predefined_Integer_Div + | Iir_Predefined_Integer_Mod + | Iir_Predefined_Integer_Rem + | Iir_Predefined_Floating_Equality + | Iir_Predefined_Floating_Inequality + | Iir_Predefined_Floating_Less + | Iir_Predefined_Floating_Less_Equal + | Iir_Predefined_Floating_Greater + | Iir_Predefined_Floating_Greater_Equal + | Iir_Predefined_Floating_Negation + | Iir_Predefined_Floating_Absolute + | Iir_Predefined_Floating_Plus + | Iir_Predefined_Floating_Minus + | Iir_Predefined_Floating_Mul + | Iir_Predefined_Floating_Div + | Iir_Predefined_Physical_Equality + | Iir_Predefined_Physical_Inequality + | Iir_Predefined_Physical_Less + | Iir_Predefined_Physical_Less_Equal + | Iir_Predefined_Physical_Greater + | Iir_Predefined_Physical_Greater_Equal + | Iir_Predefined_Physical_Negation + | Iir_Predefined_Physical_Absolute + | Iir_Predefined_Physical_Plus + | Iir_Predefined_Physical_Minus => + pragma Assert (Predefined_To_Onop (Kind) /= ON_Nil); + return; + + when Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor + | Iir_Predefined_Boolean_Xnor + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Bit_Xnor + | Iir_Predefined_Bit_Match_Equality + | Iir_Predefined_Bit_Match_Inequality + | Iir_Predefined_Bit_Match_Less + | Iir_Predefined_Bit_Match_Less_Equal + | Iir_Predefined_Bit_Match_Greater + | Iir_Predefined_Bit_Match_Greater_Equal + | Iir_Predefined_Bit_Condition + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Boolean_Falling_Edge + | Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge => + -- Intrinsic. + null; + + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Enum_Maximum + | Iir_Predefined_Enum_To_String => + -- Intrinsic. + null; + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Integer_Exp + | Iir_Predefined_Integer_Minimum + | Iir_Predefined_Integer_Maximum + | Iir_Predefined_Integer_To_String => + -- Intrinsic. + null; + when Iir_Predefined_Universal_R_I_Mul + | Iir_Predefined_Universal_I_R_Mul + | Iir_Predefined_Universal_R_I_Div => + -- Intrinsic + null; + + when Iir_Predefined_Physical_Identity + | Iir_Predefined_Physical_Minimum + | Iir_Predefined_Physical_Maximum + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + null; + + when Iir_Predefined_Physical_Integer_Mul + | Iir_Predefined_Physical_Integer_Div + | Iir_Predefined_Integer_Physical_Mul + | Iir_Predefined_Physical_Real_Mul + | Iir_Predefined_Physical_Real_Div + | Iir_Predefined_Real_Physical_Mul + | Iir_Predefined_Physical_Physical_Div => + null; + + when Iir_Predefined_Floating_Exp + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Floating_Minimum + | Iir_Predefined_Floating_Maximum + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format => + null; + + when Iir_Predefined_Record_Equality + | Iir_Predefined_Record_Inequality => + if Infos.Rec_Eq_Info = null then + Translate_Predefined_Record_Equality (Subprg); + Infos.Rec_Eq_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Rec_Eq_Info); + end if; + + when Iir_Predefined_Array_Equality + | Iir_Predefined_Array_Inequality + | Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => + if Infos.Arr_Eq_Info = null then + Translate_Predefined_Array_Equality (Subprg); + Infos.Arr_Eq_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Eq_Info); + end if; + + when Iir_Predefined_Array_Greater + | Iir_Predefined_Array_Greater_Equal + | Iir_Predefined_Array_Less + | Iir_Predefined_Array_Less_Equal + | Iir_Predefined_Array_Minimum + | Iir_Predefined_Array_Maximum => + if Infos.Arr_Cmp_Info = null then + Translate_Predefined_Array_Compare (Subprg); + Infos.Arr_Cmp_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Cmp_Info); + end if; + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + if Infos.Arr_Concat_Info = null then + Translate_Predefined_Array_Array_Concat (Subprg); + Infos.Arr_Concat_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Concat_Info); + end if; + + when Iir_Predefined_Vector_Minimum + | Iir_Predefined_Vector_Maximum => + null; + + when Iir_Predefined_TF_Array_And + | Iir_Predefined_TF_Array_Or + | Iir_Predefined_TF_Array_Nand + | Iir_Predefined_TF_Array_Nor + | Iir_Predefined_TF_Array_Xor + | Iir_Predefined_TF_Array_Xnor + | Iir_Predefined_TF_Array_Not => + Translate_Predefined_Array_Logical (Subprg); + + when Iir_Predefined_TF_Reduction_And + | Iir_Predefined_TF_Reduction_Or + | Iir_Predefined_TF_Reduction_Nand + | Iir_Predefined_TF_Reduction_Nor + | Iir_Predefined_TF_Reduction_Xor + | Iir_Predefined_TF_Reduction_Xnor + | Iir_Predefined_TF_Reduction_Not + | Iir_Predefined_TF_Array_Element_And + | Iir_Predefined_TF_Element_Array_And + | Iir_Predefined_TF_Array_Element_Or + | Iir_Predefined_TF_Element_Array_Or + | Iir_Predefined_TF_Array_Element_Nand + | Iir_Predefined_TF_Element_Array_Nand + | Iir_Predefined_TF_Array_Element_Nor + | Iir_Predefined_TF_Element_Array_Nor + | Iir_Predefined_TF_Array_Element_Xor + | Iir_Predefined_TF_Element_Array_Xor + | Iir_Predefined_TF_Array_Element_Xnor + | Iir_Predefined_TF_Element_Array_Xnor => + null; + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + if Infos.Arr_Shl_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Shl_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Shl_Info); + end if; + + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Infos.Arr_Sha_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Sha_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Sha_Info); + end if; + + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + if Infos.Arr_Rot_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Rot_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Rot_Info); + end if; + + when Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality => + -- Intrinsic. + null; + when Iir_Predefined_Deallocate => + -- Intrinsic. + null; + + when Iir_Predefined_File_Open + | Iir_Predefined_File_Open_Status + | Iir_Predefined_File_Close + | Iir_Predefined_Flush + | Iir_Predefined_Endfile => + -- All of them have predefined definitions. + null; + + when Iir_Predefined_Write + | Iir_Predefined_Read_Length + | Iir_Predefined_Read => + declare + Param : Iir; + File_Type : Iir; + begin + Param := Get_Interface_Declaration_Chain (Subprg); + File_Type := Get_Type (Param); + if not Get_Text_File_Flag (File_Type) then + Translate_File_Subprogram (Subprg, File_Type); + end if; + end; + + when Iir_Predefined_Attribute_Image + | Iir_Predefined_Attribute_Value + | Iir_Predefined_Attribute_Pos + | Iir_Predefined_Attribute_Val + | Iir_Predefined_Attribute_Succ + | Iir_Predefined_Attribute_Pred + | Iir_Predefined_Attribute_Leftof + | Iir_Predefined_Attribute_Rightof + | Iir_Predefined_Attribute_Left + | Iir_Predefined_Attribute_Right + | Iir_Predefined_Attribute_Event + | Iir_Predefined_Attribute_Active + | Iir_Predefined_Attribute_Last_Event + | Iir_Predefined_Attribute_Last_Active + | Iir_Predefined_Attribute_Last_Value + | Iir_Predefined_Attribute_Driving + | Iir_Predefined_Attribute_Driving_Value => + raise Internal_Error; + + when Iir_Predefined_Array_Char_To_String + | Iir_Predefined_Bit_Vector_To_Ostring + | Iir_Predefined_Bit_Vector_To_Hstring + | Iir_Predefined_Std_Ulogic_Match_Equality + | Iir_Predefined_Std_Ulogic_Match_Inequality + | Iir_Predefined_Std_Ulogic_Match_Less + | Iir_Predefined_Std_Ulogic_Match_Less_Equal + | Iir_Predefined_Std_Ulogic_Match_Greater + | Iir_Predefined_Std_Ulogic_Match_Greater_Equal + | Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + null; + + when Iir_Predefined_Now_Function => + null; + + -- when others => + -- Error_Kind ("translate_implicit_subprogram (" + -- & Iir_Predefined_Functions'Image (Kind) & ")", + -- Subprg); + end case; + end Translate_Implicit_Subprogram; + end Chap7; + + package body Chap8 is + procedure Translate_Return_Statement (Stmt : Iir_Return_Statement) + is + Subprg_Info : constant Ortho_Info_Acc := + Get_Info (Chap2.Current_Subprogram); + Expr : constant Iir := Get_Expression (Stmt); + Ret_Type : Iir; + Ret_Info : Type_Info_Acc; + + procedure Gen_Return is + begin + if Subprg_Info.Subprg_Exit /= O_Snode_Null then + New_Exit_Stmt (Subprg_Info.Subprg_Exit); + else + New_Return_Stmt; + end if; + end Gen_Return; + + procedure Gen_Return_Value (Val : O_Enode) is + begin + if Subprg_Info.Subprg_Exit /= O_Snode_Null then + New_Assign_Stmt (New_Obj (Subprg_Info.Subprg_Result), Val); + New_Exit_Stmt (Subprg_Info.Subprg_Exit); + else + New_Return_Stmt (Val); + end if; + end Gen_Return_Value; + begin + if Expr = Null_Iir then + -- Return in a procedure. + Gen_Return; + return; + end if; + + -- Return in a function. + Ret_Type := Get_Return_Type (Chap2.Current_Subprogram); + Ret_Info := Get_Info (Ret_Type); + case Ret_Info.Type_Mode is + when Type_Mode_Scalar => + -- * if the return type is scalar, simply returns. + declare + V : O_Dnode; + R : O_Enode; + begin + -- Always uses a temporary in case of the return expression + -- uses secondary stack. + -- FIXME: don't use the temp if not required. + R := Chap7.Translate_Expression (Expr, Ret_Type); + if Has_Stack2_Mark + or else Chap3.Need_Range_Check (Expr, Ret_Type) + then + V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (V), R); + Stack2_Release; + Chap3.Check_Range (V, Expr, Ret_Type, Expr); + Gen_Return_Value (New_Obj_Value (V)); + else + Gen_Return_Value (R); + end if; + end; + when Type_Mode_Acc => + -- * access: thin and no range. + declare + Res : O_Enode; + begin + Res := Chap7.Translate_Expression (Expr, Ret_Type); + Gen_Return_Value (Res); + end; + when Type_Mode_Fat_Array => + -- * if the return type is unconstrained: allocate an area from + -- the secondary stack, copy it to the area, and fill the fat + -- pointer. + -- Evaluate the result. + declare + Val : Mnode; + Area : Mnode; + begin + Area := Dp2M (Subprg_Info.Res_Interface, + Ret_Info, Mode_Value); + Val := Stabilize + (E2M (Chap7.Translate_Expression (Expr, Ret_Type), + Ret_Info, Mode_Value)); + Chap3.Translate_Object_Allocation + (Area, Alloc_Return, Ret_Type, + Chap3.Get_Array_Bounds (Val)); + Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type); + Gen_Return; + end; + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Fat_Acc => + -- * if the return type is a constrained composite type, copy + -- it to the result area. + -- Create a temporary area so that if the expression use + -- stack2, it will be freed before the return (otherwise, + -- the stack area will be lost). + declare + V : Mnode; + begin + Open_Temp; + V := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); + Chap3.Translate_Object_Copy + (V, Chap7.Translate_Expression (Expr, Ret_Type), Ret_Type); + Close_Temp; + Gen_Return; + end; + when Type_Mode_File => + -- FIXME: Is it possible ? + Error_Kind ("translate_return_statement", Ret_Type); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Return_Statement; + + procedure Translate_If_Statement (Stmt : Iir) + is + Blk : O_If_Block; + Else_Clause : Iir; + begin + Start_If_Stmt + (Blk, Chap7.Translate_Expression (Get_Condition (Stmt))); + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Else_Clause := Get_Else_Clause (Stmt); + if Else_Clause /= Null_Iir then + New_Else_Stmt (Blk); + if Get_Condition (Else_Clause) = Null_Iir then + Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Else_Clause)); + else + Open_Temp; + Translate_If_Statement (Else_Clause); + Close_Temp; + end if; + end if; + Finish_If_Stmt (Blk); + end Translate_If_Statement; + + function Get_Range_Ptr_Field_Value (O_Range : O_Lnode; Field : O_Fnode) + return O_Enode + is + begin + return New_Value (New_Selected_Element + (New_Access_Element (New_Value (O_Range)), Field)); + end Get_Range_Ptr_Field_Value; + + -- Inc or dec ITERATOR according to DIR. + procedure Gen_Update_Iterator (Iterator : O_Dnode; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir) + is + Op : ON_Op_Kind; + Base_Type : Iir; + V : O_Enode; + begin + case Dir is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + Base_Type := Get_Base_Type (Itype); + case Get_Kind (Base_Type) is + when Iir_Kind_Integer_Type_Definition => + V := New_Lit + (New_Signed_Literal + (Get_Ortho_Type (Base_Type, Mode_Value), Integer_64 (Val))); + when Iir_Kind_Enumeration_Type_Definition => + declare + List : Iir_List; + begin + List := Get_Enumeration_Literal_List (Base_Type); + -- FIXME: what about type E is ('T') ?? + if Natural (Val) > Get_Nbr_Elements (List) then + raise Internal_Error; + end if; + V := New_Lit + (Get_Ortho_Expr (Get_Nth_Element (List, Natural (Val)))); + end; + + when others => + Error_Kind ("gen_update_iterator", Base_Type); + end case; + New_Assign_Stmt (New_Obj (Iterator), + New_Dyadic_Op (Op, New_Obj_Value (Iterator), V)); + end Gen_Update_Iterator; + + type For_Loop_Data is record + Iterator : Iir_Iterator_Declaration; + Stmt : Iir_For_Loop_Statement; + -- If around the loop, to check if the loop must be executed. + If_Blk : O_If_Block; + Label_Next, Label_Exit : O_Snode; + -- Right bound of the iterator, used only if the iterator is a + -- range expression. + O_Right : O_Dnode; + -- Range variable of the iterator, used only if the iterator is not + -- a range expression. + O_Range : O_Dnode; + end record; + + procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration; + Stmt : Iir_For_Loop_Statement; + Data : out For_Loop_Data) + is + Iter_Type : Iir; + Iter_Base_Type : Iir; + Var_Iter : Var_Type; + Constraint : Iir; + Cond : O_Enode; + Dir : Iir_Direction; + Iter_Type_Info : Ortho_Info_Acc; + Op : ON_Op_Kind; + begin + -- Initialize DATA. + Data.Iterator := Iterator; + Data.Stmt := Stmt; + + Iter_Type := Get_Type (Iterator); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + Var_Iter := Get_Info (Iterator).Iterator_Var; + + Open_Temp; + + Constraint := Get_Range_Constraint (Iter_Type); + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + New_Assign_Stmt + (Get_Var (Var_Iter), Chap7.Translate_Range_Expression_Left + (Constraint, Iter_Base_Type)); + Dir := Get_Direction (Constraint); + Data.O_Right := Create_Temp + (Iter_Type_Info.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Obj (Data.O_Right), Chap7.Translate_Range_Expression_Right + (Constraint, Iter_Base_Type)); + case Dir is + when Iir_To => + Op := ON_Le; + when Iir_Downto => + Op := ON_Ge; + end case; + -- Check for at least one iteration. + Cond := New_Compare_Op + (Op, New_Value (Get_Var (Var_Iter)), + New_Obj_Value (Data.O_Right), + Ghdl_Bool_Type); + else + Data.O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type); + New_Assign_Stmt (New_Obj (Data.O_Range), + New_Address (Chap7.Translate_Range + (Constraint, Iter_Base_Type), + Iter_Type_Info.T.Range_Ptr_Type)); + New_Assign_Stmt + (Get_Var (Var_Iter), Get_Range_Ptr_Field_Value + (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Left)); + -- Before starting the loop, check wether there will be at least + -- one iteration. + Cond := New_Compare_Op + (ON_Gt, + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type); + end if; + + Start_If_Stmt (Data.If_Blk, Cond); + + -- Start loop. + -- There are two blocks: one for the exit, one for the next. + Start_Loop_Stmt (Data.Label_Exit); + Start_Loop_Stmt (Data.Label_Next); + + if Stmt /= Null_Iir then + declare + Loop_Info : Loop_Info_Acc; + begin + Loop_Info := Add_Info (Stmt, Kind_Loop); + Loop_Info.Label_Exit := Data.Label_Exit; + Loop_Info.Label_Next := Data.Label_Next; + end; + end if; + end Start_For_Loop; + + procedure Finish_For_Loop (Data : in out For_Loop_Data) + is + Cond : O_Enode; + If_Blk1 : O_If_Block; + Iter_Type : Iir; + Iter_Base_Type : Iir; + Iter_Type_Info : Type_Info_Acc; + Var_Iter : Var_Type; + Constraint : Iir; + Deep_Rng : Iir; + Deep_Reverse : Boolean; + begin + New_Exit_Stmt (Data.Label_Next); + Finish_Loop_Stmt (Data.Label_Next); + + -- Check end of loop. + -- Equality is necessary and enough. + Iter_Type := Get_Type (Data.Iterator); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + Var_Iter := Get_Info (Data.Iterator).Iterator_Var; + + Constraint := Get_Range_Constraint (Iter_Type); + + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + Cond := New_Obj_Value (Data.O_Right); + else + Cond := Get_Range_Ptr_Field_Value + (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Right); + end if; + Gen_Exit_When (Data.Label_Exit, + New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)), + Cond, Ghdl_Bool_Type)); + + -- Update the iterator. + Chap6.Get_Deep_Range_Expression (Iter_Type, Deep_Rng, Deep_Reverse); + if Deep_Rng /= Null_Iir then + if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + else + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + end if; + else + Start_If_Stmt + (If_Blk1, New_Compare_Op + (ON_Eq, + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + New_Else_Stmt (If_Blk1); + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + Finish_If_Stmt (If_Blk1); + end if; + + Finish_Loop_Stmt (Data.Label_Exit); + Finish_If_Stmt (Data.If_Blk); + Close_Temp; + + if Data.Stmt /= Null_Iir then + Free_Info (Data.Stmt); + end if; + end Finish_For_Loop; + + Current_Loop : Iir := Null_Iir; + + procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) + is + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Iter_Type : constant Iir := Get_Type (Iterator); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); + Data : For_Loop_Data; + It_Info : Ortho_Info_Acc; + Var_Iter : Var_Type; + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + Start_Declare_Stmt; + + Chap3.Translate_Object_Subtype (Iterator, False); + + -- Create info for the iterator. + It_Info := Add_Info (Iterator, Kind_Iterator); + Var_Iter := Create_Var + (Create_Var_Identifier (Iterator), + Iter_Type_Info.Ortho_Type (Mode_Value), + O_Storage_Local); + It_Info.Iterator_Var := Var_Iter; + + Start_For_Loop (Iterator, Stmt, Data); + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Finish_For_Loop (Data); + + Finish_Declare_Stmt; + + Free_Info (Iterator); + Current_Loop := Prev_Loop; + end Translate_For_Loop_Statement; + + procedure Translate_While_Loop_Statement + (Stmt : Iir_While_Loop_Statement) + is + Info : Loop_Info_Acc; + Cond : Iir; + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + + Info := Add_Info (Stmt, Kind_Loop); + + Start_Loop_Stmt (Info.Label_Exit); + Info.Label_Next := O_Snode_Null; + + Open_Temp; + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Gen_Exit_When + (Info.Label_Exit, + New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond))); + end if; + Close_Temp; + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Finish_Loop_Stmt (Info.Label_Exit); + Free_Info (Stmt); + Current_Loop := Prev_Loop; + end Translate_While_Loop_Statement; + + procedure Translate_Exit_Next_Statement (Stmt : Iir) + is + Cond : constant Iir := Get_Condition (Stmt); + If_Blk : O_If_Block; + Info : Loop_Info_Acc; + Loop_Label : Iir; + Loop_Stmt : Iir; + begin + if Cond /= Null_Iir then + Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); + end if; + + Loop_Label := Get_Loop_Label (Stmt); + if Loop_Label = Null_Iir then + Loop_Stmt := Current_Loop; + else + Loop_Stmt := Get_Named_Entity (Loop_Label); + end if; + + Info := Get_Info (Loop_Stmt); + case Get_Kind (Stmt) is + when Iir_Kind_Exit_Statement => + New_Exit_Stmt (Info.Label_Exit); + when Iir_Kind_Next_Statement => + if Info.Label_Next /= O_Snode_Null then + -- For-loop. + New_Exit_Stmt (Info.Label_Next); + else + -- While-loop. + New_Next_Stmt (Info.Label_Exit); + end if; + when others => + raise Internal_Error; + end case; + if Cond /= Null_Iir then + Finish_If_Stmt (If_Blk); + end if; + end Translate_Exit_Next_Statement; + + procedure Translate_Variable_Aggregate_Assignment + (Targ : Iir; Targ_Type : Iir; Val : Mnode); + + procedure Translate_Variable_Array_Aggr + (Targ : Iir_Aggregate; + Targ_Type : Iir; + Val : Mnode; + Index : in out Unsigned_64; + Dim : Natural) + is + El : Iir; + Final : Boolean; + El_Type : Iir; + begin + Final := Dim = Get_Nbr_Elements (Get_Index_Subtype_List (Targ_Type)); + if Final then + El_Type := Get_Element_Subtype (Targ_Type); + end if; + El := Get_Association_Choices_Chain (Targ); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + if Final then + Translate_Variable_Aggregate_Assignment + (Get_Associated_Expr (El), El_Type, + Chap3.Index_Base + (Val, Targ_Type, + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Index)))); + Index := Index + 1; + else + Translate_Variable_Array_Aggr + (Get_Associated_Expr (El), + Targ_Type, Val, Index, Dim + 1); + end if; + when others => + Error_Kind ("translate_variable_array_aggr", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Variable_Array_Aggr; + + procedure Translate_Variable_Rec_Aggr + (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode) + is + Aggr_El : Iir; + El_List : Iir_List; + El_Index : Natural; + Elem : Iir; + begin + El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); + El_Index := 0; + Aggr_El := Get_Association_Choices_Chain (Targ); + while Aggr_El /= Null_Iir loop + case Get_Kind (Aggr_El) is + when Iir_Kind_Choice_By_None => + Elem := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Elem := Get_Choice_Name (Aggr_El); + when others => + Error_Kind ("translate_variable_rec_aggr", Aggr_El); + end case; + Translate_Variable_Aggregate_Assignment + (Get_Associated_Expr (Aggr_El), Get_Type (Elem), + Chap6.Translate_Selected_Element (Val, Elem)); + Aggr_El := Get_Chain (Aggr_El); + end loop; + end Translate_Variable_Rec_Aggr; + + procedure Translate_Variable_Aggregate_Assignment + (Targ : Iir; Targ_Type : Iir; Val : Mnode) + is + Index : Unsigned_64; + begin + if Get_Kind (Targ) = Iir_Kind_Aggregate then + case Get_Kind (Targ_Type) is + when Iir_Kinds_Array_Type_Definition => + Index := 0; + Translate_Variable_Array_Aggr + (Targ, Targ_Type, Val, Index, 1); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Variable_Rec_Aggr (Targ, Targ_Type, Val); + when others => + Error_Kind + ("translate_variable_aggregate_assignment", Targ_Type); + end case; + else + declare + Targ_Node : Mnode; + begin + Targ_Node := Chap6.Translate_Name (Targ); + Chap3.Translate_Object_Copy (Targ_Node, M2E (Val), Targ_Type); + end; + end if; + end Translate_Variable_Aggregate_Assignment; + + procedure Translate_Variable_Assignment_Statement + (Stmt : Iir_Variable_Assignment_Statement) + is + Target : constant Iir := Get_Target (Stmt); + Targ_Type : constant Iir := Get_Type (Target); + Expr : constant Iir := Get_Expression (Stmt); + Targ_Node : Mnode; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + declare + E : O_Enode; + Temp : Mnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Targ_Type, True); + + -- Use a temporary variable, to avoid overlap. + Temp := Create_Temp (Get_Info (Targ_Type)); + Chap4.Allocate_Complex_Object (Targ_Type, Alloc_Stack, Temp); + + E := Chap7.Translate_Expression (Expr, Targ_Type); + Chap3.Translate_Object_Copy (Temp, E, Targ_Type); + Translate_Variable_Aggregate_Assignment + (Target, Targ_Type, Temp); + return; + end; + else + Targ_Node := Chap6.Translate_Name (Target); + if Get_Kind (Expr) = Iir_Kind_Aggregate then + declare + E : O_Enode; + begin + E := Chap7.Translate_Expression (Expr, Targ_Type); + Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type); + end; + else + Chap7.Translate_Assign (Targ_Node, Expr, Targ_Type); + end if; + end if; + end Translate_Variable_Assignment_Statement; + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir) + is + Expr : Iir; + Msg : O_Enode; + Severity : O_Enode; + Assocs : O_Assoc_List; + Loc : O_Dnode; + begin + Loc := Chap4.Get_Location (Stmt); + Expr := Get_Report_Expression (Stmt); + if Expr = Null_Iir then + Msg := New_Lit (New_Null_Access (Std_String_Ptr_Node)); + else + Msg := Chap7.Translate_Expression (Expr, String_Type_Definition); + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr = Null_Iir then + Severity := New_Lit (Get_Ortho_Expr (Level)); + else + Severity := Chap7.Translate_Expression (Expr); + end if; + -- Do call. + Start_Association (Assocs, Subprg); + New_Association (Assocs, Msg); + New_Association (Assocs, Severity); + New_Association (Assocs, New_Address (New_Obj (Loc), + Ghdl_Location_Ptr_Node)); + New_Procedure_Call (Assocs); + end Translate_Report; + + -- Return True if the current library unit is part of library IEEE. + function Is_Within_Ieee_Library return Boolean + is + Design_File : Iir; + Library : Iir; + begin + -- Guard. + if Current_Library_Unit = Null_Iir then + return False; + end if; + Design_File := + Get_Design_File (Get_Design_Unit (Current_Library_Unit)); + Library := Get_Library (Design_File); + return Get_Identifier (Library) = Std_Names.Name_Ieee; + end Is_Within_Ieee_Library; + + procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) + is + Expr : Iir; + If_Blk : O_If_Block; + Subprg : O_Dnode; + begin + -- Select the procedure to call in case of assertion (so that + -- assertions within the IEEE library could be ignored). + if Is_Within_Ieee_Library then + Subprg := Ghdl_Ieee_Assert_Failed; + else + Subprg := Ghdl_Assert_Failed; + end if; + + Expr := Get_Assertion_Condition (Stmt); + if Get_Expr_Staticness (Expr) = Locally then + if Eval_Pos (Expr) = 1 then + -- Assert TRUE is a noop. + -- FIXME: generate a noop ? + return; + end if; + Translate_Report (Stmt, Subprg, Severity_Level_Error); + else + -- An assertion is reported if the condition is false! + Start_If_Stmt (If_Blk, + New_Monadic_Op (ON_Not, + Chap7.Translate_Expression (Expr))); + -- Note: it is necessary to create a declare block, to avoid bad + -- order with the if block. + Open_Temp; + Translate_Report (Stmt, Subprg, Severity_Level_Error); + Close_Temp; + Finish_If_Stmt (If_Blk); + end if; + end Translate_Assertion_Statement; + + procedure Translate_Report_Statement (Stmt : Iir_Report_Statement) is + begin + Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note); + end Translate_Report_Statement; + + -- Helper to compare a string choice with the selector. + function Translate_Simple_String_Choice + (Expr : O_Dnode; + Val : O_Enode; + Val_Node : O_Dnode; + Tinfo : Type_Info_Acc; + Func : Iir) + return O_Enode + is + Assoc : O_Assoc_List; + Func_Info : Subprg_Info_Acc; + begin + New_Assign_Stmt + (New_Selected_Element (New_Obj (Val_Node), + Tinfo.T.Base_Field (Mode_Value)), + Val); + Func_Info := Get_Info (Func); + Start_Association (Assoc, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); + New_Association (Assoc, New_Obj_Value (Expr)); + New_Association + (Assoc, New_Address (New_Obj (Val_Node), + Tinfo.Ortho_Ptr_Type (Mode_Value))); + return New_Function_Call (Assoc); + end Translate_Simple_String_Choice; + + -- Helper to evaluate the selector and preparing a choice variable. + procedure Translate_String_Case_Statement_Common + (Stmt : Iir_Case_Statement; + Expr_Type : out Iir; + Tinfo : out Type_Info_Acc; + Expr_Node : out O_Dnode; + C_Node : out O_Dnode) + is + Expr : Iir; + Base_Type : Iir; + begin + -- Translate into if/elsif statements. + -- FIXME: if the number of literals ** length of the array < 256, + -- use a case statement. + Expr := Get_Expression (Stmt); + Expr_Type := Get_Type (Expr); + Base_Type := Get_Base_Type (Expr_Type); + Tinfo := Get_Info (Base_Type); + + -- Translate selector. + Expr_Node := Create_Temp_Init + (Tinfo.Ortho_Ptr_Type (Mode_Value), + Chap7.Translate_Expression (Expr, Base_Type)); + + -- Copy the bounds for the choices. + C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (C_Node), + Tinfo.T.Bounds_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); + end Translate_String_Case_Statement_Common; + + -- Translate a string case statement using a dichotomy. + procedure Translate_String_Case_Statement_Dichotomy + (Stmt : Iir_Case_Statement) + is + -- Selector. + Expr_Type : Iir; + Tinfo : Type_Info_Acc; + Expr_Node : O_Dnode; + C_Node : O_Dnode; + + Choices_Chain : Iir; + Choice : Iir; + Has_Others : Boolean; + Func : Iir; + + -- Number of non-others choices. + Nbr_Choices : Natural; + -- Number of associations. + Nbr_Assocs : Natural; + + Info : Ortho_Info_Acc; + First, Last : Ortho_Info_Acc; + Sel_Length : Iir_Int64; + + -- Dichotomy table (table of choices). + String_Type : O_Tnode; + Table_Base_Type : O_Tnode; + Table_Type : O_Tnode; + Table : O_Dnode; + List : O_Array_Aggr_List; + Table_Cst : O_Cnode; + + -- Association table. + -- Indexed by the choice, returns an index to the associated + -- statement list. + -- Could be replaced by jump table. + Assoc_Table_Base_Type : O_Tnode; + Assoc_Table_Type : O_Tnode; + Assoc_Table : O_Dnode; + begin + Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); + + -- Count number of choices and number of associations. + Nbr_Choices := 0; + Nbr_Assocs := 0; + Choice := Choices_Chain; + First := null; + Last := null; + Has_Others := False; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + Has_Others := True; + exit; + when Iir_Kind_Choice_By_Expression => + null; + when others => + raise Internal_Error; + end case; + if not Get_Same_Alternative_Flag (Choice) then + Nbr_Assocs := Nbr_Assocs + 1; + end if; + Info := Add_Info (Choice, Kind_Str_Choice); + if First = null then + First := Info; + else + Last.Choice_Chain := Info; + end if; + Last := Info; + Info.Choice_Chain := null; + Info.Choice_Assoc := Nbr_Assocs - 1; + Info.Choice_Parent := Choice; + Info.Choice_Expr := Get_Choice_Expression (Choice); + + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); + end loop; + + -- Sort choices. + declare + procedure Merge_Sort (Head : Ortho_Info_Acc; + Nbr : Natural; + Res : out Ortho_Info_Acc; + Next : out Ortho_Info_Acc) + is + L, R, L_End, R_End : Ortho_Info_Acc; + E, Last : Ortho_Info_Acc; + Half : constant Natural := Nbr / 2; + begin + -- Sorting less than 2 elements is easy! + if Nbr < 2 then + Res := Head; + if Nbr = 0 then + Next := Head; + else + Next := Head.Choice_Chain; + end if; + return; + end if; + + Merge_Sort (Head, Half, L, L_End); + Merge_Sort (L_End, Nbr - Half, R, R_End); + Next := R_End; + + -- Merge + Last := null; + loop + if L /= L_End + and then + (R = R_End + or else + Compare_String_Literals (L.Choice_Expr, R.Choice_Expr) + = Compare_Lt) + then + E := L; + L := L.Choice_Chain; + elsif R /= R_End then + E := R; + R := R.Choice_Chain; + else + exit; + end if; + if Last = null then + Res := E; + else + Last.Choice_Chain := E; + end if; + Last := E; + end loop; + Last.Choice_Chain := R_End; + end Merge_Sort; + Next : Ortho_Info_Acc; + begin + Merge_Sort (First, Nbr_Choices, First, Next); + if Next /= null then + raise Internal_Error; + end if; + end; + + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node); + + -- Generate choices table. + Sel_Length := Eval_Discrete_Type_Length + (Get_String_Type_Bound_Type (Expr_Type)); + String_Type := New_Constrained_Array_Type + (Tinfo.T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length))); + Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type); + Table_Type := New_Constrained_Array_Type + (Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Table_Type); + New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private, + Table_Type); + Start_Const_Value (Table); + Start_Array_Aggr (List, Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El (List, Chap7.Translate_Static_Expression + (Info.Choice_Expr, Expr_Type)); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Table, Table_Cst); + + -- Generate assoc table. + Assoc_Table_Base_Type := + New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type); + Assoc_Table_Type := New_Constrained_Array_Type + (Assoc_Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type); + New_Const_Decl (Assoc_Table, Create_Uniq_Identifier, + O_Storage_Private, Assoc_Table_Type); + Start_Const_Value (Assoc_Table); + Start_Array_Aggr (List, Assoc_Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Choice_Assoc))); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Assoc_Table, Table_Cst); + + -- Generate dichotomy code. + declare + Var_Lo, Var_Hi, Var_Mid : O_Dnode; + Var_Cmp : O_Dnode; + Var_Idx : O_Dnode; + Label : O_Snode; + Others_Lit : O_Cnode; + If_Blk1, If_Blk2 : O_If_Block; + Case_Blk : O_Case_Block; + begin + Var_Idx := Create_Temp (Ghdl_Index_Type); + + Start_Declare_Stmt; + + New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Cmp, Wki_Cmp, + O_Storage_Local, Ghdl_Compare_Type); + + New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0)); + New_Assign_Stmt + (New_Obj (Var_Hi), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Choices)))); + + Func := Chap7.Find_Predefined_Function + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater); + + if Has_Others then + Others_Lit := New_Unsigned_Literal + (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs)); + end if; + + Start_Loop_Stmt (Label); + New_Assign_Stmt + (New_Obj (Var_Mid), + New_Dyadic_Op (ON_Div_Ov, + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Lo), + New_Obj_Value (Var_Hi)), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, 2)))); + New_Assign_Stmt + (New_Obj (Var_Cmp), + Translate_Simple_String_Choice + (Expr_Node, + New_Address (New_Indexed_Element (New_Obj (Table), + New_Obj_Value (Var_Mid)), + Tinfo.T.Base_Ptr_Type (Mode_Value)), + C_Node, Tinfo, Func)); + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Eq), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Var_Idx), + New_Value (New_Indexed_Element (New_Obj (Assoc_Table), + New_Obj_Value (Var_Mid)))); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Lt), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Le, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Lo), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Hi), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + New_Else_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Hi), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Lo), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + Finish_If_Stmt (If_Blk1); + + Finish_Loop_Stmt (Label); + + Finish_Declare_Stmt; + + Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx)); + + Choice := Choices_Chain; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + Start_Choice (Case_Blk); + New_Expr_Choice (Case_Blk, Others_Lit); + Finish_Choice (Case_Blk); + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); + when Iir_Kind_Choice_By_Expression => + if not Get_Same_Alternative_Flag (Choice) then + Start_Choice (Case_Blk); + New_Expr_Choice + (Case_Blk, + New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Get_Info (Choice).Choice_Assoc))); + Finish_Choice (Case_Blk); + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); + end if; + Free_Info (Choice); + when others => + raise Internal_Error; + end case; + Choice := Get_Chain (Choice); + end loop; + + Start_Choice (Case_Blk); + New_Default_Choice (Case_Blk); + Finish_Choice (Case_Blk); + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + + Finish_Case_Stmt (Case_Blk); + end; + end Translate_String_Case_Statement_Dichotomy; + + -- Case statement whose expression is an unidim array. + -- Translate into if/elsif statements (linear search). + procedure Translate_String_Case_Statement_Linear + (Stmt : Iir_Case_Statement) + is + Expr_Type : Iir; + -- Node containing the address of the selector. + Expr_Node : O_Dnode; + -- Node containing the current choice. + Val_Node : O_Dnode; + Tinfo : Type_Info_Acc; + + Cond_Var : O_Dnode; + + Func : Iir; + + procedure Translate_String_Choice (Choice : Iir) + is + Cond : O_Enode; + If_Blk : O_If_Block; + Stmt_Chain : Iir; + First : Boolean; + Ch : Iir; + Ch_Expr : Iir; + begin + if Choice = Null_Iir then + return; + end if; + + First := True; + Stmt_Chain := Get_Associated_Chain (Choice); + Ch := Choice; + loop + case Get_Kind (Ch) is + when Iir_Kind_Choice_By_Expression => + Ch_Expr := Get_Choice_Expression (Ch); + Cond := Translate_Simple_String_Choice + (Expr_Node, + Chap7.Translate_Expression (Ch_Expr, + Get_Type (Ch_Expr)), + Val_Node, Tinfo, Func); + when Iir_Kind_Choice_By_Others => + Translate_Statements_Chain (Stmt_Chain); + return; + when others => + Error_Kind ("translate_string_choice", Ch); + end case; + if not First then + New_Assign_Stmt + (New_Obj (Cond_Var), + New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); + end if; + Ch := Get_Chain (Ch); + exit when Ch = Null_Iir; + exit when not Get_Same_Alternative_Flag (Ch); + exit when Get_Associated_Chain (Ch) /= Null_Iir; + if First then + New_Assign_Stmt (New_Obj (Cond_Var), Cond); + First := False; + end if; + end loop; + if not First then + Cond := New_Obj_Value (Cond_Var); + end if; + Start_If_Stmt (If_Blk, Cond); + Translate_Statements_Chain (Stmt_Chain); + New_Else_Stmt (If_Blk); + Translate_String_Choice (Ch); + Finish_If_Stmt (If_Blk); + end Translate_String_Choice; + begin + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node); + + Func := Chap7.Find_Predefined_Function + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); + + Cond_Var := Create_Temp (Std_Boolean_Type_Node); + + Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt)); + end Translate_String_Case_Statement_Linear; + + procedure Translate_Case_Choice + (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block) + is + Expr : Iir; + begin + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + New_Default_Choice (Blk); + when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); + New_Expr_Choice + (Blk, Chap7.Translate_Static_Expression (Expr, Choice_Type)); + when Iir_Kind_Choice_By_Range => + declare + H, L : Iir; + begin + Expr := Get_Choice_Range (Choice); + Get_Low_High_Limit (Expr, L, H); + New_Range_Choice + (Blk, + Chap7.Translate_Static_Expression (L, Choice_Type), + Chap7.Translate_Static_Expression (H, Choice_Type)); + end; + when others => + Error_Kind ("translate_case_choice", Choice); + end case; + end Translate_Case_Choice; + + procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) + is + Expr : Iir; + Expr_Type : Iir; + Case_Blk : O_Case_Block; + Choice : Iir; + Stmt_Chain : Iir; + begin + Expr := Get_Expression (Stmt); + Expr_Type := Get_Type (Expr); + if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then + declare + Nbr_Choices : Natural := 0; + Choice : Iir; + begin + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + exit; + when Iir_Kind_Choice_By_Expression => + null; + when others => + raise Internal_Error; + end case; + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); + end loop; + + if Nbr_Choices < 3 then + Translate_String_Case_Statement_Linear (Stmt); + else + Translate_String_Case_Statement_Dichotomy (Stmt); + end if; + end; + return; + end if; + Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + Start_Choice (Case_Blk); + Stmt_Chain := Get_Associated_Chain (Choice); + loop + Translate_Case_Choice (Choice, Expr_Type, Case_Blk); + Choice := Get_Chain (Choice); + exit when Choice = Null_Iir; + exit when not Get_Same_Alternative_Flag (Choice); + pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); + end loop; + Finish_Choice (Case_Blk); + Translate_Statements_Chain (Stmt_Chain); + end loop; + Finish_Case_Stmt (Case_Blk); + end Translate_Case_Statement; + + procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) + is + F_Assoc : Iir; + Value_Assoc : Iir; + Value : O_Dnode; + Formal_Type : Iir; + Tinfo : Type_Info_Acc; + Assocs : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + begin + F_Assoc := Param_Chain; + Value_Assoc := Get_Chain (Param_Chain); + Formal_Type := Get_Type (Get_Formal (Value_Assoc)); + Tinfo := Get_Info (Formal_Type); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + Open_Temp; + Start_Association (Assocs, Ghdl_Write_Scalar); + -- compute file parameter (get an index) + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + -- compute the value. + Value := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Obj (Value), + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + New_Association + (Assocs, + New_Unchecked_Address (New_Obj (Value), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + Close_Temp; + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Fat_Array => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + New_Procedure_Call (Assocs); + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Write_Procedure_Call; + + procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) + is + F_Assoc : Iir; + Value_Assoc : Iir; + Value : Mnode; + Formal_Type : Iir; + Tinfo : Type_Info_Acc; + Assocs : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + begin + F_Assoc := Param_Chain; + Value_Assoc := Get_Chain (Param_Chain); + Formal_Type := Get_Type (Get_Formal (Value_Assoc)); + Tinfo := Get_Info (Formal_Type); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + Open_Temp; + Start_Association (Assocs, Ghdl_Read_Scalar); + -- compute file parameter (get an index) + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + -- value + Value := Chap6.Translate_Name (Get_Actual (Value_Assoc)); + New_Association + (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + Close_Temp; + when Type_Mode_Array + | Type_Mode_Record => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc))); + New_Procedure_Call (Assocs); + when Type_Mode_Fat_Array => + declare + Length_Assoc : Iir; + Length : Mnode; + begin + Length_Assoc := Get_Chain (Value_Assoc); + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + Length := Chap6.Translate_Name (Get_Actual (Length_Assoc)); + New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs)); + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Read_Procedure_Call; + + procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) + is + Imp : constant Iir := Get_Implementation (Call); + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call); + begin + case Kind is + when Iir_Predefined_Write => + -- Check wether text or not. + declare + File_Param : Iir; + Assocs : O_Assoc_List; + begin + File_Param := Param_Chain; + -- FIXME: do the test. + if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) + then + -- If text: + Start_Association (Assocs, Ghdl_Text_Write); + -- compute file parameter (get an index) + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (File_Param))); + -- compute string parameter (get a fat array pointer) + New_Association + (Assocs, Chap7.Translate_Expression + (Get_Actual (Get_Chain (Param_Chain)), + String_Type_Definition)); + -- call a predefined procedure + New_Procedure_Call (Assocs); + else + Translate_Write_Procedure_Call (Imp, Param_Chain); + end if; + end; + + when Iir_Predefined_Read_Length => + -- FIXME: works only for text read length. + declare + File_Param : Iir; + N_Param : Iir; + Assocs : O_Assoc_List; + Str : O_Enode; + Res : Mnode; + begin + File_Param := Param_Chain; + if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) + then + N_Param := Get_Chain (File_Param); + Str := Chap7.Translate_Expression + (Get_Actual (N_Param), String_Type_Definition); + N_Param := Get_Chain (N_Param); + Res := Chap6.Translate_Name (Get_Actual (N_Param)); + Start_Association (Assocs, Ghdl_Text_Read_Length); + -- compute file parameter (get an index) + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (File_Param))); + -- compute string parameter (get a fat array pointer) + New_Association (Assocs, Str); + -- call a predefined procedure + New_Assign_Stmt + (M2Lv (Res), New_Function_Call (Assocs)); + else + Translate_Read_Procedure_Call (Imp, Param_Chain); + end if; + end; + + when Iir_Predefined_Read => + Translate_Read_Procedure_Call (Imp, Param_Chain); + + when Iir_Predefined_Deallocate => + Chap3.Translate_Object_Deallocation (Get_Actual (Param_Chain)); + + when Iir_Predefined_File_Open => + declare + N_Param : Iir; + File_Param : Iir; + Name_Param : Iir; + Kind_Param : Iir; + Constr : O_Assoc_List; + begin + File_Param := Get_Actual (Param_Chain); + N_Param := Get_Chain (Param_Chain); + Name_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Kind_Param := Get_Actual (N_Param); + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Open); + else + Start_Association (Constr, Ghdl_File_Open); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Association + (Constr, New_Convert_Ov + (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); + New_Association + (Constr, + Chap7.Translate_Expression (Name_Param, + String_Type_Definition)); + New_Procedure_Call (Constr); + end; + + when Iir_Predefined_File_Open_Status => + declare + Std_File_Open_Status_Otype : constant O_Tnode := + Get_Ortho_Type (File_Open_Status_Type_Definition, + Mode_Value); + N_Param : Iir; + Status_Param : constant Iir := Get_Actual (Param_Chain); + File_Param : Iir; + Name_Param : Iir; + Kind_Param : Iir; + Constr : O_Assoc_List; + Status : Mnode; + begin + Status := Chap6.Translate_Name (Status_Param); + N_Param := Get_Chain (Param_Chain); + File_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Name_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Kind_Param := Get_Actual (N_Param); + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Open_Status); + else + Start_Association (Constr, Ghdl_File_Open_Status); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Association + (Constr, New_Convert_Ov + (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); + New_Association + (Constr, + Chap7.Translate_Expression (Name_Param, + String_Type_Definition)); + New_Assign_Stmt + (M2Lv (Status), + New_Convert_Ov (New_Function_Call (Constr), + Std_File_Open_Status_Otype)); + end; + + when Iir_Predefined_File_Close => + declare + File_Param : constant Iir := Get_Actual (Param_Chain); + Constr : O_Assoc_List; + begin + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Close); + else + Start_Association (Constr, Ghdl_File_Close); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Procedure_Call (Constr); + end; + + when Iir_Predefined_Flush => + declare + File_Param : constant Iir := Get_Actual (Param_Chain); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_File_Flush); + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Procedure_Call (Constr); + end; + + when others => + Ada.Text_IO.Put_Line + ("translate_implicit_procedure_call: cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + end case; + end Translate_Implicit_Procedure_Call; + + function Do_Conversion (Conv : Iir; Expr : Iir; Src : Mnode) + return O_Enode + is + Constr : O_Assoc_List; + Conv_Info : Subprg_Info_Acc; + Res : O_Dnode; + Imp : Iir; + begin + if Conv = Null_Iir then + return M2E (Src); +-- case Get_Type_Info (Dest).Type_Mode is +-- when Type_Mode_Thin => +-- New_Assign_Stmt (M2Lv (Dest), M2E (Src)); +-- when Type_Mode_Fat_Acc => +-- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src)); +-- when others => +-- raise Internal_Error; +-- end case; + else + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + -- Call conversion function. + Imp := Get_Implementation (Conv); + Conv_Info := Get_Info (Imp); + Start_Association (Constr, Conv_Info.Ortho_Func); + + if Conv_Info.Res_Interface /= O_Dnode_Null then + Res := Create_Temp (Conv_Info.Res_Record_Type); + -- Composite result. + New_Association + (Constr, + New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Conv_Info.Subprg_Instance); + + New_Association (Constr, M2E (Src)); + + if Conv_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), + Conv_Info.Res_Record_Ptr); + else + return New_Function_Call (Constr); + end if; + when Iir_Kind_Type_Conversion => + return Chap7.Translate_Type_Conversion + (M2E (Src), Get_Type (Expr), + Get_Type (Conv), Null_Iir); + when others => + Error_Kind ("do_conversion", Conv); + end case; + end if; + end Do_Conversion; + + procedure Translate_Procedure_Call (Stmt : Iir_Procedure_Call) + is + type Mnode_Array is array (Natural range <>) of Mnode; + type O_Enode_Array is array (Natural range <>) of O_Enode; + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Nbr_Assoc : constant Natural := + Iir_Chains.Get_Chain_Length (Assoc_Chain); + Params : Mnode_Array (0 .. Nbr_Assoc - 1); + E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); + Imp : constant Iir := Get_Implementation (Stmt); + Info : constant Subprg_Info_Acc := Get_Info (Imp); + Res : O_Dnode; + El : Iir; + Pos : Natural; + Constr : O_Assoc_List; + Act : Iir; + Actual_Type : Iir; + Formal : Iir; + Base_Formal : Iir; + Formal_Type : Iir; + Ftype_Info : Type_Info_Acc; + Formal_Info : Ortho_Info_Acc; + Val : O_Enode; + Param : Mnode; + Last_Individual : Natural; + Ptr : O_Lnode; + In_Conv : Iir; + In_Expr : Iir; + Out_Conv : Iir; + Out_Expr : Iir; + Formal_Object_Kind : Object_Kind_Type; + Bounds : Mnode; + Obj : Iir; + begin + -- Create an in-out result record for in-out arguments passed by + -- value. + if Info.Res_Record_Type /= O_Tnode_Null then + Res := Create_Temp (Info.Res_Record_Type); + else + Res := O_Dnode_Null; + end if; + + -- Evaluate in-out parameters and parameters passed by ref, since + -- they can add declarations. + -- Non-composite in-out parameters address are saved in order to + -- be able to assignate the result. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Params (Pos) := Mnode_Null; + E_Params (Pos) := O_Enode_Null; + + Formal := Get_Formal (El); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + Base_Formal := Get_Association_Interface (El); + Formal_Type := Get_Type (Formal); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration + then + Formal_Object_Kind := Mode_Signal; + else + Formal_Object_Kind := Mode_Value; + end if; + Ftype_Info := Get_Info (Formal_Type); + + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Act := Get_Default_Value (Formal); + In_Conv := Null_Iir; + Out_Conv := Null_Iir; + when Iir_Kind_Association_Element_By_Expression => + Act := Get_Actual (El); + In_Conv := Get_In_Conversion (El); + Out_Conv := Get_Out_Conversion (El); + when Iir_Kind_Association_Element_By_Individual => + Actual_Type := Get_Actual_Type (El); + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- A non-composite type cannot be associated by element. + raise Internal_Error; + end if; + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + Chap3.Create_Array_Subtype (Actual_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Param := Create_Temp (Ftype_Info, Formal_Object_Kind); + Chap3.Translate_Object_Allocation + (Param, Alloc_Stack, Formal_Type, Bounds); + else + Param := Create_Temp (Ftype_Info, Formal_Object_Kind); + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc_Stack, Param); + end if; + Last_Individual := Pos; + Params (Pos) := Param; + goto Continue; + when others => + Error_Kind ("translate_procedure_call", El); + end case; + Actual_Type := Get_Type (Act); + + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- Copy-out argument. + -- This is not a composite type. + Param := Chap6.Translate_Name (Act); + if Get_Object_Kind (Param) /= Mode_Value then + raise Internal_Error; + end if; + Params (Pos) := Stabilize (Param); + if In_Conv /= Null_Iir + or else Get_Mode (Formal) = Iir_Inout_Mode + then + -- Arguments may be assigned if there is an in conversion. + Ptr := New_Selected_Element + (New_Obj (Res), Formal_Info.Interface_Field); + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + if In_Conv /= Null_Iir then + In_Expr := In_Conv; + else + In_Expr := Act; + end if; + Chap7.Translate_Assign + (Param, + Do_Conversion (In_Conv, Act, Params (Pos)), + In_Expr, + Formal_Type, El); + end if; + elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then + -- Passed by reference. + case Get_Kind (Base_Formal) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + -- No conversion here. + E_Params (Pos) := Chap7.Translate_Expression + (Act, Formal_Type); + when Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Param := Chap6.Translate_Name (Act); + -- Atype may not have been set (eg: slice). + if Base_Formal /= Formal then + Stabilize (Param); + Params (Pos) := Param; + end if; + E_Params (Pos) := M2E (Param); + if Formal_Type /= Actual_Type then + -- Implicit array conversion or subtype check. + E_Params (Pos) := Chap7.Translate_Implicit_Conv + (E_Params (Pos), Actual_Type, Formal_Type, + Get_Object_Kind (Param), Stmt); + end if; + when others => + Error_Kind ("translate_procedure_call(2)", Formal); + end case; + end if; + if Base_Formal /= Formal then + -- Individual association. + if Ftype_Info.Type_Mode not in Type_Mode_By_Value then + -- Not by-value actual already translated. + Val := E_Params (Pos); + else + -- By value association. + Act := Get_Actual (El); + if Get_Kind (Base_Formal) + = Iir_Kind_Interface_Constant_Declaration + then + Val := Chap7.Translate_Expression (Act, Formal_Type); + else + Params (Pos) := Chap6.Translate_Name (Act); + -- Since signals are passed by reference, they are not + -- copied back, so do not stabilize them (furthermore, + -- it is not possible to stabilize them). + if Formal_Object_Kind = Mode_Value then + Params (Pos) := Stabilize (Params (Pos)); + end if; + Val := M2E (Params (Pos)); + end if; + end if; + -- Assign formal. + -- Change the formal variable so that it is the local variable + -- that will be passed to the subprogram. + declare + Prev_Node : O_Dnode; + begin + Prev_Node := Formal_Info.Interface_Node; + -- We need a pointer since the interface is by reference. + Formal_Info.Interface_Node := + M2Dp (Params (Last_Individual)); + Param := Chap6.Translate_Name (Formal); + Formal_Info.Interface_Node := Prev_Node; + end; + Chap7.Translate_Assign (Param, Val, Act, Formal_Type, El); + end if; + << Continue >> null; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + + -- Second stage: really perform the call. + Start_Association (Constr, Info.Ortho_Func); + if Res /= O_Dnode_Null then + New_Association (Constr, + New_Address (New_Obj (Res), Info.Res_Record_Ptr)); + end if; + + Obj := Get_Method_Object (Stmt); + if Obj /= Null_Iir then + New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + -- Parameters. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Formal := Get_Formal (El); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + Base_Formal := Get_Association_Interface (El); + Formal_Info := Get_Info (Base_Formal); + Formal_Type := Get_Type (Formal); + Ftype_Info := Get_Info (Formal_Type); + + if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then + Last_Individual := Pos; + New_Association (Constr, M2E (Params (Pos))); + elsif Base_Formal /= Formal then + -- Individual association. + null; + elsif Formal_Info.Interface_Field = O_Fnode_Null then + if Ftype_Info.Type_Mode in Type_Mode_By_Value then + -- Parameter passed by value. + if E_Params (Pos) /= O_Enode_Null then + Val := E_Params (Pos); + raise Internal_Error; + else + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Act := Get_Default_Value (Formal); + In_Conv := Null_Iir; + when Iir_Kind_Association_Element_By_Expression => + Act := Get_Actual (El); + In_Conv := Get_In_Conversion (El); + when others => + Error_Kind ("translate_procedure_call(2)", El); + end case; + case Get_Kind (Formal) is + when Iir_Kind_Interface_Signal_Declaration => + Param := Chap6.Translate_Name (Act); + -- This is a scalar. + Val := M2E (Param); + when others => + if In_Conv = Null_Iir then + Val := Chap7.Translate_Expression + (Act, Formal_Type); + else + Actual_Type := Get_Type (Act); + Val := Do_Conversion + (In_Conv, + Act, + E2M (Chap7.Translate_Expression (Act, + Actual_Type), + Get_Info (Actual_Type), + Mode_Value)); + end if; + end case; + end if; + New_Association (Constr, Val); + else + -- Parameter passed by ref, which was already computed. + New_Association (Constr, E_Params (Pos)); + end if; + end if; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + + New_Procedure_Call (Constr); + + -- Copy-out non-composite parameters. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Formal := Get_Formal (El); + Base_Formal := Get_Association_Interface (El); + Formal_Type := Get_Type (Formal); + Ftype_Info := Get_Info (Formal_Type); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Base_Formal) in Iir_Out_Modes + and then Params (Pos) /= Mnode_Null + then + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- OUT parameters. + Out_Conv := Get_Out_Conversion (El); + if Out_Conv = Null_Iir then + Out_Expr := Formal; + else + Out_Expr := Out_Conv; + end if; + Ptr := New_Selected_Element + (New_Obj (Res), Formal_Info.Interface_Field); + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + Chap7.Translate_Assign (Params (Pos), + Do_Conversion (Out_Conv, Formal, + Param), + Out_Expr, + Get_Type (Get_Actual (El)), El); + elsif Base_Formal /= Formal then + -- By individual. + -- Copy back. + Act := Get_Actual (El); + declare + Prev_Node : O_Dnode; + begin + Prev_Node := Formal_Info.Interface_Node; + -- We need a pointer since the interface is by reference. + Formal_Info.Interface_Node := + M2Dp (Params (Last_Individual)); + Val := Chap7.Translate_Expression + (Formal, Get_Type (Act)); + Formal_Info.Interface_Node := Prev_Node; + end; + Chap7.Translate_Assign + (Params (Pos), Val, Formal, Get_Type (Act), El); + end if; + end if; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + end Translate_Procedure_Call; + + procedure Translate_Wait_Statement (Stmt : Iir) + is + Sensitivity : Iir_List; + Cond : Iir; + Timeout : Iir; + Constr : O_Assoc_List; + begin + Sensitivity := Get_Sensitivity_List (Stmt); + Cond := Get_Condition_Clause (Stmt); + Timeout := Get_Timeout_Clause (Stmt); + + if Sensitivity = Null_Iir_List and Cond /= Null_Iir then + Sensitivity := Create_Iir_List; + Canon.Canon_Extract_Sensitivity (Cond, Sensitivity); + Set_Sensitivity_List (Stmt, Sensitivity); + end if; + + -- Check for simple cases. + if Sensitivity = Null_Iir_List + and then Cond = Null_Iir + then + if Timeout = Null_Iir then + -- Process exit. + Start_Association (Constr, Ghdl_Process_Wait_Exit); + New_Procedure_Call (Constr); + else + -- Wait for a timeout. + Start_Association (Constr, Ghdl_Process_Wait_Timeout); + New_Association (Constr, Chap7.Translate_Expression + (Timeout, Time_Type_Definition)); + New_Procedure_Call (Constr); + end if; + return; + end if; + + -- Evaluate the timeout (if any) and register it, + if Timeout /= Null_Iir then + Start_Association (Constr, Ghdl_Process_Wait_Set_Timeout); + New_Association (Constr, Chap7.Translate_Expression + (Timeout, Time_Type_Definition)); + New_Procedure_Call (Constr); + end if; + + -- Evaluate the sensitivity list and register it. + if Sensitivity /= Null_Iir_List then + Register_Signal_List + (Sensitivity, Ghdl_Process_Wait_Add_Sensitivity); + end if; + + if Cond = Null_Iir then + declare + V : O_Dnode; + begin + -- declare + -- v : __ghdl_bool_type_node; + -- begin + -- v := suspend (); + -- end; + Open_Temp; + V := Create_Temp (Ghdl_Bool_Type); + Start_Association (Constr, Ghdl_Process_Wait_Suspend); + New_Assign_Stmt (New_Obj (V), New_Function_Call (Constr)); + Close_Temp; + end; + else + declare + Label : O_Snode; + begin + -- start loop + Start_Loop_Stmt (Label); + + -- if suspend() then -- return true if timeout. + -- exit; + -- end if; + Start_Association (Constr, Ghdl_Process_Wait_Suspend); + Gen_Exit_When (Label, New_Function_Call (Constr)); + + -- if condition then + -- exit; + -- end if; + Open_Temp; + Gen_Exit_When + (Label, + Chap7.Translate_Expression (Cond, Boolean_Type_Definition)); + Close_Temp; + + -- end loop; + Finish_Loop_Stmt (Label); + end; + end if; + + -- wait_close; + Start_Association (Constr, Ghdl_Process_Wait_Close); + New_Procedure_Call (Constr); + end Translate_Wait_Statement; + + -- Signal assignment. + Signal_Assign_Line : Natural; + procedure Gen_Simple_Signal_Assign_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Val : O_Enode) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Simple_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Simple_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Simple_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Simple_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Simple_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Simple_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_assign_non_composite", Targ_Type); + end case; + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + Val2 : O_Dnode; + Targ2 : O_Dnode; + begin + Open_Temp; + Val2 := Create_Temp_Init + (Type_Info.Ortho_Type (Mode_Value), Val); + Targ2 := Create_Temp_Init + (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + Start_If_Stmt (If_Blk, Chap3.Not_In_Range (Val2, Targ_Type)); + Start_Association (Assoc, Ghdl_Signal_Simple_Assign_Error); + New_Association (Assoc, New_Obj_Value (Targ2)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + New_Else_Stmt (If_Blk); + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Targ2)); + New_Association + (Assoc, New_Convert_Ov (New_Obj_Value (Val2), Conv)); + New_Procedure_Call (Assoc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Convert_Ov (Val, Conv)); + New_Procedure_Call (Assoc); + end if; + end Gen_Simple_Signal_Assign_Non_Composite; + + procedure Gen_Simple_Signal_Assign is new Foreach_Non_Composite + (Data_Type => O_Enode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Gen_Simple_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite, + Update_Data_Array => Gen_Oenode_Update_Data_Array, + Finish_Data_Array => Gen_Oenode_Finish_Data_Composite, + Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite, + Update_Data_Record => Gen_Oenode_Update_Data_Record, + Finish_Data_Record => Gen_Oenode_Finish_Data_Composite); + + type Signal_Assign_Data is record + Expr : Mnode; + Reject : O_Dnode; + After : O_Dnode; + end record; + + procedure Gen_Start_Signal_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + if Data.Expr = Mnode_Null then + -- Null transaction. + Start_Association (Assoc, Ghdl_Signal_Start_Assign_Null); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + return; + end if; + + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Start_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Start_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Start_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Start_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Start_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Start_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_assign_non_composite", Targ_Type); + end case; + -- Check range. + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + V : Mnode; + Starg : O_Dnode; + begin + Open_Temp; + V := Stabilize_Value (Data.Expr); + Starg := Create_Temp_Init + (Ghdl_Signal_Ptr, + New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + Start_If_Stmt + (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); + Start_Association (Assoc, Ghdl_Signal_Start_Assign_Error); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Obj_Value (Data.After)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + New_Else_Stmt (If_Blk); + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + end if; + end Gen_Start_Signal_Assign_Non_Composite; + + function Gen_Signal_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) + return Signal_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Signal_Prepare_Data_Composite; + + function Gen_Signal_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) + return Signal_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + if Val.Expr = Mnode_Null then + return Val; + else + return Signal_Assign_Data' + (Expr => Stabilize (Val.Expr), + Reject => Val.Reject, + After => Val.After); + end if; + end Gen_Signal_Prepare_Data_Record; + + function Gen_Signal_Update_Data_Array + (Val : Signal_Assign_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Signal_Assign_Data + is + Res : Signal_Assign_Data; + begin + if Val.Expr = Mnode_Null then + -- Handle null transaction. + return Val; + end if; + Res := Signal_Assign_Data' + (Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), + Targ_Type, New_Obj_Value (Index)), + Reject => Val.Reject, + After => Val.After); + return Res; + end Gen_Signal_Update_Data_Array; + + function Gen_Signal_Update_Data_Record + (Val : Signal_Assign_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Signal_Assign_Data + is + pragma Unreferenced (Targ_Type); + Res : Signal_Assign_Data; + begin + if Val.Expr = Mnode_Null then + -- Handle null transaction. + return Val; + end if; + Res := Signal_Assign_Data' + (Expr => Chap6.Translate_Selected_Element (Val.Expr, El), + Reject => Val.Reject, + After => Val.After); + return Res; + end Gen_Signal_Update_Data_Record; + + procedure Gen_Signal_Finish_Data_Composite + (Data : in out Signal_Assign_Data) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Signal_Finish_Data_Composite; + + procedure Gen_Start_Signal_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Assign_Data, + Composite_Data_Type => Signal_Assign_Data, + Do_Non_Composite => Gen_Start_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Finish_Data_Composite); + + procedure Gen_Next_Signal_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + if Data.Expr = Mnode_Null then + -- Null transaction. + Start_Association (Assoc, Ghdl_Signal_Next_Assign_Null); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + return; + end if; + + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Next_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Next_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Next_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Next_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Next_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Next_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_next_assign_non_composite", Targ_Type); + end case; + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + V : Mnode; + Starg : O_Dnode; + begin + Open_Temp; + V := Stabilize_Value (Data.Expr); + Starg := Create_Temp_Init + (Ghdl_Signal_Ptr, + New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + Start_If_Stmt + (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); + + Start_Association (Assoc, Ghdl_Signal_Next_Assign_Error); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.After)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + + New_Else_Stmt (If_Blk); + + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + end if; + end Gen_Next_Signal_Assign_Non_Composite; + + procedure Gen_Next_Signal_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Assign_Data, + Composite_Data_Type => Signal_Assign_Data, + Do_Non_Composite => Gen_Next_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Finish_Data_Composite); + + procedure Translate_Signal_Target_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir); + + procedure Translate_Signal_Target_Array_Aggr + (Aggr : Mnode; + Target : Iir; + Target_Type : Iir; + Idx : O_Dnode; + Dim : Natural) + is + Index_List : constant Iir_List := + Get_Index_Subtype_List (Target_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Sub_Aggr : Mnode; + El : Iir; + Expr : Iir; + begin + El := Get_Association_Choices_Chain (Target); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + Sub_Aggr := Chap3.Index_Base + (Aggr, Target_Type, New_Obj_Value (Idx)); + when others => + Error_Kind ("translate_signal_target_array_aggr", El); + end case; + Expr := Get_Associated_Expr (El); + if Dim = Nbr_Dim then + Translate_Signal_Target_Aggr + (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type)); + if Get_Kind (El) = Iir_Kind_Choice_By_None then + Inc_Var (Idx); + else + raise Internal_Error; + end if; + else + Translate_Signal_Target_Array_Aggr + (Sub_Aggr, Expr, Target_Type, Idx, Dim + 1); + end if; + El := Get_Chain (El); + end loop; + end Translate_Signal_Target_Array_Aggr; + + procedure Translate_Signal_Target_Record_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir) + is + Aggr_El : Iir; + El_List : Iir_List; + El_Index : Natural; + Element : Iir_Element_Declaration; + begin + El_List := Get_Elements_Declaration_List + (Get_Base_Type (Target_Type)); + El_Index := 0; + Aggr_El := Get_Association_Choices_Chain (Target); + while Aggr_El /= Null_Iir loop + case Get_Kind (Aggr_El) is + when Iir_Kind_Choice_By_None => + Element := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Element := Get_Choice_Name (Aggr_El); + El_Index := Natural'Last; + when others => + Error_Kind ("translate_signal_target_record_aggr", Aggr_El); + end case; + Translate_Signal_Target_Aggr + (Chap6.Translate_Selected_Element (Aggr, Element), + Get_Associated_Expr (Aggr_El), Get_Type (Element)); + Aggr_El := Get_Chain (Aggr_El); + end loop; + end Translate_Signal_Target_Record_Aggr; + + procedure Translate_Signal_Target_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir) + is + Src : Mnode; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + declare + Idx : O_Dnode; + St_Aggr : Mnode; + begin + Open_Temp; + St_Aggr := Stabilize (Aggr); + case Get_Kind (Target_Type) is + when Iir_Kinds_Array_Type_Definition => + Idx := Create_Temp (Ghdl_Index_Type); + Init_Var (Idx); + Translate_Signal_Target_Array_Aggr + (St_Aggr, Target, Target_Type, Idx, 1); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Signal_Target_Record_Aggr + (St_Aggr, Target, Target_Type); + when others => + Error_Kind ("translate_signal_target_aggr", Target_Type); + end case; + Close_Temp; + end; + else + Src := Chap6.Translate_Name (Target); + Chap3.Translate_Object_Copy (Aggr, M2E (Src), Target_Type); + end if; + end Translate_Signal_Target_Aggr; + + type Signal_Direct_Assign_Data is record + -- The driver + Drv : Mnode; + + -- The value + Expr : Mnode; + + -- The node for the expression (used to locate errors). + Expr_Node : Iir; + end record; + + procedure Gen_Signal_Direct_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Direct_Assign_Data) + is + Targ_Sig : Mnode; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + Cond : O_Dnode; + Drv : Mnode; + begin + Open_Temp; + Targ_Sig := Stabilize (Targ, True); + Cond := Create_Temp (Ghdl_Bool_Type); + Drv := Stabilize (Data.Drv, False); + + -- Set driver. + Chap7.Translate_Assign + (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node); + + -- Test if the signal is active. + Start_If_Stmt + (If_Blk, + New_Value (Chap14.Get_Signal_Field + (Targ_Sig, Ghdl_Signal_Has_Active_Field))); + -- Either because has_active is true. + New_Assign_Stmt (New_Obj (Cond), + New_Lit (Ghdl_Bool_True_Node)); + New_Else_Stmt (If_Blk); + -- Or because the value is different from the current driving value. + -- FIXME: ideally, we should compare the value with the current + -- value of the driver. This is an approximation that might break + -- with weird resolution functions. + New_Assign_Stmt + (New_Obj (Cond), + New_Compare_Op (ON_Neq, + Chap7.Translate_Signal_Driving_Value + (M2E (Targ_Sig), Targ_Type), + M2E (Drv), + Ghdl_Bool_Type)); + Finish_If_Stmt (If_Blk); + + -- Put signal into active list (if not already in the list). + -- FIXME: this is not thread-safe! + Start_If_Stmt (If_Blk, New_Obj_Value (Cond)); + Start_Association (Constr, Ghdl_Signal_Direct_Assign); + New_Association (Constr, + New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + + Close_Temp; + end Gen_Signal_Direct_Assign_Non_Composite; + + function Gen_Signal_Direct_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Signal_Direct_Prepare_Data_Composite; + + function Gen_Signal_Direct_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Signal_Direct_Assign_Data' + (Drv => Stabilize (Val.Drv), + Expr => Stabilize (Val.Expr), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Prepare_Data_Record; + + function Gen_Signal_Direct_Update_Data_Array + (Val : Signal_Direct_Assign_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Signal_Direct_Assign_Data + is + begin + return Signal_Direct_Assign_Data' + (Drv => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Drv), + Targ_Type, New_Obj_Value (Index)), + Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), + Targ_Type, New_Obj_Value (Index)), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Update_Data_Array; + + function Gen_Signal_Direct_Update_Data_Record + (Val : Signal_Direct_Assign_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ_Type); + begin + return Signal_Direct_Assign_Data' + (Drv => Chap6.Translate_Selected_Element (Val.Drv, El), + Expr => Chap6.Translate_Selected_Element (Val.Expr, El), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Update_Data_Record; + + procedure Gen_Signal_Direct_Finish_Data_Composite + (Data : in out Signal_Direct_Assign_Data) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Signal_Direct_Finish_Data_Composite; + + procedure Gen_Signal_Direct_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Direct_Assign_Data, + Composite_Data_Type => Signal_Direct_Assign_Data, + Do_Non_Composite => Gen_Signal_Direct_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Direct_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Direct_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Direct_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Direct_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Direct_Finish_Data_Composite); + + procedure Translate_Direct_Signal_Assignment (Stmt : Iir; We : Iir) + is + Target : constant Iir := Get_Target (Stmt); + Target_Type : constant Iir := Get_Type (Target); + Arg : Signal_Direct_Assign_Data; + Targ_Sig : Mnode; + begin + Chap6.Translate_Direct_Driver (Target, Targ_Sig, Arg.Drv); + + Arg.Expr := E2M (Chap7.Translate_Expression (We, Target_Type), + Get_Info (Target_Type), Mode_Value); + Arg.Expr_Node := We; + Gen_Signal_Direct_Assign (Targ_Sig, Target_Type, Arg); + end Translate_Direct_Signal_Assignment; + + procedure Translate_Signal_Assignment_Statement (Stmt : Iir) + is + Target : Iir; + Target_Type : Iir; + We : Iir_Waveform_Element; + Targ : Mnode; + Val : O_Enode; + Value : Iir; + Is_Simple : Boolean; + begin + Target := Get_Target (Stmt); + Target_Type := Get_Type (Target); + We := Get_Waveform_Chain (Stmt); + + if We /= Null_Iir + and then Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay + and then Get_Reject_Time_Expression (Stmt) = Null_Iir + then + -- Simple signal assignment ? + Value := Get_We_Value (We); + Is_Simple := Get_Kind (Value) /= Iir_Kind_Null_Literal; + else + Is_Simple := False; + end if; + + if Get_Kind (Target) = Iir_Kind_Aggregate then + Chap3.Translate_Anonymous_Type_Definition (Target_Type, True); + Targ := Create_Temp (Get_Info (Target_Type), Mode_Signal); + Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ); + Translate_Signal_Target_Aggr (Targ, Target, Target_Type); + else + if Is_Simple + and then Flag_Direct_Drivers + and then Chap4.Has_Direct_Driver (Target) + then + Translate_Direct_Signal_Assignment (Stmt, Value); + return; + end if; + Targ := Chap6.Translate_Name (Target); + if Get_Object_Kind (Targ) /= Mode_Signal then + raise Internal_Error; + end if; + end if; + + if We = Null_Iir then + -- Implicit disconnect statment. + Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect); + return; + end if; + + -- Handle a simple and common case: only one waveform, inertial, + -- and no time (eg: sig <= expr). + Value := Get_We_Value (We); + Signal_Assign_Line := Get_Line_Number (Value); + if Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay + and then Get_Reject_Time_Expression (Stmt) = Null_Iir + and then Get_Kind (Value) /= Iir_Kind_Null_Literal + then + Val := Chap7.Translate_Expression (Value, Target_Type); + Gen_Simple_Signal_Assign (Targ, Target_Type, Val); + return; + end if; + + -- General case. + declare + Var_Targ : Mnode; + Targ_Tinfo : Type_Info_Acc; + begin + Open_Temp; + Targ_Tinfo := Get_Info (Target_Type); + Var_Targ := Stabilize (Targ, True); + + -- Translate the first waveform element. + declare + Reject_Time : O_Dnode; + After_Time : O_Dnode; + Del : Iir; + Rej : Iir; + Val : Mnode; + Data : Signal_Assign_Data; + begin + Open_Temp; + Reject_Time := Create_Temp (Std_Time_Otype); + After_Time := Create_Temp (Std_Time_Otype); + Del := Get_Time (We); + if Del = Null_Iir then + New_Assign_Stmt + (New_Obj (After_Time), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); + else + New_Assign_Stmt + (New_Obj (After_Time), + Chap7.Translate_Expression (Del, Time_Type_Definition)); + end if; + case Get_Delay_Mechanism (Stmt) is + when Iir_Transport_Delay => + New_Assign_Stmt + (New_Obj (Reject_Time), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); + when Iir_Inertial_Delay => + Rej := Get_Reject_Time_Expression (Stmt); + if Rej = Null_Iir then + New_Assign_Stmt (New_Obj (Reject_Time), + New_Obj_Value (After_Time)); + else + New_Assign_Stmt + (New_Obj (Reject_Time), Chap7.Translate_Expression + (Rej, Time_Type_Definition)); + end if; + end case; + if Get_Kind (Value) = Iir_Kind_Null_Literal then + Val := Mnode_Null; + else + Val := E2M (Chap7.Translate_Expression (Value, Target_Type), + Targ_Tinfo, Mode_Value); + Val := Stabilize (Val); + end if; + Data := Signal_Assign_Data'(Expr => Val, + Reject => Reject_Time, + After => After_Time); + Gen_Start_Signal_Assign (Var_Targ, Target_Type, Data); + Close_Temp; + end; + + -- Translate other waveform elements. + We := Get_Chain (We); + while We /= Null_Iir loop + declare + After_Time : O_Dnode; + Val : Mnode; + Data : Signal_Assign_Data; + begin + Open_Temp; + After_Time := Create_Temp (Std_Time_Otype); + New_Assign_Stmt + (New_Obj (After_Time), + Chap7.Translate_Expression (Get_Time (We), + Time_Type_Definition)); + Value := Get_We_Value (We); + Signal_Assign_Line := Get_Line_Number (Value); + if Get_Kind (Value) = Iir_Kind_Null_Literal then + Val := Mnode_Null; + else + Val := + E2M (Chap7.Translate_Expression (Value, Target_Type), + Targ_Tinfo, Mode_Value); + end if; + Data := Signal_Assign_Data'(Expr => Val, + Reject => O_Dnode_Null, + After => After_Time); + Gen_Next_Signal_Assign (Var_Targ, Target_Type, Data); + Close_Temp; + end; + We := Get_Chain (We); + end loop; + + Close_Temp; + end; + end Translate_Signal_Assignment_Statement; + + procedure Translate_Statement (Stmt : Iir) + is + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + Open_Temp; + case Get_Kind (Stmt) is + when Iir_Kind_Return_Statement => + Translate_Return_Statement (Stmt); + + when Iir_Kind_If_Statement => + Translate_If_Statement (Stmt); + when Iir_Kind_Assertion_Statement => + Translate_Assertion_Statement (Stmt); + when Iir_Kind_Report_Statement => + Translate_Report_Statement (Stmt); + when Iir_Kind_Case_Statement => + Translate_Case_Statement (Stmt); + + when Iir_Kind_For_Loop_Statement => + Translate_For_Loop_Statement (Stmt); + when Iir_Kind_While_Loop_Statement => + Translate_While_Loop_Statement (Stmt); + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + Translate_Exit_Next_Statement (Stmt); + + when Iir_Kind_Signal_Assignment_Statement => + Translate_Signal_Assignment_Statement (Stmt); + when Iir_Kind_Variable_Assignment_Statement => + Translate_Variable_Assignment_Statement (Stmt); + + when Iir_Kind_Null_Statement => + -- A null statement is translated to a NOP, so that the + -- statement generates code (and a breakpoint can be set on + -- it). + -- Emit_Nop; + null; + + when Iir_Kind_Procedure_Call_Statement => + declare + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Implementation (Call); + begin + Canon.Canon_Subprogram_Call (Call); + if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration + then + Translate_Implicit_Procedure_Call (Call); + else + Translate_Procedure_Call (Call); + end if; + end; + + when Iir_Kind_Wait_Statement => + Translate_Wait_Statement (Stmt); + + when others => + Error_Kind ("translate_statement", Stmt); + end case; + Close_Temp; + end Translate_Statement; + + procedure Translate_Statements_Chain (First : Iir) + is + Stmt : Iir; + begin + Stmt := First; + while Stmt /= Null_Iir loop + Translate_Statement (Stmt); + Stmt := Get_Chain (Stmt); + end loop; + end Translate_Statements_Chain; + + function Translate_Statements_Chain_Has_Return (First : Iir) + return Boolean + is + Stmt : Iir; + Has_Return : Boolean := False; + begin + Stmt := First; + while Stmt /= Null_Iir loop + Translate_Statement (Stmt); + if Get_Kind (Stmt) = Iir_Kind_Return_Statement then + Has_Return := True; + end if; + Stmt := Get_Chain (Stmt); + end loop; + return Has_Return; + end Translate_Statements_Chain_Has_Return; + end Chap8; + + package body Chap9 is + procedure Set_Direct_Drivers (Proc : Iir) + is + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Info : Ortho_Info_Acc; + Var : Var_Type; + Sig : Iir; + begin + for I in Drivers.all'Range loop + Var := Drivers (I).Var; + if Var /= Null_Var then + Sig := Get_Object_Prefix (Drivers (I).Sig); + Info := Get_Info (Sig); + case Info.Kind is + when Kind_Object => + Info.Object_Driver := Var; + when Kind_Alias => + null; + when others => + raise Internal_Error; + end case; + end if; + end loop; + end Set_Direct_Drivers; + + procedure Reset_Direct_Drivers (Proc : Iir) + is + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Info : Ortho_Info_Acc; + Var : Var_Type; + Sig : Iir; + begin + for I in Drivers.all'Range loop + Var := Drivers (I).Var; + if Var /= Null_Var then + Sig := Get_Object_Prefix (Drivers (I).Sig); + Info := Get_Info (Sig); + case Info.Kind is + when Kind_Object => + Info.Object_Driver := Null_Var; + when Kind_Alias => + null; + when others => + raise Internal_Error; + end case; + end if; + end loop; + end Reset_Direct_Drivers; + + procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc) + is + Info : constant Proc_Info_Acc := Get_Info (Proc); + Inter_List : O_Inter_List; + Instance : O_Dnode; + begin + Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Process_Subprg); + + Start_Subprogram_Body (Info.Process_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + Chap8.Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Proc)); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Process_Statement; + + procedure Translate_Implicit_Guard_Signal + (Guard : Iir; Base : Block_Info_Acc) + is + Info : Object_Info_Acc; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Guard_Expr : Iir; + begin + Guard_Expr := Get_Guard_Expression (Guard); + -- Create the subprogram to compute the value of GUARD. + Info := Get_Info (Guard); + Start_Function_Decl (Inter_List, Create_Identifier ("_GUARD_PROC"), + O_Storage_Private, Std_Boolean_Type_Node); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Object_Function); + + Start_Subprogram_Body (Info.Object_Function); + Push_Local_Factory; + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + Open_Temp; + New_Return_Stmt (Chap7.Translate_Expression (Guard_Expr)); + Close_Temp; + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Implicit_Guard_Signal; + + procedure Translate_Component_Instantiation_Statement (Inst : Iir) + is + Comp : constant Iir := Get_Instantiated_Unit (Inst); + Info : Block_Info_Acc; + Comp_Info : Comp_Info_Acc; + + Mark2 : Id_Mark_Type; + Assoc, Conv, In_Type : Iir; + Has_Conv_Record : Boolean := False; + begin + Info := Add_Info (Inst, Kind_Block); + + if Is_Component_Instantiation (Inst) then + -- Via a component declaration. + Comp_Info := Get_Info (Get_Named_Entity (Comp)); + Info.Block_Link_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Get_Scope_Type (Comp_Info.Comp_Scope)); + else + -- Direct instantiation. + Info.Block_Link_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Rtis.Ghdl_Component_Link_Type); + end if; + + -- When conversions are used, the subtype of the actual (or of the + -- formal for out conversions) may not be yet translated. This + -- can happen if the name is a slice. + -- We need to translate it and create variables in the instance + -- because it will be referenced by the conversion subprogram. + Assoc := Get_Port_Map_Aspect_Chain (Inst); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression + then + Conv := Get_In_Conversion (Assoc); + In_Type := Get_Type (Get_Actual (Assoc)); + if Conv /= Null_Iir + and then Is_Anonymous_Type_Definition (In_Type) + then + -- Lazy creation of the record. + if not Has_Conv_Record then + Has_Conv_Record := True; + Push_Instance_Factory (Info.Block_Scope'Access); + end if; + + -- FIXME: handle with overload multiple case on the same + -- formal. + Push_Identifier_Prefix + (Mark2, + Get_Identifier (Get_Association_Interface (Assoc))); + Chap3.Translate_Type_Definition (In_Type, True); + Pop_Identifier_Prefix (Mark2); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + if Has_Conv_Record then + Pop_Instance_Factory (Info.Block_Scope'Access); + New_Type_Decl + (Create_Identifier (Get_Identifier (Inst), "__CONVS"), + Get_Scope_Type (Info.Block_Scope)); + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Get_Identifier (Inst), + "__CONVS"), + Get_Scope_Type (Info.Block_Scope)); + end if; + end Translate_Component_Instantiation_Statement; + + procedure Translate_Process_Declarations (Proc : Iir) + is + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + + Drivers : Iir_List; + Nbr_Drivers : Natural; + Sig : Iir; + begin + Info := Add_Info (Proc, Kind_Process); + + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Proc)); + Push_Instance_Factory (Info.Process_Scope'Access); + Chap4.Translate_Declaration_Chain (Proc); + + if Flag_Direct_Drivers then + -- Create direct drivers. + Drivers := Trans_Analyzes.Extract_Drivers (Proc); + if Flag_Dump_Drivers then + Trans_Analyzes.Dump_Drivers (Proc, Drivers); + end if; + + Nbr_Drivers := Get_Nbr_Elements (Drivers); + Info.Process_Drivers := new Direct_Driver_Arr (1 .. Nbr_Drivers); + for I in 1 .. Nbr_Drivers loop + Sig := Get_Nth_Element (Drivers, I - 1); + Info.Process_Drivers (I) := (Sig => Sig, Var => Null_Var); + Sig := Get_Object_Prefix (Sig); + if Get_Kind (Sig) /= Iir_Kind_Object_Alias_Declaration + and then not Get_After_Drivers_Flag (Sig) + then + Info.Process_Drivers (I).Var := + Create_Var (Create_Var_Identifier (Sig, "_DDRV", I), + Chap4.Get_Object_Type + (Get_Info (Get_Type (Sig)), Mode_Value)); + + -- Do not create driver severals times. + Set_After_Drivers_Flag (Sig, True); + end if; + end loop; + Trans_Analyzes.Free_Drivers_List (Drivers); + end if; + Pop_Instance_Factory (Info.Process_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Process_Scope)); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field (Create_Identifier_Without_Prefix (Proc), + Info.Process_Scope); + end Translate_Process_Declarations; + + procedure Translate_Psl_Directive_Declarations (Stmt : Iir) + is + use PSL.Nodes; + use PSL.NFAs; + + N : constant NFA := Get_PSL_NFA (Stmt); + + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Stmt, Kind_Psl_Directive); + + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Push_Instance_Factory (Info.Psl_Scope'Access); + + Labelize_States (N, Info.Psl_Vect_Len); + Info.Psl_Vect_Type := New_Constrained_Array_Type + (Std_Boolean_Array_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))); + New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type); + Info.Psl_Vect_Var := Create_Var + (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type); + + if Get_Kind (Stmt) = Iir_Kind_Psl_Cover_Statement then + Info.Psl_Bool_Var := Create_Var + (Create_Var_Identifier ("BOOL"), Ghdl_Bool_Type); + end if; + + Pop_Instance_Factory (Info.Psl_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Psl_Scope)); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field + (Create_Identifier_Without_Prefix (Stmt), Info.Psl_Scope); + end Translate_Psl_Directive_Declarations; + + function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean) + return O_Enode + is + use PSL.Nodes; + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + declare + E : Iir; + Rtype : Iir; + Res : O_Enode; + begin + E := Get_HDL_Node (Expr); + Rtype := Get_Base_Type (Get_Type (E)); + Res := Chap7.Translate_Expression (E); + if Rtype = Boolean_Type_Definition then + return Res; + elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then + return New_Value + (New_Indexed_Element + (New_Obj (Ghdl_Std_Ulogic_To_Boolean_Array), + New_Convert_Ov (Res, Ghdl_Index_Type))); + else + Error_Kind ("translate_psl_expr/hdl_expr", Expr); + end if; + end; + when N_True => + return New_Lit (Std_Boolean_True_Node); + when N_EOS => + if Eos then + return New_Lit (Std_Boolean_True_Node); + else + return New_Lit (Std_Boolean_False_Node); + end if; + when N_Not_Bool => + return New_Monadic_Op + (ON_Not, + Translate_Psl_Expr (Get_Boolean (Expr), Eos)); + when N_And_Bool => + return New_Dyadic_Op + (ON_And, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when N_Or_Bool => + return New_Dyadic_Op + (ON_Or, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when others => + Error_Kind ("translate_psl_expr", Expr); + end case; + end Translate_Psl_Expr; + + -- Return TRUE iff NFA has an edge with an EOS. + -- If so, we need to create a finalizer. + function Psl_Need_Finalizer (Nfa : PSL_NFA) return Boolean + is + use PSL.NFAs; + S : NFA_State; + E : NFA_Edge; + begin + S := Get_Final_State (Nfa); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + return True; + end if; + E := Get_Next_Dest_Edge (E); + end loop; + return False; + end Psl_Need_Finalizer; + + procedure Create_Psl_Final_Proc + (Stmt : Iir; Base : Block_Info_Acc; Instance : out O_Dnode) + is + Inter_List : O_Inter_List; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + begin + Start_Procedure_Decl (Inter_List, Create_Identifier ("FINALPROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Final_Subprg); + end Create_Psl_Final_Proc; + + procedure Translate_Psl_Directive_Statement + (Stmt : Iir; Base : Block_Info_Acc) + is + use PSL.NFAs; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Var_I : O_Dnode; + Var_Nvec : O_Dnode; + Label : O_Snode; + Clk_Blk : O_If_Block; + S_Blk : O_If_Block; + E_Blk : O_If_Block; + S : NFA_State; + S_Num : Int32; + E : NFA_Edge; + Sd : NFA_State; + Cond : O_Enode; + NFA : PSL_NFA; + D_Lit : O_Cnode; + begin + Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Subprg); + + Start_Subprogram_Body (Info.Psl_Proc_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + -- New state vector. + New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type); + + -- For cover directive, return now if already covered. + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + null; + when Iir_Kind_Psl_Cover_Statement => + Start_If_Stmt (S_Blk, New_Value (Get_Var (Info.Psl_Bool_Var))); + New_Return_Stmt; + Finish_If_Stmt (S_Blk); + when others => + Error_Kind ("Translate_Psl_Directive_Statement(1)", Stmt); + end case; + + -- Initialize the new state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + -- Global if statement for the clock. + Open_Temp; + Start_If_Stmt (Clk_Blk, + Translate_Psl_Expr (Get_PSL_Clock (Stmt), False)); + + -- For each state: if set, evaluate all outgoing edges. + NFA := Get_PSL_NFA (Stmt); + S := Get_First_State (NFA); + while S /= No_State loop + S_Num := Get_State_Label (S); + Open_Temp; + + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Dest (E); + Open_Temp; + + D_Lit := New_Index_Lit (Unsigned_64 (Get_State_Label (Sd))); + Cond := New_Monadic_Op + (ON_Not, + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (D_Lit)))); + Cond := New_Dyadic_Op + (ON_And, Cond, Translate_Psl_Expr (Get_Edge_Expr (E), False)); + Start_If_Stmt (E_Blk, Cond); + New_Assign_Stmt + (New_Indexed_Element (New_Obj (Var_Nvec), New_Lit (D_Lit)), + New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (E_Blk); + + Close_Temp; + E := Get_Next_Src_Edge (E); + end loop; + + Finish_If_Stmt (S_Blk); + Close_Temp; + S := Get_Next_State (S); + end loop; + + -- Check fail state. + S := Get_Final_State (NFA); + S_Num := Get_State_Label (S); + pragma Assert (Integer (S_Num) = Info.Psl_Vect_Len - 1); + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + when Iir_Kind_Psl_Cover_Statement => + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Cover, Severity_Level_Note); + New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), + New_Lit (Ghdl_Bool_True_Node)); + when others => + Error_Kind ("Translate_Psl_Directive_Statement", Stmt); + end case; + Finish_If_Stmt (S_Blk); + + -- Assign state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)))); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + Close_Temp; + Finish_If_Stmt (Clk_Blk); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- The finalizer. + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + if Psl_Need_Finalizer (NFA) then + Create_Psl_Final_Proc (Stmt, Base, Instance); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + S := Get_Final_State (NFA); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Src (E); + + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + + S_Num := Get_State_Label (Sd); + Open_Temp; + + Cond := New_Value + (New_Indexed_Element + (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit (Unsigned_64 (S_Num))))); + Cond := New_Dyadic_Op + (ON_And, Cond, + Translate_Psl_Expr (Get_Edge_Expr (E), True)); + Start_If_Stmt (E_Blk, Cond); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + New_Return_Stmt; + Finish_If_Stmt (E_Blk); + + Close_Temp; + end if; + + E := Get_Next_Dest_Edge (E); + end loop; + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + else + Info.Psl_Proc_Final_Subprg := O_Dnode_Null; + end if; + + when Iir_Kind_Psl_Cover_Statement => + Create_Psl_Final_Proc (Stmt, Base, Instance); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + Start_If_Stmt + (S_Blk, + New_Monadic_Op (ON_Not, + New_Value (Get_Var (Info.Psl_Bool_Var)))); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Cover_Failed, Severity_Level_Error); + Finish_If_Stmt (S_Blk); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + + when others => + Error_Kind ("Translate_Psl_Directive_Statement(3)", Stmt); + end case; + end Translate_Psl_Directive_Statement; + + -- Create the instance for block BLOCK. + -- BLOCK can be either an entity, an architecture or a block statement. + procedure Translate_Block_Declarations (Block : Iir; Origin : Iir) + is + El : Iir; + begin + Chap4.Translate_Declaration_Chain (Block); + + El := Get_Concurrent_Statement_Chain (Block); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Translate_Process_Declarations (El); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Translate_Psl_Directive_Declarations (El); + when Iir_Kind_Component_Instantiation_Statement => + Translate_Component_Instantiation_Statement (El); + when Iir_Kind_Block_Statement => + declare + Info : Block_Info_Acc; + Hdr : Iir_Block_Header; + Guard : Iir; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + Info := Add_Info (El, Kind_Block); + Chap1.Start_Block_Decl (El); + Push_Instance_Factory (Info.Block_Scope'Access); + + Guard := Get_Guard_Decl (El); + if Guard /= Null_Iir then + Chap4.Translate_Declaration (Guard); + end if; + + -- generics, ports. + Hdr := Get_Block_Header (El); + if Hdr /= Null_Iir then + Chap4.Translate_Generic_Chain (Hdr); + Chap4.Translate_Port_Chain (Hdr); + end if; + + Chap9.Translate_Block_Declarations (El, Origin); + + Pop_Instance_Factory (Info.Block_Scope'Access); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Scope); + end; + when Iir_Kind_Generate_Statement => + declare + Scheme : constant Iir := Get_Generation_Scheme (El); + Info : Block_Info_Acc; + Mark : Id_Mark_Type; + Iter_Type : Iir; + It_Info : Ortho_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Chap3.Translate_Object_Subtype (Scheme, True); + end if; + + Info := Add_Info (El, Kind_Block); + Chap1.Start_Block_Decl (El); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Add a parent field in the current instance. + Info.Block_Origin_Field := Add_Instance_Factory_Field + (Get_Identifier ("ORIGIN"), + Get_Info (Origin).Block_Decls_Ptr_Type); + + -- Iterator. + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Info.Block_Configured_Field := + Add_Instance_Factory_Field + (Get_Identifier ("CONFIGURED"), Ghdl_Bool_Type); + It_Info := Add_Info (Scheme, Kind_Iterator); + It_Info.Iterator_Var := Create_Var + (Create_Var_Identifier (Scheme), + Get_Info (Get_Base_Type (Iter_Type)).Ortho_Type + (Mode_Value)); + end if; + + Chap9.Translate_Block_Declarations (El, El); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + -- Create array type of block_decls_type + Info.Block_Decls_Array_Type := New_Array_Type + (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("INSTARRTYPE"), + Info.Block_Decls_Array_Type); + -- Create access to the array type. + Info.Block_Decls_Array_Ptr_Type := New_Access_Type + (Info.Block_Decls_Array_Type); + New_Type_Decl (Create_Identifier ("INSTARRPTR"), + Info.Block_Decls_Array_Ptr_Type); + -- Add a field in parent record + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Decls_Array_Ptr_Type); + else + -- Create an access field in the parent record. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Decls_Ptr_Type); + end if; + + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("translate_block_declarations", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Declarations; + + procedure Translate_Component_Instantiation_Subprogram + (Stmt : Iir; Base : Block_Info_Acc) + is + procedure Set_Component_Link (Ref_Scope : Var_Scope_Type; + Comp_Field : O_Fnode) + is + begin + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Comp_Field), + Rtis.Ghdl_Component_Link_Stmt), + New_Lit (Rtis.Get_Context_Rti (Stmt))); + end Set_Component_Link; + + Info : constant Block_Info_Acc := Get_Info (Stmt); + + Parent : constant Iir := Get_Parent (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); + + Comp : Iir; + Comp_Info : Comp_Info_Acc; + Inter_List : O_Inter_List; + Instance : O_Dnode; + begin + -- Create the elaborator for the instantiation. + Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Block_Elab_Subprg); + + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + -- Add access to the instantiation-specific data. + -- This is used only for anonymous subtype variables. + if Has_Scope_Type (Info.Block_Scope) then + Set_Scope_Via_Field (Info.Block_Scope, + Info.Block_Parent_Field, + Parent_Info.Block_Scope'Access); + end if; + + Comp := Get_Instantiated_Unit (Stmt); + if Is_Entity_Instantiation (Stmt) then + -- This is a direct instantiation. + Set_Component_Link (Parent_Info.Block_Scope, + Info.Block_Link_Field); + Translate_Entity_Instantiation (Comp, Stmt, Stmt, Null_Iir); + else + Comp := Get_Named_Entity (Comp); + Comp_Info := Get_Info (Comp); + Set_Scope_Via_Field (Comp_Info.Comp_Scope, + Info.Block_Link_Field, + Parent_Info.Block_Scope'Access); + + -- Set the link from component declaration to component + -- instantiation statement. + Set_Component_Link (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); + + Chap5.Elab_Map_Aspect (Stmt, Comp); + + Clear_Scope (Comp_Info.Comp_Scope); + end if; + + if Has_Scope_Type (Info.Block_Scope) then + Clear_Scope (Info.Block_Scope); + end if; + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Component_Instantiation_Subprogram; + + -- Translate concurrent statements into subprograms. + procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir) + is + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt : Iir; + Mark : Id_Mark_Type; + begin + Chap4.Translate_Declaration_Chain_Subprograms (Block); + + Stmt := Get_Concurrent_Statement_Chain (Block); + while Stmt /= Null_Iir loop + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + if Flag_Direct_Drivers then + Chap9.Set_Direct_Drivers (Stmt); + end if; + + Chap4.Translate_Declaration_Chain_Subprograms (Stmt); + Translate_Process_Statement (Stmt, Base_Info); + + if Flag_Direct_Drivers then + Chap9.Reset_Direct_Drivers (Stmt); + end if; + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Translate_Psl_Directive_Statement (Stmt, Base_Info); + when Iir_Kind_Component_Instantiation_Statement => + Chap4.Translate_Association_Subprograms + (Stmt, Block, Base_Block, + Get_Entity_From_Entity_Aspect + (Get_Instantiated_Unit (Stmt))); + Translate_Component_Instantiation_Subprogram + (Stmt, Base_Info); + when Iir_Kind_Block_Statement => + declare + Guard : constant Iir := Get_Guard_Decl (Stmt); + Hdr : constant Iir := Get_Block_Header (Stmt); + begin + if Guard /= Null_Iir then + Translate_Implicit_Guard_Signal (Guard, Base_Info); + end if; + if Hdr /= Null_Iir then + Chap4.Translate_Association_Subprograms + (Hdr, Block, Base_Block, Null_Iir); + end if; + Translate_Block_Subprograms (Stmt, Base_Block); + end; + when Iir_Kind_Generate_Statement => + declare + Info : constant Block_Info_Acc := Get_Info (Stmt); + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + Info.Block_Origin_Field, + Info.Block_Scope'Access); + Translate_Block_Subprograms (Stmt, Stmt); + Clear_Scope (Base_Info.Block_Scope); + Chap2.Pop_Subprg_Instance + (Wki_Instance, Prev_Subprg_Instance); + end; + when others => + Error_Kind ("translate_block_subprograms", Stmt); + end case; + Pop_Identifier_Prefix (Mark); + Stmt := Get_Chain (Stmt); + end loop; + end Translate_Block_Subprograms; + + -- Remove anonymous and implicit type definitions in a list of names. + -- Such type definitions are created during slice translations, however + -- variables created are defined in the translation scope. + -- If the type is referenced again, the variables must be reachable. + -- This is not the case for elaborator subprogram (which may references + -- slices in the sensitivity or driver list) and the process subprg. + procedure Destroy_Types_In_Name (Name : Iir) + is + El : Iir; + Atype : Iir; + Info : Type_Info_Acc; + begin + El := Name; + loop + Atype := Null_Iir; + case Get_Kind (El) is + when Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name => + El := Get_Prefix (El); + when Iir_Kind_Slice_Name => + Atype := Get_Type (El); + El := Get_Prefix (El); + when Iir_Kind_Object_Alias_Declaration => + El := Get_Name (El); + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + El := Get_Prefix (El); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + exit; + when Iir_Kinds_Denoting_Name => + El := Get_Named_Entity (El); + when others => + Error_Kind ("destroy_types_in_name", El); + end case; + if Atype /= Null_Iir + and then Is_Anonymous_Type_Definition (Atype) + then + Info := Get_Info (Atype); + if Info /= null then + Free_Type_Info (Info); + Clear_Info (Atype); + end if; + end if; + end loop; + end Destroy_Types_In_Name; + + procedure Destroy_Types_In_List (List : Iir_List) + is + El : Iir; + begin + if List = Null_Iir_List then + return; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Destroy_Types_In_Name (El); + end loop; + end Destroy_Types_In_List; + + procedure Gen_Register_Direct_Driver_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Drv : Mnode) + is + pragma Unreferenced (Targ_Type); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); + New_Association + (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Association + (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); + New_Procedure_Call (Constr); + end Gen_Register_Direct_Driver_Non_Composite; + + function Gen_Register_Direct_Driver_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Register_Direct_Driver_Prepare_Data_Composite; + + function Gen_Register_Direct_Driver_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Stabilize (Val); + end Gen_Register_Direct_Driver_Prepare_Data_Record; + + function Gen_Register_Direct_Driver_Update_Data_Array + (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) + return Mnode + is + begin + return Chap3.Index_Base (Chap3.Get_Array_Base (Val), + Targ_Type, New_Obj_Value (Index)); + end Gen_Register_Direct_Driver_Update_Data_Array; + + function Gen_Register_Direct_Driver_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return Mnode + is + pragma Unreferenced (Targ_Type); + begin + return Chap6.Translate_Selected_Element (Val, El); + end Gen_Register_Direct_Driver_Update_Data_Record; + + procedure Gen_Register_Direct_Driver_Finish_Data_Composite + (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Register_Direct_Driver_Finish_Data_Composite; + + procedure Gen_Register_Direct_Driver is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Gen_Register_Direct_Driver_Non_Composite, + Prepare_Data_Array => + Gen_Register_Direct_Driver_Prepare_Data_Composite, + Update_Data_Array => Gen_Register_Direct_Driver_Update_Data_Array, + Finish_Data_Array => Gen_Register_Direct_Driver_Finish_Data_Composite, + Prepare_Data_Record => Gen_Register_Direct_Driver_Prepare_Data_Record, + Update_Data_Record => Gen_Register_Direct_Driver_Update_Data_Record, + Finish_Data_Record => + Gen_Register_Direct_Driver_Finish_Data_Composite); + +-- procedure Register_Scalar_Direct_Driver (Sig : Mnode; +-- Sig_Type : Iir; +-- Drv : Mnode) +-- is +-- pragma Unreferenced (Sig_Type); +-- Constr : O_Assoc_List; +-- begin +-- Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); +-- New_Association +-- (Constr, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); +-- New_Association +-- (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); +-- New_Procedure_Call (Constr); +-- end Register_Scalar_Direct_Driver; + + -- PROC: the process to be elaborated + -- BASE_INFO: info for the global block + procedure Elab_Process (Proc : Iir; Base_Info : Block_Info_Acc) + is + Info : constant Proc_Info_Acc := Get_Info (Proc); + Is_Sensitized : constant Boolean := + Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement; + Subprg : O_Dnode; + Constr : O_Assoc_List; + List : Iir_List; + List_Orig : Iir_List; + Final : Boolean; + begin + New_Debug_Line_Stmt (Get_Line_Number (Proc)); + + -- Register process. + if Is_Sensitized then + if Get_Postponed_Flag (Proc) then + Subprg := Ghdl_Postponed_Sensitized_Process_Register; + else + Subprg := Ghdl_Sensitized_Process_Register; + end if; + else + if Get_Postponed_Flag (Proc) then + Subprg := Ghdl_Postponed_Process_Register; + else + Subprg := Ghdl_Process_Register; + end if; + end if; + + Start_Association (Constr, Subprg); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Process_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Proc); + New_Procedure_Call (Constr); + + -- First elaborate declarations since a driver may depend on + -- an alias declaration. + -- Also, with vhdl 08 a sensitivity element may depend on an alias. + Open_Temp; + Chap4.Elab_Declaration_Chain (Proc, Final); + Close_Temp; + + -- Register drivers. + if Flag_Direct_Drivers then + Chap9.Set_Direct_Drivers (Proc); + + declare + Sig : Iir; + Base : Iir; + Sig_Node, Drv_Node : Mnode; + begin + for I in Info.Process_Drivers.all'Range loop + Sig := Info.Process_Drivers (I).Sig; + Open_Temp; + Base := Get_Object_Prefix (Sig); + if Info.Process_Drivers (I).Var /= Null_Var then + -- Elaborate direct driver. Done only once. + Chap4.Elab_Direct_Driver_Declaration_Storage (Base); + end if; + if Chap4.Has_Direct_Driver (Base) then + -- Signal has a direct driver. + Chap6.Translate_Direct_Driver (Sig, Sig_Node, Drv_Node); + Gen_Register_Direct_Driver + (Sig_Node, Get_Type (Sig), Drv_Node); + else + Register_Signal (Chap6.Translate_Name (Sig), + Get_Type (Sig), + Ghdl_Process_Add_Driver); + end if; + Close_Temp; + end loop; + end; + + Chap9.Reset_Direct_Drivers (Proc); + else + List := Trans_Analyzes.Extract_Drivers (Proc); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Driver); + if Flag_Dump_Drivers then + Trans_Analyzes.Dump_Drivers (Proc, List); + end if; + Trans_Analyzes.Free_Drivers_List (List); + end if; + + if Is_Sensitized then + List_Orig := Get_Sensitivity_List (Proc); + if List_Orig = Iir_List_All then + List := Canon.Canon_Extract_Process_Sensitivity (Proc); + else + List := List_Orig; + end if; + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + if List_Orig = Iir_List_All then + Destroy_Iir_List (List); + end if; + end if; + end Elab_Process; + + -- PROC: the process to be elaborated + -- BLOCK: the block containing the process (its parent) + -- BASE_INFO: info for the global block + procedure Elab_Psl_Directive (Stmt : Iir; + Base_Info : Block_Info_Acc) + is + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Constr : O_Assoc_List; + List : Iir_List; + Clk : PSL_Node; + Var_I : O_Dnode; + Label : O_Snode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + -- Register process. + Start_Association (Constr, Ghdl_Sensitized_Process_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Stmt); + New_Procedure_Call (Constr); + + -- Register clock sensitivity. + Clk := Get_PSL_Clock (Stmt); + List := Create_Iir_List; + Canon_PSL.Canon_Extract_Sensitivity (Clk, List); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + Destroy_Iir_List (List); + + -- Register finalizer (if any). + if Info.Psl_Proc_Final_Subprg /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Finalize_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), + Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Final_Subprg, + Ghdl_Ptr_Type))); + New_Procedure_Call (Constr); + end if; + + -- Initialize state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (Ghdl_Index_0)), + New_Lit (Std_Boolean_True_Node)); + New_Assign_Stmt (New_Obj (Var_I), New_Lit (Ghdl_Index_1)); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + if Info.Psl_Bool_Var /= Null_Var then + New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), + New_Lit (Ghdl_Bool_False_Node)); + end if; + end Elab_Psl_Directive; + + procedure Elab_Implicit_Guard_Signal + (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc) + is + Guard : Iir; + Type_Info : Type_Info_Acc; + Info : Object_Info_Acc; + Constr : O_Assoc_List; + begin + -- Create the guard signal. + Guard := Get_Guard_Decl (Block); + Info := Get_Info (Guard); + Type_Info := Get_Info (Get_Type (Guard)); + Start_Association (Constr, Ghdl_Signal_Create_Guard); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Block_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Object_Function, + Ghdl_Ptr_Type))); +-- New_Association (Constr, Chap6.Get_Instance_Name_Ref (Block)); + New_Assign_Stmt (Get_Var (Info.Object_Var), + New_Convert_Ov (New_Function_Call (Constr), + Type_Info.Ortho_Type (Mode_Signal))); + + -- Register sensitivity list of the guard signal. + Register_Signal_List (Get_Guard_Sensitivity_List (Guard), + Ghdl_Signal_Guard_Dependence); + end Elab_Implicit_Guard_Signal; + + procedure Translate_Entity_Instantiation + (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir) + is + Entity_Unit : Iir_Design_Unit; + Config : Iir; + Arch : Iir; + Entity : Iir_Entity_Declaration; + Entity_Info : Block_Info_Acc; + Arch_Info : Block_Info_Acc; + + Instance_Size : O_Dnode; + Arch_Elab : O_Dnode; + Arch_Config : O_Dnode; + Arch_Config_Type : O_Tnode; + + Var_Sub : O_Dnode; + begin + -- Extract entity, architecture and configuration from + -- binding aspect. + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Aspect); + Arch := Get_Architecture (Aspect); + if Flags.Flag_Elaborate and then Arch = Null_Iir then + -- This is valid only during elaboration. + Arch := Libraries.Get_Latest_Architecture (Entity); + end if; + Config := Null_Iir; + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Configuration (Aspect); + Entity := Get_Entity (Config); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + when others => + Error_Kind ("translate_entity_instantiation", Aspect); + end case; + Entity_Unit := Get_Design_Unit (Entity); + Entity_Info := Get_Info (Entity); + if Config_Override /= Null_Iir then + Config := Config_Override; + if Get_Kind (Arch) = Iir_Kind_Simple_Name then + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + end if; + end if; + + -- 1) Create instance for the arch + if Arch /= Null_Iir then + Arch_Info := Get_Info (Arch); + if Config = Null_Iir + and then Get_Kind (Arch) = Iir_Kind_Architecture_Body + then + Config := Get_Default_Configuration_Declaration (Arch); + if Config /= Null_Iir then + Config := Get_Library_Unit (Config); + end if; + end if; + else + Arch_Info := null; + end if; + if Arch_Info = null or Config = Null_Iir then + declare + function Get_Arch_Name return String is + begin + if Arch /= Null_Iir then + return "ARCH__" & Image_Identifier (Arch); + else + return "LASTARCH"; + end if; + end Get_Arch_Name; + + Str : constant String := + Image_Identifier (Get_Library (Get_Design_File (Entity_Unit))) + & "__" & Image_Identifier (Entity) & "__" + & Get_Arch_Name & "__"; + Sub_Inter : O_Inter_List; + Arg : O_Dnode; + begin + if Arch_Info = null then + New_Const_Decl + (Instance_Size, Get_Identifier (Str & "INSTSIZE"), + O_Storage_External, Ghdl_Index_Type); + + Start_Procedure_Decl + (Sub_Inter, Get_Identifier (Str & "ELAB"), + O_Storage_External); + New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Sub_Inter, Arch_Elab); + end if; + + if Config = Null_Iir then + Start_Procedure_Decl + (Sub_Inter, Get_Identifier (Str & "DEFAULT_CONFIG"), + O_Storage_External); + New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Sub_Inter, Arch_Config); + + Arch_Config_Type := Entity_Info.Block_Decls_Ptr_Type; + end if; + end; + end if; + + if Arch_Info = null then + if Config /= Null_Iir then + -- Architecture is unknown, but we know how to configure + -- the block inside it. + raise Internal_Error; + end if; + else + Instance_Size := Arch_Info.Block_Instance_Size; + Arch_Elab := Arch_Info.Block_Elab_Subprg; + if Config /= Null_Iir then + Arch_Config := Get_Info (Config).Config_Subprg; + Arch_Config_Type := Arch_Info.Block_Decls_Ptr_Type; + end if; + end if; + + -- Create the instance variable and allocate storage. + New_Var_Decl (Var_Sub, Get_Identifier ("SUB_INSTANCE"), + O_Storage_Local, Entity_Info.Block_Decls_Ptr_Type); + + New_Assign_Stmt + (New_Obj (Var_Sub), + Gen_Alloc (Alloc_System, New_Obj_Value (Instance_Size), + Entity_Info.Block_Decls_Ptr_Type)); + + -- 1.5) link instance. + declare + procedure Set_Links (Ref_Scope : Var_Scope_Type; + Link_Field : O_Fnode) + is + begin + -- Set the ghdl_component_link_instance field. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Instance), + New_Address (New_Selected_Acc_Value + (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Acc)); + -- Set the ghdl_entity_link_parent field. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Parent), + New_Address + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Acc)); + end Set_Links; + begin + case Get_Kind (Parent) is + when Iir_Kind_Component_Declaration => + -- Instantiation via a component declaration. + declare + Comp_Info : constant Comp_Info_Acc := Get_Info (Parent); + begin + Set_Links (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); + end; + when Iir_Kind_Component_Instantiation_Statement => + -- Direct instantiation. + declare + Parent_Info : constant Block_Info_Acc := + Get_Info (Get_Parent (Parent)); + begin + Set_Links (Parent_Info.Block_Scope, + Get_Info (Parent).Block_Link_Field); + end; + when others => + Error_Kind ("translate_entity_instantiation(1)", Parent); + end case; + end; + + -- Elab entity packages. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); + New_Procedure_Call (Assoc); + end; + + -- Elab map aspects. + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Var_Sub); + Chap5.Elab_Map_Aspect (Mapping, Entity); + Clear_Scope (Entity_Info.Block_Scope); + + -- 3) Elab instance. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Arch_Elab); + New_Association (Assoc, New_Obj_Value (Var_Sub)); + New_Procedure_Call (Assoc); + end; + + -- 5) Configure + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Arch_Config); + New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Var_Sub), + Arch_Config_Type)); + New_Procedure_Call (Assoc); + end; + end Translate_Entity_Instantiation; + + procedure Elab_Conditionnal_Generate_Statement + (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); + Var : O_Dnode; + Blk : O_If_Block; + V : O_Lnode; + begin + Open_Temp; + + Var := Create_Temp (Info.Block_Decls_Ptr_Type); + Start_If_Stmt (Blk, Chap7.Translate_Expression (Scheme)); + New_Assign_Stmt + (New_Obj (Var), + Gen_Alloc (Alloc_System, + New_Lit (Get_Scope_Size (Info.Block_Scope)), + Info.Block_Decls_Ptr_Type)); + New_Else_Stmt (Blk); + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type))); + Finish_If_Stmt (Blk); + + -- Add a link to child in parent. + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Parent_Field); + New_Assign_Stmt (V, New_Obj_Value (Var)); + + Start_If_Stmt + (Blk, + New_Compare_Op + (ON_Neq, + New_Obj_Value (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), + Ghdl_Bool_Type)); + -- Add a link to parent in child. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), + Get_Instance_Access (Base_Block)); + -- Elaborate block + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Elab_Block_Declarations (Stmt, Stmt); + Clear_Scope (Info.Block_Scope); + Finish_If_Stmt (Blk); + Close_Temp; + end Elab_Conditionnal_Generate_Statement; + + procedure Elab_Iterative_Generate_Statement + (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Iter_Type : constant Iir := Get_Type (Scheme); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); +-- Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Var_Inst : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + V : O_Lnode; + Var : O_Dnode; + Range_Ptr : O_Dnode; + begin + Open_Temp; + + -- Evaluate iterator range. + Chap3.Elab_Object_Subtype (Iter_Type); + + Range_Ptr := Create_Temp_Ptr + (Iter_Type_Info.T.Range_Ptr_Type, + Get_Var (Get_Info (Iter_Type).T.Range_Var)); + + -- Allocate instances. + Var_Inst := Create_Temp (Info.Block_Decls_Array_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Inst), + Gen_Alloc + (Alloc_System, + New_Dyadic_Op (ON_Mul_Ov, + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Length), + New_Lit (Get_Scope_Size (Info.Block_Scope))), + Info.Block_Decls_Array_Ptr_Type)); + + -- Add a link to child in parent. + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Parent_Field); + New_Assign_Stmt (V, New_Obj_Value (Var_Inst)); + + -- Start loop. + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Length), + Ghdl_Bool_Type)); + + Var := Create_Temp_Ptr + (Info.Block_Decls_Ptr_Type, + New_Indexed_Element (New_Acc_Value (New_Obj (Var_Inst)), + New_Obj_Value (Var_I))); + -- Add a link to parent in child. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), + Get_Instance_Access (Base_Block)); + -- Mark the block as not (yet) configured. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_False_Node)); + + -- Elaborate block + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + -- Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + -- Info.Block_Origin_Field, + -- Info.Block_Scope'Access); + + -- Set iterator value. + -- FIXME: this could be slighly optimized... + declare + Val : O_Dnode; + If_Blk : O_If_Block; + begin + Val := Create_Temp (Iter_Type_Info.Ortho_Type (Mode_Value)); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Left)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Right)); + Finish_If_Stmt (If_Blk); + + New_Assign_Stmt + (Get_Var (Get_Info (Scheme).Iterator_Var), + New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Val), + New_Convert_Ov (New_Obj_Value (Var_I), + Iter_Type_Info.Ortho_Type (Mode_Value)))); + end; + + -- Elaboration. + Elab_Block_Declarations (Stmt, Stmt); + +-- Clear_Scope (Base_Info.Block_Scope); + Clear_Scope (Info.Block_Scope); + + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + end Elab_Iterative_Generate_Statement; + + type Merge_Signals_Data is record + Sig : Iir; + Set_Init : Boolean; + Has_Val : Boolean; + Val : Mnode; + end record; + + procedure Merge_Signals_Rti_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Merge_Signals_Data) + is + Type_Info : Type_Info_Acc; + Sig : Mnode; + + Init_Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + Init_Val : O_Enode; + begin + Type_Info := Get_Info (Targ_Type); + + Open_Temp; + + if Data.Set_Init then + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Init_Subprg := Ghdl_Signal_Init_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Init_Subprg := Ghdl_Signal_Init_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Init_Subprg := Ghdl_Signal_Init_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Init_Subprg := Ghdl_Signal_Init_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Init_Subprg := Ghdl_Signal_Init_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Init_Subprg := Ghdl_Signal_Init_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("merge_signals_rti_non_composite", Targ_Type); + end case; + + Sig := Stabilize (Targ, True); + + -- Init the signal. + Start_Association (Assoc, Init_Subprg); + New_Association + (Assoc, + New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); + if Data.Has_Val then + Init_Val := M2E (Data.Val); + else + Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); + end if; + New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); + New_Procedure_Call (Assoc); + else + Sig := Targ; + end if; + + Start_Association (Assoc, Ghdl_Signal_Merge_Rti); + + New_Association + (Assoc, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); + New_Association + (Assoc, + New_Lit (New_Global_Unchecked_Address + (Get_Info (Data.Sig).Object_Rti, + Rtis.Ghdl_Rti_Access))); + New_Procedure_Call (Assoc); + Close_Temp; + end Merge_Signals_Rti_Non_Composite; + + function Merge_Signals_Rti_Prepare (Targ : Mnode; + Targ_Type : Iir; + Data : Merge_Signals_Data) + return Merge_Signals_Data + is + pragma Unreferenced (Targ); + pragma Unreferenced (Targ_Type); + Res : Merge_Signals_Data; + begin + Res := Data; + if Data.Has_Val then + if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then + Res.Val := Stabilize (Data.Val); + else + Res.Val := Chap3.Get_Array_Base (Data.Val); + end if; + end if; + + return Res; + end Merge_Signals_Rti_Prepare; + + function Merge_Signals_Rti_Update_Data_Array + (Data : Merge_Signals_Data; Targ_Type : Iir; Index : O_Dnode) + return Merge_Signals_Data + is + begin + if not Data.Has_Val then + return Data; + else + return Merge_Signals_Data' + (Sig => Data.Sig, + Val => Chap3.Index_Base (Data.Val, Targ_Type, + New_Obj_Value (Index)), + Has_Val => True, + Set_Init => Data.Set_Init); + end if; + end Merge_Signals_Rti_Update_Data_Array; + + procedure Merge_Signals_Rti_Finish_Data_Composite + (Data : in out Merge_Signals_Data) + is + pragma Unreferenced (Data); + begin + null; + end Merge_Signals_Rti_Finish_Data_Composite; + + function Merge_Signals_Rti_Update_Data_Record + (Data : Merge_Signals_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) return Merge_Signals_Data + is + pragma Unreferenced (Targ_Type); + begin + if not Data.Has_Val then + return Data; + else + return Merge_Signals_Data' + (Sig => Data.Sig, + Val => Chap6.Translate_Selected_Element (Data.Val, El), + Has_Val => True, + Set_Init => Data.Set_Init); + end if; + end Merge_Signals_Rti_Update_Data_Record; + + pragma Inline (Merge_Signals_Rti_Finish_Data_Composite); + + procedure Merge_Signals_Rti is new Foreach_Non_Composite + (Data_Type => Merge_Signals_Data, + Composite_Data_Type => Merge_Signals_Data, + Do_Non_Composite => Merge_Signals_Rti_Non_Composite, + Prepare_Data_Array => Merge_Signals_Rti_Prepare, + Update_Data_Array => Merge_Signals_Rti_Update_Data_Array, + Finish_Data_Array => Merge_Signals_Rti_Finish_Data_Composite, + Prepare_Data_Record => Merge_Signals_Rti_Prepare, + Update_Data_Record => Merge_Signals_Rti_Update_Data_Record, + Finish_Data_Record => Merge_Signals_Rti_Finish_Data_Composite); + + procedure Merge_Signals_Rti_Of_Port_Chain (Chain : Iir) + is + Port : Iir; + Port_Type : Iir; + Data : Merge_Signals_Data; + Val : Iir; + begin + Port := Chain; + while Port /= Null_Iir loop + Port_Type := Get_Type (Port); + Data.Sig := Port; + case Get_Mode (Port) is + when Iir_Buffer_Mode + | Iir_Out_Mode + | Iir_Inout_Mode => + Data.Set_Init := True; + when others => + Data.Set_Init := False; + end case; + + Open_Temp; + Val := Get_Default_Value (Port); + if Val = Null_Iir then + Data.Has_Val := False; + else + Data.Has_Val := True; + Data.Val := E2M (Chap7.Translate_Expression (Val, Port_Type), + Get_Info (Port_Type), + Mode_Value); + end if; + + Merge_Signals_Rti (Chap6.Translate_Name (Port), Port_Type, Data); + Close_Temp; + + Port := Get_Chain (Port); + end loop; + end Merge_Signals_Rti_Of_Port_Chain; + + procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir) + is + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt : Iir; + Final : Boolean; + begin + New_Debug_Line_Stmt (Get_Line_Number (Block)); + + case Get_Kind (Block) is + when Iir_Kind_Entity_Declaration => + Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Block)); + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_Block_Statement => + declare + Header : constant Iir_Block_Header := + Get_Block_Header (Block); + Guard : constant Iir := Get_Guard_Decl (Block); + begin + if Guard /= Null_Iir then + New_Debug_Line_Stmt (Get_Line_Number (Guard)); + Elab_Implicit_Guard_Signal (Block, Base_Info); + end if; + if Header /= Null_Iir then + New_Debug_Line_Stmt (Get_Line_Number (Header)); + Chap5.Elab_Map_Aspect (Header, Block); + Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Header)); + end if; + end; + when Iir_Kind_Generate_Statement => + null; + when others => + Error_Kind ("elab_block_declarations", Block); + end case; + + Open_Temp; + Chap4.Elab_Declaration_Chain (Block, Final); + Close_Temp; + + Stmt := Get_Concurrent_Statement_Chain (Block); + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Elab_Process (Stmt, Base_Info); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Elab_Psl_Directive (Stmt, Base_Info); + when Iir_Kind_Component_Instantiation_Statement => + declare + Info : constant Block_Info_Acc := Get_Info (Stmt); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Block_Elab_Subprg); + New_Association + (Constr, Get_Instance_Access (Base_Block)); + New_Procedure_Call (Constr); + end; + when Iir_Kind_Block_Statement => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Elab_Block_Declarations (Stmt, Base_Block); + Pop_Identifier_Prefix (Mark); + end; + when Iir_Kind_Generate_Statement => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + if Get_Kind (Get_Generation_Scheme (Stmt)) + = Iir_Kind_Iterator_Declaration + then + Elab_Iterative_Generate_Statement + (Stmt, Block, Base_Block); + else + Elab_Conditionnal_Generate_Statement + (Stmt, Block, Base_Block); + end if; + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("elab_block_declarations", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Elab_Block_Declarations; + end Chap9; + + package body Chap10 is + -- Identifiers. + -- The following functions are helpers to create ortho identifiers. + Identifier_Buffer : String (1 .. 512); + Identifier_Len : Natural := 0; + Identifier_Start : Natural := 1; + Identifier_Local : Local_Identifier_Type := 0; + + + Inst_Build : Inst_Build_Acc := null; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object => Inst_Build_Type, Name => Inst_Build_Acc); + + procedure Set_Global_Storage (Storage : O_Storage) is + begin + Global_Storage := Storage; + end Set_Global_Storage; + + procedure Pop_Build_Instance + is + Old : Inst_Build_Acc; + begin + Old := Inst_Build; + Identifier_Start := Old.Prev_Id_Start; + Inst_Build := Old.Prev; + Unchecked_Deallocation (Old); + end Pop_Build_Instance; + + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return Scope.Scope_Type; + end Get_Scope_Type; + + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return New_Sizeof (Scope.Scope_Type, Ghdl_Index_Type); + end Get_Scope_Size; + + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean is + begin + return Scope.Scope_Type /= O_Tnode_Null; + end Has_Scope_Type; + + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident) + is + begin + pragma Assert (Scope.Scope_Type = O_Tnode_Null); + New_Uncomplete_Record_Type (Scope.Scope_Type); + New_Type_Decl (Name, Scope.Scope_Type); + end Predeclare_Scope_Type; + + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode) is + begin + Ptr_Type := New_Access_Type (Get_Scope_Type (Scope)); + New_Type_Decl (Name, Ptr_Type); + end Declare_Scope_Acc; + + procedure Push_Instance_Factory (Scope : Var_Scope_Acc) + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null and then Inst_Build.Kind /= Instance then + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Instance); + Inst.Prev := Inst_Build; + Inst.Prev_Id_Start := Identifier_Start; + Inst.Scope := Scope; + + Identifier_Start := Identifier_Len + 1; + + if Scope.Scope_Type /= O_Tnode_Null then + Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements); + else + Start_Record_Type (Inst.Elements); + end if; + Inst_Build := Inst; + end Push_Instance_Factory; + + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode + is + Res : O_Fnode; + begin + New_Record_Field (Inst_Build.Elements, Res, Name, Ftype); + return Res; + end Add_Instance_Factory_Field; + + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type) + is + Field : O_Fnode; + begin + Field := Add_Instance_Factory_Field (Name, Get_Scope_Type (Child)); + Set_Scope_Via_Field (Child, Field, Inst_Build.Scope); + end Add_Scope_Field; + + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode is + begin + return New_Offsetof (Get_Scope_Type (Child.Up_Link.all), + Child.Field, Otype); + end Get_Scope_Offset; + + procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc) + is + Res : O_Tnode; + begin + if Inst_Build.Kind /= Instance then + -- Not matching. + raise Internal_Error; + end if; + Finish_Record_Type (Inst_Build.Elements, Res); + Pop_Build_Instance; + Scope.Scope_Type := Res; + end Pop_Instance_Factory; + + procedure Push_Local_Factory + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null + and then (Inst_Build.Kind /= Global and Inst_Build.Kind /= Local) + then + -- Cannot create a local factory on an instance. + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Kind => Local); + Inst.Prev := Inst_Build; + Inst.Prev_Global_Storage := Global_Storage; + + Inst.Prev_Id_Start := Identifier_Start; + Identifier_Start := Identifier_Len + 1; + + Inst_Build := Inst; + case Global_Storage is + when O_Storage_Public => + Global_Storage := O_Storage_Private; + when O_Storage_Private + | O_Storage_External => + null; + when O_Storage_Local => + raise Internal_Error; + end case; + end Push_Local_Factory; + + -- Return TRUE is the current scope is local. + function Is_Local_Scope return Boolean is + begin + if Inst_Build = null then + return False; + end if; + case Inst_Build.Kind is + when Local + | Instance => + return True; + when Global => + return False; + end case; + end Is_Local_Scope; + + procedure Pop_Local_Factory is + begin + if Inst_Build.Kind /= Local then + -- Not matching. + raise Internal_Error; + end if; + Global_Storage := Inst_Build.Prev_Global_Storage; + Pop_Build_Instance; + end Pop_Local_Factory; + + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field; + + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field_Ptr, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field_Ptr; + + procedure Set_Scope_Via_Var_Ptr + (Scope : in out Var_Scope_Type; Var : Var_Type) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + pragma Assert (Var.Kind = Var_Scope); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field_Ptr, + Field => Var.I_Field, Up_Link => Var.I_Scope); + end Set_Scope_Via_Var_Ptr; + + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Ptr, D => Scope_Param); + end Set_Scope_Via_Param_Ptr; + + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Decl, D => Decl); + end Set_Scope_Via_Decl; + + procedure Clear_Scope (Scope : in out Var_Scope_Type) is + begin + pragma Assert (Scope.Kind /= Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_None); + end Clear_Scope; + + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Type + is + Var : O_Dnode; + begin + New_Var_Decl (Var, Name, Storage, Vtype); + return Var_Type'(Kind => Var_Global, E => Var); + end Create_Global_Var; + + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Type + is + Res : O_Dnode; + begin + New_Const_Decl (Res, Name, Storage, Vtype); + if Storage /= O_Storage_External + and then Initial_Value /= O_Cnode_Null + then + Start_Const_Value (Res); + Finish_Const_Value (Res, Initial_Value); + end if; + return Var_Type'(Kind => Var_Global, E => Res); + end Create_Global_Const; + + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode) is + begin + Start_Const_Value (Const.E); + Finish_Const_Value (Const.E, Val); + end Define_Global_Const; + + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Type + is + Res : O_Dnode; + Field : O_Fnode; + K : Inst_Build_Kind_Type; + begin + if Inst_Build = null then + K := Global; + else + K := Inst_Build.Kind; + end if; + case K is + when Global => + -- The global scope is in use... + return Create_Global_Var (Name.Id, Vtype, Storage); + when Local => + -- It is always possible to create a variable in a local scope. + -- Create a var. + New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype); + return Var_Type'(Kind => Var_Local, E => Res); + when Instance => + -- Create a field. + New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype); + return Var_Type'(Kind => Var_Scope, I_Field => Field, + I_Scope => Inst_Build.Scope); + end case; + end Create_Var; + + -- Get a reference to scope STYPE. If IS_PTR is set, RES is an access + -- to the scope, otherwise RES directly designates the scope. + procedure Find_Scope (Scope : Var_Scope_Type; + Res : out O_Lnode; + Is_Ptr : out Boolean) is + begin + case Scope.Kind is + when Var_Scope_None => + raise Internal_Error; + when Var_Scope_Ptr + | Var_Scope_Decl => + Res := New_Obj (Scope.D); + Is_Ptr := Scope.Kind = Var_Scope_Ptr; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + declare + Parent : O_Lnode; + Parent_Ptr : Boolean; + begin + Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr); + if Parent_Ptr then + Parent := New_Acc_Value (Parent); + end if; + Res := New_Selected_Element (Parent, Scope.Field); + Is_Ptr := Scope.Kind = Var_Scope_Field_Ptr; + end; + end case; + end Find_Scope; + + procedure Check_Not_Building is + begin + -- Variables cannot be referenced if there is an instance being + -- built. + if Inst_Build /= null and then Inst_Build.Kind = Instance then + raise Internal_Error; + end if; + end Check_Not_Building; + + function Get_Instance_Access (Block : Iir) return O_Enode + is + Info : constant Block_Info_Acc := Get_Info (Block); + Res : O_Lnode; + Is_Ptr : Boolean; + begin + Check_Not_Building; + Find_Scope (Info.Block_Scope, Res, Is_Ptr); + if Is_Ptr then + return New_Value (Res); + else + return New_Address (Res, Info.Block_Decls_Ptr_Type); + end if; + end Get_Instance_Access; + + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode + is + Res : O_Lnode; + Is_Ptr : Boolean; + begin + Check_Not_Building; + Find_Scope (Scope, Res, Is_Ptr); + if Is_Ptr then + return New_Acc_Value (Res); + else + return Res; + end if; + end Get_Instance_Ref; + + function Get_Var (Var : Var_Type) return O_Lnode + is + begin + case Var.Kind is + when Var_None => + raise Internal_Error; + when Var_Local + | Var_Global => + return New_Obj (Var.E); + when Var_Scope => + return New_Selected_Element + (Get_Instance_Ref (Var.I_Scope.all), Var.I_Field); + end case; + end Get_Var; + + function Get_Alloc_Kind_For_Var (Var : Var_Type) + return Allocation_Kind is + begin + case Var.Kind is + when Var_Local => + return Alloc_Stack; + when Var_Global + | Var_Scope => + return Alloc_System; + when Var_None => + raise Internal_Error; + end case; + end Get_Alloc_Kind_For_Var; + + function Is_Var_Stable (Var : Var_Type) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return True; + when Var_Scope => + return False; + when Var_None => + raise Internal_Error; + end case; + end Is_Var_Stable; + + function Is_Var_Field (Var : Var_Type) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return False; + when Var_Scope => + return True; + when Var_None => + raise Internal_Error; + end case; + end Is_Var_Field; + + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode + is + begin + return New_Offsetof (Get_Scope_Type (Var.I_Scope.all), + Var.I_Field, Otype); + end Get_Var_Offset; + + function Get_Var_Label (Var : Var_Type) return O_Dnode is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return Var.E; + when Var_Scope + | Var_None => + raise Internal_Error; + end case; + end Get_Var_Label; + + procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is + begin + Id := Identifier_Local; + end Save_Local_Identifier; + + procedure Restore_Local_Identifier (Id : Local_Identifier_Type) is + begin + if Identifier_Local > Id then + -- If the value is restored with a smaller value, some identifiers + -- will be reused. This is certainly an internal error. + raise Internal_Error; + end if; + Identifier_Local := Id; + end Restore_Local_Identifier; + + -- Reset the identifier. + procedure Reset_Identifier_Prefix is + begin + if Identifier_Len /= 0 or else Identifier_Local /= 0 then + raise Internal_Error; + end if; + end Reset_Identifier_Prefix; + + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is + begin + Identifier_Len := Mark.Len; + Identifier_Local := Mark.Local_Id; + end Pop_Identifier_Prefix; + + procedure Add_String (Len : in out Natural; Str : String) is + begin + Identifier_Buffer (Len + 1 .. Len + Str'Length) := Str; + Len := Len + Str'Length; + end Add_String; + + procedure Add_Nat (Len : in out Natural; Val : Natural) + is + Num : String (1 .. 10); + V : Natural; + P : Natural; + begin + P := Num'Last; + V := Val; + loop + Num (P) := Character'Val (Character'Pos ('0') + V mod 10); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + Add_String (Len, Num (P .. Num'Last)); + end Add_Nat; + + -- Convert name_id NAME to a string stored to + -- NAME_BUFFER (1 .. NAME_LENGTH). + -- + -- This encodes extended identifiers. + -- + -- Extended identifier encoding: + -- They start with 'X'. + -- Non extended character [0-9a-zA-Z] are left as is, + -- others are encoded to _XX, where XX is the character position in hex. + -- They finish with "__". + procedure Name_Id_To_String (Name : Name_Id) + is + use Name_Table; + + type Bool_Array_Type is array (Character) of Boolean; + pragma Pack (Bool_Array_Type); + Is_Extended_Char : constant Bool_Array_Type := + ('0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' => False, + others => True); + + N_Len : Natural; + P : Natural; + C : Character; + begin + if Is_Character (Name) then + P := Character'Pos (Name_Table.Get_Character (Name)); + Name_Buffer (1) := 'C'; + Name_Buffer (2) := N2hex (P / 16); + Name_Buffer (3) := N2hex (P mod 16); + Name_Length := 3; + return; + else + Image (Name); + end if; + if Name_Buffer (1) /= '\' then + return; + end if; + -- Extended identifier. + -- Supress trailing backslash. + Name_Length := Name_Length - 1; + + -- Count number of characters in the extended string. + N_Len := Name_Length; + for I in 2 .. Name_Length loop + if Is_Extended_Char (Name_Buffer (I)) then + N_Len := N_Len + 2; + end if; + end loop; + + -- Convert. + Name_Buffer (1) := 'X'; + P := N_Len; + for J in reverse 2 .. Name_Length loop + C := Name_Buffer (J); + if Is_Extended_Char (C) then + Name_Buffer (P - 0) := N2hex (Character'Pos (C) mod 16); + Name_Buffer (P - 1) := N2hex (Character'Pos (C) / 16); + Name_Buffer (P - 2) := '_'; + P := P - 3; + else + Name_Buffer (P) := C; + P := P - 1; + end if; + end loop; + Name_Buffer (N_Len + 1) := '_'; + Name_Buffer (N_Len + 2) := '_'; + Name_Length := N_Len + 2; + end Name_Id_To_String; + + procedure Add_Name (Len : in out Natural; Name : Name_Id) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Add_String (Len, Name_Buffer (1 .. Name_Length)); + end Add_Name; + + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0) + is + P : Natural; + begin + Mark.Len := Identifier_Len; + Mark.Local_Id := Identifier_Local; + Identifier_Local := 0; + P := Identifier_Len; + Add_String (P, Name); + if Val > 0 then + Add_String (P, "O"); + Add_Nat (P, Natural (Val)); + end if; + Add_String (P, "__"); + Identifier_Len := P; + end Push_Identifier_Prefix; + + -- Add a suffix to the prefix (!!!). + procedure Push_Identifier_Prefix + (Mark : out Id_Mark_Type; Name : Name_Id; Val : Iir_Int32 := 0) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Push_Identifier_Prefix (Mark, Name_Buffer (1 .. Name_Length), Val); + end Push_Identifier_Prefix; + + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type) + is + Str : String := Local_Identifier_Type'Image (Identifier_Local); + begin + Identifier_Local := Identifier_Local + 1; + Str (1) := 'U'; + Push_Identifier_Prefix (Mark, Str, 0); + end Push_Identifier_Prefix_Uniq; + + procedure Add_Identifier (Len : in out Natural; Id : Name_Id) is + begin + if Id /= Null_Identifier then + Add_Name (Len, Id); + end if; + end Add_Identifier; + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Get_Identifier (Id)); + return Get_Identifier (Name_Buffer (1 .. Name_Length)); + end Create_Identifier_Without_Prefix; + + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Id); + Name_Buffer (Name_Length + 1 .. Name_Length + Str'Length) := Str; + return Get_Identifier (Name_Buffer (1 .. Name_Length + Str'Length)); + end Create_Identifier_Without_Prefix; + + -- Create an identifier from IIR node ID with prefix. + function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean) + return O_Ident + is + L : Natural; + begin + L := Identifier_Len; + Add_Identifier (L, Id); + Add_String (L, Str); + --Identifier_Buffer (L + Str'Length + 1) := Nul; + if Is_Local then + return Get_Identifier + (Identifier_Buffer (Identifier_Start .. L)); + else + return Get_Identifier (Identifier_Buffer (1 .. L)); + end if; + end Create_Id; + + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident + is + begin + return Create_Id (Id, Str, False); + end Create_Identifier; + + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident + is + begin + return Create_Id (Get_Identifier (Id), Str, False); + end Create_Identifier; + + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_Identifier (Len, Get_Identifier (Id)); + + if Val > 0 then + Add_String (Len, "O"); + Add_Nat (Len, Natural (Val)); + end if; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier (Str : String) + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier return O_Ident + is + begin + return Get_Identifier (Identifier_Buffer (1 .. Identifier_Len - 2)); + end Create_Identifier; + + function Create_Var_Identifier_From_Buffer (L : Natural) + return Var_Ident_Type + is + Start : Natural; + begin + if Is_Local_Scope then + Start := Identifier_Start; + else + Start := 1; + end if; + return (Id => Get_Identifier (Identifier_Buffer (Start .. L))); + end Create_Var_Identifier_From_Buffer; + + function Create_Var_Identifier (Id : Iir) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_Identifier (L, Get_Identifier (Id)); + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Var_Identifier (Id : String) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_String (L, Id); + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_Identifier (L, Get_Identifier (Id)); + Add_String (L, Str); + if Val > 0 then + Add_String (L, "O"); + Add_Nat (L, Val); + end if; + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Uniq_Identifier return Var_Ident_Type + is + Res : Var_Ident_Type; + begin + Res.Id := Create_Uniq_Identifier; + return Res; + end Create_Uniq_Identifier; + + type Instantiate_Var_Stack; + type Instantiate_Var_Stack_Acc is access Instantiate_Var_Stack; + + type Instantiate_Var_Stack is record + Orig_Scope : Var_Scope_Acc; + Inst_Scope : Var_Scope_Acc; + Prev : Instantiate_Var_Stack_Acc; + end record; + + Top_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; + Free_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; + + procedure Push_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc) + is + Inst : Instantiate_Var_Stack_Acc; + begin + if Free_Instantiate_Var_Stack = null then + Inst := new Instantiate_Var_Stack; + else + Inst := Free_Instantiate_Var_Stack; + Free_Instantiate_Var_Stack := Inst.Prev; + end if; + Inst.all := (Orig_Scope => Orig_Scope, + Inst_Scope => Inst_Scope, + Prev => Top_Instantiate_Var_Stack); + Top_Instantiate_Var_Stack := Inst; + end Push_Instantiate_Var_Scope; + + procedure Pop_Instantiate_Var_Scope (Inst_Scope : Var_Scope_Acc) + is + Item : constant Instantiate_Var_Stack_Acc := + Top_Instantiate_Var_Stack; + begin + pragma Assert (Item /= null); + pragma Assert (Item.Inst_Scope = Inst_Scope); + Top_Instantiate_Var_Stack := Item.Prev; + Item.all := (Orig_Scope => null, + Inst_Scope => null, + Prev => Free_Instantiate_Var_Stack); + Free_Instantiate_Var_Stack := Item; + end Pop_Instantiate_Var_Scope; + + function Instantiated_Var_Scope (Scope : Var_Scope_Acc) + return Var_Scope_Acc + is + Item : Instantiate_Var_Stack_Acc; + begin + if Scope = null then + return null; + end if; + + Item := Top_Instantiate_Var_Stack; + loop + pragma Assert (Item /= null); + if Item.Orig_Scope = Scope then + return Item.Inst_Scope; + end if; + Item := Item.Prev; + end loop; + end Instantiated_Var_Scope; + + function Instantiate_Var (Var : Var_Type) return Var_Type is + begin + case Var.Kind is + when Var_None + | Var_Global + | Var_Local => + return Var; + when Var_Scope => + return Var_Type' + (Kind => Var_Scope, + I_Field => Var.I_Field, + I_Scope => Instantiated_Var_Scope (Var.I_Scope)); + end case; + end Instantiate_Var; + + function Instantiate_Var_Scope (Scope : Var_Scope_Type) + return Var_Scope_Type is + begin + case Scope.Kind is + when Var_Scope_None + | Var_Scope_Ptr + | Var_Scope_Decl => + return Scope; + when Var_Scope_Field => + return Var_Scope_Type' + (Kind => Var_Scope_Field, + Scope_Type => Scope.Scope_Type, + Field => Scope.Field, + Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); + when Var_Scope_Field_Ptr => + return Var_Scope_Type' + (Kind => Var_Scope_Field_Ptr, + Scope_Type => Scope.Scope_Type, + Field => Scope.Field, + Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); + end case; + end Instantiate_Var_Scope; + end Chap10; + + package body Chap14 is + function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode + is + Prefix : constant Iir := Get_Prefix (Expr); + Type_Name : constant Iir := Is_Type_Name (Prefix); + Arr : Mnode; + Dim : Natural; + begin + if Type_Name /= Null_Iir then + -- Prefix denotes a type name + Arr := T2M (Type_Name, Mode_Value); + else + -- Prefix is an object. + Arr := Chap6.Translate_Name (Prefix); + end if; + Dim := Natural (Get_Value (Get_Parameter (Expr))); + return Chap3.Get_Array_Range (Arr, Get_Type (Prefix), Dim); + end Translate_Array_Attribute_To_Range; + + function Translate_Range_Array_Attribute (Expr : Iir) + return O_Lnode is + begin + return M2Lv (Translate_Array_Attribute_To_Range (Expr)); + end Translate_Range_Array_Attribute; + + function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) + return O_Enode + is + Rng : Mnode; + Val : O_Enode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + Val := M2E (Chap3.Range_To_Length (Rng)); + if Rtype /= Null_Iir then + Val := New_Convert_Ov (Val, Get_Ortho_Type (Rtype, Mode_Value)); + end if; + return Val; + end Translate_Length_Array_Attribute; + + -- Extract high or low bound of RANGE_VAR. + function Range_To_High_Low + (Range_Var : Mnode; Range_Type : Iir; Is_High : Boolean) + return Mnode + is + Op : ON_Op_Kind; + If_Blk : O_If_Block; + Range_Svar : constant Mnode := Stabilize (Range_Var); + Res : O_Dnode; + Tinfo : constant Ortho_Info_Acc := + Get_Info (Get_Base_Type (Range_Type)); + begin + Res := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + Open_Temp; + if Is_High then + Op := ON_Neq; + else + Op := ON_Eq; + end if; + Start_If_Stmt (If_Blk, + New_Compare_Op (Op, + M2E (Chap3.Range_To_Dir (Range_Svar)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Left (Range_Svar))); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Right (Range_Svar))); + Finish_If_Stmt (If_Blk); + Close_Temp; + return Dv2M (Res, Tinfo, Mode_Value); + end Range_To_High_Low; + + function Translate_High_Low_Type_Attribute + (Atype : Iir; Is_High : Boolean) return O_Enode + is + Cons : constant Iir := Get_Range_Constraint (Atype); + begin + -- FIXME: improve code if constraint is a range expression. + if Get_Type_Staticness (Atype) = Locally then + if Get_Direction (Cons) = Iir_To xor Is_High then + return New_Lit + (Chap7.Translate_Static_Range_Left (Cons, Atype)); + else + return New_Lit + (Chap7.Translate_Static_Range_Right (Cons, Atype)); + end if; + else + return M2E (Range_To_High_Low + (Chap3.Type_To_Range (Atype), Atype, Is_High)); + end if; + end Translate_High_Low_Type_Attribute; + + function Translate_High_Low_Array_Attribute (Expr : Iir; + Is_High : Boolean) + return O_Enode + is + begin + -- FIXME: improve code if index is a range expression. + return M2E (Range_To_High_Low + (Translate_Array_Attribute_To_Range (Expr), + Get_Type (Expr), Is_High)); + end Translate_High_Low_Array_Attribute; + + function Translate_Low_Array_Attribute (Expr : Iir) + return O_Enode + is + begin + return Translate_High_Low_Array_Attribute (Expr, False); + end Translate_Low_Array_Attribute; + + function Translate_High_Array_Attribute (Expr : Iir) + return O_Enode + is + begin + return Translate_High_Low_Array_Attribute (Expr, True); + end Translate_High_Array_Attribute; + + function Translate_Left_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return M2E (Chap3.Range_To_Left (Rng)); + end Translate_Left_Array_Attribute; + + function Translate_Right_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return M2E (Chap3.Range_To_Right (Rng)); + end Translate_Right_Array_Attribute; + + function Translate_Ascending_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Lit (Ghdl_Dir_To_Node), + Std_Boolean_Type_Node); + end Translate_Ascending_Array_Attribute; + + function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode is + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Left + (Get_Range_Constraint (Atype), Atype)); + else + return M2E (Chap3.Range_To_Left (Chap3.Type_To_Range (Atype))); + end if; + end Translate_Left_Type_Attribute; + + function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode is + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Right + (Get_Range_Constraint (Atype), Atype)); + else + return M2E (Chap3.Range_To_Right (Chap3.Type_To_Range (Atype))); + end if; + end Translate_Right_Type_Attribute; + + function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode + is + Info : Type_Info_Acc; + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Dir + (Get_Range_Constraint (Atype))); + else + Info := Get_Info (Atype); + return New_Value + (New_Selected_Element (Get_Var (Info.T.Range_Var), + Info.T.Range_Dir)); + end if; + end Translate_Dir_Type_Attribute; + + function Translate_Val_Attribute (Attr : Iir) return O_Enode + is + Val : O_Enode; + Attr_Type : Iir; + Res_Var : O_Dnode; + Res_Type : O_Tnode; + begin + Attr_Type := Get_Type (Attr); + Res_Type := Get_Ortho_Type (Attr_Type, Mode_Value); + Res_Var := Create_Temp (Res_Type); + Val := Chap7.Translate_Expression (Get_Parameter (Attr)); + + case Get_Kind (Attr_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + -- For enumeration, always check the value is in the enum + -- range. + declare + Val_Type : O_Tnode; + Val_Var : O_Dnode; + If_Blk : O_If_Block; + begin + Val_Type := Get_Ortho_Type (Get_Type (Get_Parameter (Attr)), + Mode_Value); + Val_Var := Create_Temp_Init (Val_Type, Val); + Start_If_Stmt + (If_Blk, + New_Dyadic_Op + (ON_Or, + New_Compare_Op (ON_Lt, + New_Obj_Value (Val_Var), + New_Lit (New_Signed_Literal + (Val_Type, 0)), + Ghdl_Bool_Type), + New_Compare_Op (ON_Ge, + New_Obj_Value (Val_Var), + New_Lit (New_Signed_Literal + (Val_Type, + Integer_64 + (Get_Nbr_Elements + (Get_Enumeration_Literal_List + (Attr_Type))))), + Ghdl_Bool_Type))); + Chap6.Gen_Bound_Error (Attr); + Finish_If_Stmt (If_Blk); + Val := New_Obj_Value (Val_Var); + end; + when others => + null; + end case; + + New_Assign_Stmt (New_Obj (Res_Var), New_Convert_Ov (Val, Res_Type)); + Chap3.Check_Range + (Res_Var, Attr, Get_Type (Get_Prefix (Attr)), Attr); + return New_Obj_Value (Res_Var); + end Translate_Val_Attribute; + + function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) + return O_Enode + is + T : O_Dnode; + Ttype : O_Tnode; + begin + Ttype := Get_Ortho_Type (Res_Type, Mode_Value); + T := Create_Temp (Ttype); + New_Assign_Stmt + (New_Obj (T), + New_Convert_Ov (Chap7.Translate_Expression (Get_Parameter (Attr)), + Ttype)); + Chap3.Check_Range (T, Attr, Res_Type, Attr); + return New_Obj_Value (T); + end Translate_Pos_Attribute; + + function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode + is + Expr_Type : Iir; + Tinfo : Type_Info_Acc; + Ttype : O_Tnode; + Expr : O_Enode; + List : Iir_List; + Limit : Iir; + Is_Succ : Boolean; + Op : ON_Op_Kind; + begin + -- FIXME: should check bounds. + Expr_Type := Get_Type (Attr); + Tinfo := Get_Info (Expr_Type); + Expr := Chap7.Translate_Expression (Get_Parameter (Attr), Expr_Type); + Ttype := Tinfo.Ortho_Type (Mode_Value); + Is_Succ := Get_Kind (Attr) = Iir_Kind_Succ_Attribute; + if Is_Succ then + Op := ON_Add_Ov; + else + Op := ON_Sub_Ov; + end if; + case Tinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 => + -- Should check it is not the last. + declare + L : O_Dnode; + begin + List := Get_Enumeration_Literal_List (Get_Base_Type + (Expr_Type)); + L := Create_Temp_Init (Ttype, Expr); + if Is_Succ then + Limit := Get_Last_Element (List); + else + Limit := Get_First_Element (List); + end if; + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Eq, + New_Obj_Value (L), + New_Lit (Get_Ortho_Expr (Limit)), + Ghdl_Bool_Type), + Attr, 0); + return New_Convert_Ov + (New_Dyadic_Op + (Op, + New_Convert_Ov (New_Obj_Value (L), Ghdl_I32_Type), + New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1))), + Ttype); + end; + when Type_Mode_I32 + | Type_Mode_P64 => + return New_Dyadic_Op + (Op, Expr, New_Lit (New_Signed_Literal (Ttype, 1))); + when others => + raise Internal_Error; + end case; + end Translate_Succ_Pred_Attribute; + + type Bool_Sigattr_Data_Type is record + Label : O_Snode; + Field : O_Fnode; + end record; + + procedure Bool_Sigattr_Non_Composite_Signal + (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) + is + pragma Unreferenced (Targ_Type); + begin + Gen_Exit_When (Data.Label, + New_Value (Get_Signal_Field (Targ, Data.Field))); + end Bool_Sigattr_Non_Composite_Signal; + + function Bool_Sigattr_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Bool_Sigattr_Prepare_Data_Composite; + + function Bool_Sigattr_Update_Data_Array (Data : Bool_Sigattr_Data_Type; + Targ_Type : Iir; + Index : O_Dnode) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ_Type, Index); + begin + return Data; + end Bool_Sigattr_Update_Data_Array; + + function Bool_Sigattr_Update_Data_Record (Data : Bool_Sigattr_Data_Type; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ_Type, El); + begin + return Data; + end Bool_Sigattr_Update_Data_Record; + + procedure Bool_Sigattr_Finish_Data_Composite + (Data : in out Bool_Sigattr_Data_Type) + is + pragma Unreferenced (Data); + begin + null; + end Bool_Sigattr_Finish_Data_Composite; + + procedure Bool_Sigattr_Foreach is new Foreach_Non_Composite + (Data_Type => Bool_Sigattr_Data_Type, + Composite_Data_Type => Bool_Sigattr_Data_Type, + Do_Non_Composite => Bool_Sigattr_Non_Composite_Signal, + Prepare_Data_Array => Bool_Sigattr_Prepare_Data_Composite, + Update_Data_Array => Bool_Sigattr_Update_Data_Array, + Finish_Data_Array => Bool_Sigattr_Finish_Data_Composite, + Prepare_Data_Record => Bool_Sigattr_Prepare_Data_Composite, + Update_Data_Record => Bool_Sigattr_Update_Data_Record, + Finish_Data_Record => Bool_Sigattr_Finish_Data_Composite); + + function Translate_Bool_Signal_Attribute (Attr : Iir; Field : O_Fnode) + return O_Enode + is + Data : Bool_Sigattr_Data_Type; + Res : O_Dnode; + Name : Mnode; + Prefix : constant Iir := Get_Prefix (Attr); + Prefix_Type : constant Iir := Get_Type (Prefix); + begin + if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then + -- Effecient handling for a scalar signal. + Name := Chap6.Translate_Name (Prefix); + return New_Value (Get_Signal_Field (Name, Field)); + else + -- Element per element handling for composite signals. + Res := Create_Temp (Std_Boolean_Type_Node); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); + Name := Chap6.Translate_Name (Prefix); + Start_Loop_Stmt (Data.Label); + Data.Field := Field; + Bool_Sigattr_Foreach (Name, Prefix_Type, Data); + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); + New_Exit_Stmt (Data.Label); + Finish_Loop_Stmt (Data.Label); + Close_Temp; + return New_Obj_Value (Res); + end if; + end Translate_Bool_Signal_Attribute; + + function Translate_Event_Attribute (Attr : Iir) return O_Enode is + begin + return Translate_Bool_Signal_Attribute + (Attr, Ghdl_Signal_Event_Field); + end Translate_Event_Attribute; + + function Translate_Active_Attribute (Attr : Iir) return O_Enode is + begin + return Translate_Bool_Signal_Attribute + (Attr, Ghdl_Signal_Active_Field); + end Translate_Active_Attribute; + + -- Read signal value FIELD of signal SIG. + function Get_Signal_Value_Field + (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) + return O_Lnode + is + S_Type : O_Tnode; + T : O_Lnode; + begin + S_Type := Get_Ortho_Type (Sig_Type, Mode_Signal); + T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Access_Element + (New_Unchecked_Address (New_Selected_Element (T, Field), S_Type)); + end Get_Signal_Value_Field; + + function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) + return O_Lnode + is + S : O_Enode; + begin + S := New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr); + return New_Selected_Element (New_Access_Element (S), Field); + end Get_Signal_Field; + + function Read_Last_Value (Sig : O_Enode; Sig_Type : Iir) return O_Enode + is + begin + return New_Value (Get_Signal_Value_Field + (Sig, Sig_Type, Ghdl_Signal_Last_Value_Field)); + end Read_Last_Value; + + function Translate_Last_Value is new Chap7.Translate_Signal_Value + (Read_Value => Read_Last_Value); + + function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode + is + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + Name := Chap6.Translate_Name (Prefix); + if Get_Object_Kind (Name) /= Mode_Signal then + raise Internal_Error; + end if; + return Translate_Last_Value (M2E (Name), Prefix_Type); + end Translate_Last_Value_Attribute; + + function Read_Last_Time (Sig : O_Enode; Field : O_Fnode) return O_Enode + is + T : O_Lnode; + begin + T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Value (New_Selected_Element (T, Field)); + end Read_Last_Time; + + type Last_Time_Data is record + Var : O_Dnode; + Field : O_Fnode; + end record; + + procedure Translate_Last_Time_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) + is + pragma Unreferenced (Targ_Type); + Val : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + Val := Create_Temp_Init + (Std_Time_Otype, + Read_Last_Time (New_Value (M2Lv (Targ)), Data.Field)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Gt, + New_Obj_Value (Val), + New_Obj_Value (Data.Var), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Data.Var), New_Obj_Value (Val)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end Translate_Last_Time_Non_Composite; + + function Last_Time_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) + return Last_Time_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Last_Time_Prepare_Data_Composite; + + function Last_Time_Update_Data_Array (Data : Last_Time_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Last_Time_Data + is + pragma Unreferenced (Targ_Type, Index); + begin + return Data; + end Last_Time_Update_Data_Array; + + function Last_Time_Update_Data_Record (Data : Last_Time_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Last_Time_Data + is + pragma Unreferenced (Targ_Type, El); + begin + return Data; + end Last_Time_Update_Data_Record; + + procedure Last_Time_Finish_Data_Composite + (Data : in out Last_Time_Data) + is + pragma Unreferenced (Data); + begin + null; + end Last_Time_Finish_Data_Composite; + + procedure Translate_Last_Time is new Foreach_Non_Composite + (Data_Type => Last_Time_Data, + Composite_Data_Type => Last_Time_Data, + Do_Non_Composite => Translate_Last_Time_Non_Composite, + Prepare_Data_Array => Last_Time_Prepare_Data_Composite, + Update_Data_Array => Last_Time_Update_Data_Array, + Finish_Data_Array => Last_Time_Finish_Data_Composite, + Prepare_Data_Record => Last_Time_Prepare_Data_Composite, + Update_Data_Record => Last_Time_Update_Data_Record, + Finish_Data_Record => Last_Time_Finish_Data_Composite); + + function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) + return O_Enode + is + Prefix_Type : Iir; + Name : Mnode; + Info : Type_Info_Acc; + Var : O_Dnode; + Data : Last_Time_Data; + Right_Bound : Iir_Int64; + If_Blk : O_If_Block; + begin + Prefix_Type := Get_Type (Prefix); + Name := Chap6.Translate_Name (Prefix); + Info := Get_Info (Prefix_Type); + Var := Create_Temp (Std_Time_Otype); + + if Info.Type_Mode in Type_Mode_Scalar then + New_Assign_Stmt (New_Obj (Var), + Read_Last_Time (M2E (Name), Field)); + else + -- Init with a negative value. + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Signed_Literal (Std_Time_Otype, -1))); + Data := Last_Time_Data'(Var => Var, Field => Field); + Translate_Last_Time (Name, Prefix_Type, Data); + end if; + + Right_Bound := Get_Value + (Get_Right_Limit (Get_Range_Constraint (Time_Subtype_Definition))); + + -- VAR < 0 ? + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Lt, + New_Obj_Value (Var), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0)), + Ghdl_Bool_Type)); + -- LRM 14.1 Predefined attributes + -- [...]; otherwise, it returns TIME'HIGH. + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Signed_Literal + (Std_Time_Otype, Integer_64 (Right_Bound)))); + New_Else_Stmt (If_Blk); + -- Returns NOW - Var. + New_Assign_Stmt (New_Obj (Var), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Ghdl_Now), + New_Obj_Value (Var))); + Finish_If_Stmt (If_Blk); + return New_Obj_Value (Var); + end Translate_Last_Time_Attribute; + + -- Return TRUE if the scalar signal SIG is being driven. + function Read_Driving_Attribute (Sig : O_Enode) return O_Enode + is + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Driving); + New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Function_Call (Assoc); + end Read_Driving_Attribute; + + procedure Driving_Non_Composite_Signal + (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) + is + pragma Unreferenced (Targ_Type); + begin + Gen_Exit_When + (Label, + New_Monadic_Op + (ON_Not, Read_Driving_Attribute (New_Value (M2Lv (Targ))))); + end Driving_Non_Composite_Signal; + + function Driving_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) + return O_Snode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Label; + end Driving_Prepare_Data_Composite; + + function Driving_Update_Data_Array (Label : O_Snode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Snode + is + pragma Unreferenced (Targ_Type, Index); + begin + return Label; + end Driving_Update_Data_Array; + + function Driving_Update_Data_Record (Label : O_Snode; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return O_Snode + is + pragma Unreferenced (Targ_Type, El); + begin + return Label; + end Driving_Update_Data_Record; + + procedure Driving_Finish_Data_Composite (Label : in out O_Snode) + is + pragma Unreferenced (Label); + begin + null; + end Driving_Finish_Data_Composite; + + procedure Driving_Foreach is new Foreach_Non_Composite + (Data_Type => O_Snode, + Composite_Data_Type => O_Snode, + Do_Non_Composite => Driving_Non_Composite_Signal, + Prepare_Data_Array => Driving_Prepare_Data_Composite, + Update_Data_Array => Driving_Update_Data_Array, + Finish_Data_Array => Driving_Finish_Data_Composite, + Prepare_Data_Record => Driving_Prepare_Data_Composite, + Update_Data_Record => Driving_Update_Data_Record, + Finish_Data_Record => Driving_Finish_Data_Composite); + + function Translate_Driving_Attribute (Attr : Iir) return O_Enode + is + Label : O_Snode; + Res : O_Dnode; + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then + -- Effecient handling for a scalar signal. + Name := Chap6.Translate_Name (Prefix); + return Read_Driving_Attribute (New_Value (M2Lv (Name))); + else + -- Element per element handling for composite signals. + Res := Create_Temp (Std_Boolean_Type_Node); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); + Name := Chap6.Translate_Name (Prefix); + Start_Loop_Stmt (Label); + Driving_Foreach (Name, Prefix_Type, Label); + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); + New_Exit_Stmt (Label); + Finish_Loop_Stmt (Label); + Close_Temp; + return New_Obj_Value (Res); + end if; + end Translate_Driving_Attribute; + + function Read_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + Tinfo : Type_Info_Acc; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + begin + Tinfo := Get_Info (Sig_Type); + case Tinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Driving_Value_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Driving_Value_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Driving_Value_E32; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Driving_Value_I32; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Driving_Value_I64; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Driving_Value_F64; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Convert_Ov (New_Function_Call (Assoc), + Tinfo.Ortho_Type (Mode_Value)); + end Read_Driving_Value; + + function Translate_Driving_Value is new Chap7.Translate_Signal_Value + (Read_Value => Read_Driving_Value); + + function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode + is + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + Name := Chap6.Translate_Name (Prefix); + if Get_Object_Kind (Name) /= Mode_Signal then + raise Internal_Error; + end if; + return Translate_Driving_Value (M2E (Name), Prefix_Type); + end Translate_Driving_Value_Attribute; + + function Translate_Image_Attribute (Attr : Iir) return O_Enode + is + Prefix_Type : constant Iir := + Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); + Res : O_Dnode; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + Conv : O_Tnode; + begin + Res := Create_Temp (Std_String_Node); + Create_Temp_Stack2_Mark; + case Pinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Image_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Image_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Image_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 => + Subprg := Ghdl_Image_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P32 => + Subprg := Ghdl_Image_P32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_Image_P64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Image_F64; + Conv := Ghdl_Real_Type; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association (Assoc, + New_Address (New_Obj (Res), Std_String_Ptr_Node)); + New_Association + (Assoc, + New_Convert_Ov + (Chap7.Translate_Expression (Get_Parameter (Attr), Prefix_Type), + Conv)); + case Pinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 + | Type_Mode_P32 + | Type_Mode_P64 => + New_Association + (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + when Type_Mode_I32 + | Type_Mode_F64 => + null; + when others => + raise Internal_Error; + end case; + New_Procedure_Call (Assoc); + return New_Address (New_Obj (Res), Std_String_Ptr_Node); + end Translate_Image_Attribute; + + function Translate_Value_Attribute (Attr : Iir) return O_Enode + is + Prefix_Type : constant Iir := + Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); + Subprg : O_Dnode; + Assoc : O_Assoc_List; + begin + case Pinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Value_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Value_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Value_E32; + when Type_Mode_I32 => + Subprg := Ghdl_Value_I32; + when Type_Mode_P32 => + Subprg := Ghdl_Value_P32; + when Type_Mode_P64 => + Subprg := Ghdl_Value_P64; + when Type_Mode_F64 => + Subprg := Ghdl_Value_F64; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association + (Assoc, + Chap7.Translate_Expression (Get_Parameter (Attr), + String_Type_Definition)); + case Pinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 + | Type_Mode_P32 + | Type_Mode_P64 => + New_Association + (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + when Type_Mode_I32 + | Type_Mode_F64 => + null; + when others => + raise Internal_Error; + end case; + return New_Convert_Ov (New_Function_Call (Assoc), + Pinfo.Ortho_Type (Mode_Value)); + end Translate_Value_Attribute; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode + is + Name : constant Path_Instance_Name_Type := + Get_Path_Instance_Name_Suffix (Attr); + Res : O_Dnode; + Name_Cst : O_Dnode; + Str_Cst : O_Cnode; + Constr : O_Assoc_List; + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + Create_Temp_Stack2_Mark; + + Res := Create_Temp (Std_String_Node); + Str_Cst := Create_String_Len (Name.Suffix, Create_Uniq_Identifier); + New_Const_Decl (Name_Cst, Create_Uniq_Identifier, O_Storage_Private, + Ghdl_Str_Len_Type_Node); + Start_Const_Value (Name_Cst); + Finish_Const_Value (Name_Cst, Str_Cst); + if Is_Instance then + Start_Association (Constr, Ghdl_Get_Instance_Name); + else + Start_Association (Constr, Ghdl_Get_Path_Name); + end if; + New_Association + (Constr, New_Address (New_Obj (Res), Std_String_Ptr_Node)); + if Name.Path_Instance = Null_Iir then + Rtis.Associate_Null_Rti_Context (Constr); + else + Rtis.Associate_Rti_Context (Constr, Name.Path_Instance); + end if; + New_Association (Constr, + New_Address (New_Obj (Name_Cst), + Ghdl_Str_Len_Ptr_Node)); + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), Std_String_Ptr_Node); + end Translate_Path_Instance_Name_Attribute; + end Chap14; + + package body Rtis is + -- Node for package, body, entity, architecture, block, generate, + -- processes. + Ghdl_Rtin_Block : O_Tnode; + Ghdl_Rtin_Block_Common : O_Fnode; + Ghdl_Rtin_Block_Name : O_Fnode; + Ghdl_Rtin_Block_Loc : O_Fnode; + Ghdl_Rtin_Block_Parent : O_Fnode; + Ghdl_Rtin_Block_Size : O_Fnode; + Ghdl_Rtin_Block_Nbr_Child : O_Fnode; + Ghdl_Rtin_Block_Children : O_Fnode; + + -- Node for scalar type decls. + Ghdl_Rtin_Type_Scalar : O_Tnode; + Ghdl_Rtin_Type_Scalar_Common : O_Fnode; + Ghdl_Rtin_Type_Scalar_Name : O_Fnode; + + -- Node for an enumeration type definition. + Ghdl_Rtin_Type_Enum : O_Tnode; + Ghdl_Rtin_Type_Enum_Common : O_Fnode; + Ghdl_Rtin_Type_Enum_Name : O_Fnode; + Ghdl_Rtin_Type_Enum_Nbr : O_Fnode; + Ghdl_Rtin_Type_Enum_Lits : O_Fnode; + + -- Node for an unit64. + Ghdl_Rtin_Unit64 : O_Tnode; + Ghdl_Rtin_Unit64_Common : O_Fnode; + Ghdl_Rtin_Unit64_Name : O_Fnode; + Ghdl_Rtin_Unit64_Value : O_Fnode; + + -- Node for an unitptr. + Ghdl_Rtin_Unitptr : O_Tnode; + Ghdl_Rtin_Unitptr_Common : O_Fnode; + Ghdl_Rtin_Unitptr_Name : O_Fnode; + Ghdl_Rtin_Unitptr_Value : O_Fnode; + + -- Node for a physical type + Ghdl_Rtin_Type_Physical : O_Tnode; + Ghdl_Rtin_Type_Physical_Common : O_Fnode; + Ghdl_Rtin_Type_Physical_Name : O_Fnode; + Ghdl_Rtin_Type_Physical_Nbr : O_Fnode; + Ghdl_Rtin_Type_Physical_Units : O_Fnode; + + -- Node for a scalar subtype definition. + Ghdl_Rtin_Subtype_Scalar : O_Tnode; + Ghdl_Rtin_Subtype_Scalar_Common : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Name : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Base : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Range : O_Fnode; + + -- Node for an access or a file type. + Ghdl_Rtin_Type_Fileacc : O_Tnode; + Ghdl_Rtin_Type_Fileacc_Common : O_Fnode; + Ghdl_Rtin_Type_Fileacc_Name : O_Fnode; + Ghdl_Rtin_Type_Fileacc_Base : O_Fnode; + + -- Node for an array type. + Ghdl_Rtin_Type_Array : O_Tnode; + Ghdl_Rtin_Type_Array_Common : O_Fnode; + Ghdl_Rtin_Type_Array_Name : O_Fnode; + Ghdl_Rtin_Type_Array_Element : O_Fnode; + Ghdl_Rtin_Type_Array_Nbrdim : O_Fnode; + Ghdl_Rtin_Type_Array_Indexes : O_Fnode; + + -- Node for an array subtype. + Ghdl_Rtin_Subtype_Array : O_Tnode; + Ghdl_Rtin_Subtype_Array_Common : O_Fnode; + Ghdl_Rtin_Subtype_Array_Name : O_Fnode; + Ghdl_Rtin_Subtype_Array_Basetype : O_Fnode; + Ghdl_Rtin_Subtype_Array_Bounds : O_Fnode; + Ghdl_Rtin_Subtype_Array_Valsize : O_Fnode; + Ghdl_Rtin_Subtype_Array_Sigsize : O_Fnode; + + -- Node for a record element. + Ghdl_Rtin_Element : O_Tnode; + Ghdl_Rtin_Element_Common : O_Fnode; + Ghdl_Rtin_Element_Name : O_Fnode; + Ghdl_Rtin_Element_Type : O_Fnode; + Ghdl_Rtin_Element_Valoff : O_Fnode; + Ghdl_Rtin_Element_Sigoff : O_Fnode; + + -- Node for a record type. + Ghdl_Rtin_Type_Record : O_Tnode; + Ghdl_Rtin_Type_Record_Common : O_Fnode; + Ghdl_Rtin_Type_Record_Name : O_Fnode; + Ghdl_Rtin_Type_Record_Nbrel : O_Fnode; + Ghdl_Rtin_Type_Record_Elements : O_Fnode; + --Ghdl_Rtin_Type_Record_Valsize : O_Fnode; + --Ghdl_Rtin_Type_Record_Sigsize : O_Fnode; + + -- Node for an object. + Ghdl_Rtin_Object : O_Tnode; + Ghdl_Rtin_Object_Common : O_Fnode; + Ghdl_Rtin_Object_Name : O_Fnode; + Ghdl_Rtin_Object_Loc : O_Fnode; + Ghdl_Rtin_Object_Type : O_Fnode; + + -- Node for an instance. + Ghdl_Rtin_Instance : O_Tnode; + Ghdl_Rtin_Instance_Common : O_Fnode; + Ghdl_Rtin_Instance_Name : O_Fnode; + Ghdl_Rtin_Instance_Loc : O_Fnode; + Ghdl_Rtin_Instance_Parent : O_Fnode; + Ghdl_Rtin_Instance_Type : O_Fnode; + + -- Node for a component. + Ghdl_Rtin_Component : O_Tnode; + Ghdl_Rtin_Component_Common : O_Fnode; + Ghdl_Rtin_Component_Name : O_Fnode; + Ghdl_Rtin_Component_Nbr_Child : O_Fnode; + Ghdl_Rtin_Component_Children : O_Fnode; + + procedure Rti_Initialize + is + begin + -- Create type ghdl_rti_kind is (ghdl_rtik_typedef_bool, ...) + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_top"), + Ghdl_Rtik_Top); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_library"), + Ghdl_Rtik_Library); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_package"), + Ghdl_Rtik_Package); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_package_body"), + Ghdl_Rtik_Package_Body); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_entity"), + Ghdl_Rtik_Entity); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_architecture"), + Ghdl_Rtik_Architecture); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_process"), + Ghdl_Rtik_Process); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_block"), + Ghdl_Rtik_Block); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_if_generate"), + Ghdl_Rtik_If_Generate); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_for_generate"), + Ghdl_Rtik_For_Generate); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_instance"), + Ghdl_Rtik_Instance); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_constant"), + Ghdl_Rtik_Constant); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_iterator"), + Ghdl_Rtik_Iterator); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_variable"), + Ghdl_Rtik_Variable); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_signal"), + Ghdl_Rtik_Signal); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_file"), + Ghdl_Rtik_File); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_port"), + Ghdl_Rtik_Port); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_generic"), + Ghdl_Rtik_Generic); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_alias"), + Ghdl_Rtik_Alias); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_guard"), + Ghdl_Rtik_Guard); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_component"), + Ghdl_Rtik_Component); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute"), + Ghdl_Rtik_Attribute); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_b1"), + Ghdl_Rtik_Type_B1); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_e8"), + Ghdl_Rtik_Type_E8); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_e32"), + Ghdl_Rtik_Type_E32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_i32"), + Ghdl_Rtik_Type_I32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_i64"), + Ghdl_Rtik_Type_I64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_f64"), + Ghdl_Rtik_Type_F64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_p32"), + Ghdl_Rtik_Type_P32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_p64"), + Ghdl_Rtik_Type_P64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_access"), + Ghdl_Rtik_Type_Access); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_array"), + Ghdl_Rtik_Type_Array); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_record"), + Ghdl_Rtik_Type_Record); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_file"), + Ghdl_Rtik_Type_File); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_scalar"), + Ghdl_Rtik_Subtype_Scalar); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_array"), + Ghdl_Rtik_Subtype_Array); + New_Enum_Literal + (Constr, + Get_Identifier ("__ghdl_rtik_subtype_unconstrained_array"), + Ghdl_Rtik_Subtype_Unconstrained_Array); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_record"), + Ghdl_Rtik_Subtype_Record); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_access"), + Ghdl_Rtik_Subtype_Access); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_protected"), + Ghdl_Rtik_Type_Protected); + + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_element"), + Ghdl_Rtik_Element); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unit64"), + Ghdl_Rtik_Unit64); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unitptr"), + Ghdl_Rtik_Unitptr); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_transaction"), + Ghdl_Rtik_Attribute_Transaction); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_quiet"), + Ghdl_Rtik_Attribute_Quiet); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_stable"), + Ghdl_Rtik_Attribute_Stable); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_psl_assert"), + Ghdl_Rtik_Psl_Assert); + + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_error"), + Ghdl_Rtik_Error); + Finish_Enum_Type (Constr, Ghdl_Rtik); + New_Type_Decl (Get_Identifier ("__ghdl_rtik"), Ghdl_Rtik); + end; + + -- Create type ghdl_rti_depth. + Ghdl_Rti_Depth := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_rti_depth"), Ghdl_Rti_Depth); + Ghdl_Rti_U8 := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_rti_u8"), Ghdl_Rti_U8); + + -- Create type ghdl_rti_common. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rti_Common_Kind, + Get_Identifier ("kind"), Ghdl_Rtik); + New_Record_Field (Constr, Ghdl_Rti_Common_Depth, + Get_Identifier ("depth"), Ghdl_Rti_Depth); + New_Record_Field (Constr, Ghdl_Rti_Common_Mode, + Get_Identifier ("mode"), Ghdl_Rti_U8); + New_Record_Field (Constr, Ghdl_Rti_Common_Max_Depth, + Get_Identifier ("max_depth"), Ghdl_Rti_Depth); + Finish_Record_Type (Constr, Ghdl_Rti_Common); + New_Type_Decl (Get_Identifier ("__ghdl_rti_common"), + Ghdl_Rti_Common); + end; + + Ghdl_Rti_Access := New_Access_Type (Ghdl_Rti_Common); + New_Type_Decl (Get_Identifier ("__ghdl_rti_access"), Ghdl_Rti_Access); + + Ghdl_Rti_Array := New_Array_Type (Ghdl_Rti_Access, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_rti_array"), Ghdl_Rti_Array); + + Ghdl_Rti_Arr_Acc := New_Access_Type (Ghdl_Rti_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rti_arr_acc"), + Ghdl_Rti_Arr_Acc); + + -- Ghdl_Component_Link_Type. + New_Uncomplete_Record_Type (Ghdl_Component_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_component_link_type"), + Ghdl_Component_Link_Type); + + Ghdl_Component_Link_Acc := New_Access_Type (Ghdl_Component_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_component_link_acc"), + Ghdl_Component_Link_Acc); + + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Entity_Link_Rti, + Get_Identifier ("rti"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Entity_Link_Parent, + Wki_Parent, Ghdl_Component_Link_Acc); + Finish_Record_Type (Constr, Ghdl_Entity_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_entity_link_type"), + Ghdl_Entity_Link_Type); + end; + + Ghdl_Entity_Link_Acc := New_Access_Type (Ghdl_Entity_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_entity_link_acc"), + Ghdl_Entity_Link_Acc); + + declare + Constr : O_Element_List; + begin + Start_Uncomplete_Record_Type (Ghdl_Component_Link_Type, Constr); + New_Record_Field (Constr, Ghdl_Component_Link_Instance, + Wki_Instance, Ghdl_Entity_Link_Acc); + New_Record_Field (Constr, Ghdl_Component_Link_Stmt, + Get_Identifier ("stmt"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Component_Link_Type); + end; + + -- Create type ghdl_rtin_block + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Block_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Block_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Parent, + Wki_Parent, Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Block_Size, + Get_Identifier ("size"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Nbr_Child, + Get_Identifier ("nbr_child"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Children, + Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Block); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_block"), + Ghdl_Rtin_Block); + end; + + -- type (type and subtype declarations). + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Name, + Get_Identifier ("name"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Scalar); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_scalar"), + Ghdl_Rtin_Type_Scalar); + end; + + -- Type_Enum + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Nbr, + Get_Identifier ("nbr"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Lits, + Get_Identifier ("lits"), + Char_Ptr_Array_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Enum); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_enum"), + Ghdl_Rtin_Type_Enum); + end; + + -- subtype_scalar + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Base, + Get_Identifier ("base"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Range, + Get_Identifier ("range"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Scalar); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_scalar"), + Ghdl_Rtin_Subtype_Scalar); + end; + + -- Unit64 + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Value, + Wki_Val, Ghdl_I64_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Unit64); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_unit64"), + Ghdl_Rtin_Unit64); + end; + + -- Unitptr + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Value, + Get_Identifier ("addr"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Unitptr); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_unitptr"), + Ghdl_Rtin_Unitptr); + end; + + -- Physical type. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Nbr, + Get_Identifier ("nbr"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Units, + Get_Identifier ("units"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Physical); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_physical"), + Ghdl_Rtin_Type_Physical); + end; + + -- file and access type. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Base, + Get_Identifier ("base"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Fileacc); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_fileacc"), + Ghdl_Rtin_Type_Fileacc); + end; + + -- arraytype. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Element, + Get_Identifier ("element"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Nbrdim, + Get_Identifier ("nbr_dim"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Indexes, + Get_Identifier ("indexes"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_array"), + Ghdl_Rtin_Type_Array); + end; + + -- subtype_Array. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Basetype, + Get_Identifier ("basetype"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Bounds, + Get_Identifier ("bounds"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Valsize, + Get_Identifier ("val_size"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Sigsize, + Get_Identifier ("sig_size"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_array"), + Ghdl_Rtin_Subtype_Array); + end; + + -- type record. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Nbrel, + Get_Identifier ("nbrel"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Elements, + Get_Identifier ("elements"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Record); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_record"), + Ghdl_Rtin_Type_Record); + end; + + -- record element. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Element_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Element_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Element_Type, + Get_Identifier ("eltype"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Element_Valoff, + Get_Identifier ("val_off"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Element_Sigoff, + Get_Identifier ("sig_off"), Ghdl_Index_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Element); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_element"), + Ghdl_Rtin_Element); + end; + + -- Object. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Object_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Object_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Object_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Object_Type, + Get_Identifier ("obj_type"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Object); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_object"), + Ghdl_Rtin_Object); + end; + + -- Instance. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Parent, + Wki_Parent, Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Type, + Get_Identifier ("instance"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Instance); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_instance"), + Ghdl_Rtin_Instance); + end; + + -- Component + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Component_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Component_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Component_Nbr_Child, + Get_Identifier ("nbr_child"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Component_Children, + Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Component); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_component"), + Ghdl_Rtin_Component); + end; + + end Rti_Initialize; + + type Rti_Array is array (1 .. 8) of O_Dnode; + type Rti_Array_List; + type Rti_Array_List_Acc is access Rti_Array_List; + type Rti_Array_List is record + Rtis : Rti_Array; + Next : Rti_Array_List_Acc; + end record; + + type Rti_Block is record + Depth : Rti_Depth_Type; + Nbr : Integer; + List : Rti_Array_List; + Last_List : Rti_Array_List_Acc; + Last_Nbr : Integer; + end record; + + Cur_Block : Rti_Block := (Depth => 0, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + + Free_List : Rti_Array_List_Acc := null; + + procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True) + is + Ndepth : Rti_Depth_Type; + begin + if Deeper then + Ndepth := Cur_Block.Depth + 1; + else + Ndepth := Cur_Block.Depth; + end if; + Prev := Cur_Block; + Cur_Block := (Depth => Ndepth, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + end Push_Rti_Node; + + procedure Add_Rti_Node (Node : O_Dnode) + is + begin + if Node = O_Dnode_Null then + -- FIXME: temporary for not yet handled types. + return; + end if; + if Cur_Block.Last_Nbr = Rti_Array'Last then + declare + N : Rti_Array_List_Acc; + begin + if Free_List = null then + N := new Rti_Array_List; + else + N := Free_List; + Free_List := N.Next; + end if; + N.Next := null; + if Cur_Block.Last_List = null then + Cur_Block.List.Next := N; + else + Cur_Block.Last_List.Next := N; + end if; + Cur_Block.Last_List := N; + end; + Cur_Block.Last_Nbr := 1; + else + Cur_Block.Last_Nbr := Cur_Block.Last_Nbr + 1; + end if; + if Cur_Block.Last_List = null then + Cur_Block.List.Rtis (Cur_Block.Last_Nbr) := Node; + else + Cur_Block.Last_List.Rtis (Cur_Block.Last_Nbr) := Node; + end if; + Cur_Block.Nbr := Cur_Block.Nbr + 1; + end Add_Rti_Node; + + function Generate_Rti_Array (Id : O_Ident) return O_Dnode + is + Arr_Type : O_Tnode; + List : O_Array_Aggr_List; + L : Rti_Array_List_Acc; + Nbr : Integer; + Val : O_Cnode; + Res : O_Dnode; + begin + Arr_Type := New_Constrained_Array_Type + (Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr + 1))); + New_Const_Decl (Res, Id, O_Storage_Private, Arr_Type); + Start_Const_Value (Res); + Start_Array_Aggr (List, Arr_Type); + Nbr := Cur_Block.Nbr; + for I in Cur_Block.List.Rtis'Range loop + exit when I > Nbr; + New_Array_Aggr_El + (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I), + Ghdl_Rti_Access)); + end loop; + L := Cur_Block.List.Next; + while L /= null loop + Nbr := Nbr - Cur_Block.List.Rtis'Length; + for I in L.Rtis'Range loop + exit when I > Nbr; + New_Array_Aggr_El + (List, New_Global_Unchecked_Address (L.Rtis (I), + Ghdl_Rti_Access)); + end loop; + L := L.Next; + end loop; + New_Array_Aggr_El (List, New_Null_Access (Ghdl_Rti_Access)); + Finish_Array_Aggr (List, Val); + Finish_Const_Value (Res, Val); + return Res; + end Generate_Rti_Array; + + procedure Pop_Rti_Node (Prev : Rti_Block) + is + L : Rti_Array_List_Acc; + begin + L := Cur_Block.List.Next; + if L /= null then + Cur_Block.Last_List.Next := Free_List; + Free_List := Cur_Block.List.Next; + Cur_Block.List.Next := null; + end if; + Cur_Block := Prev; + end Pop_Rti_Node; + + function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type + is + begin + if Var = Null_Var or else Is_Var_Field (Var) then + return Cur_Block.Depth; + else + return 0; + end if; + end Get_Depth_From_Var; + + function Generate_Common + (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0) + return O_Cnode + is + List : O_Record_Aggr_List; + Res : O_Cnode; + Val : Unsigned_64; + begin + Start_Record_Aggr (List, Ghdl_Rti_Common); + New_Record_Aggr_El (List, Kind); + Val := Unsigned_64 (Get_Depth_From_Var (Var)); + New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, Val)); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); + New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, 0)); + Finish_Record_Aggr (List, Res); + return Res; + end Generate_Common; + + -- Same as Generat_Common but for types. + function Generate_Common_Type (Kind : O_Cnode; + Depth : Rti_Depth_Type; + Max_Depth : Rti_Depth_Type; + Mode : Natural := 0) + return O_Cnode + is + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Start_Record_Aggr (List, Ghdl_Rti_Common); + New_Record_Aggr_El (List, Kind); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Depth))); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Max_Depth))); + Finish_Record_Aggr (List, Res); + return Res; + end Generate_Common_Type; + + function Generate_Name (Node : Iir) return O_Dnode + is + use Name_Table; + Id : Name_Id; + begin + Id := Get_Identifier (Node); + if Is_Character (Id) then + Name_Buffer (1) := '''; + Name_Buffer (2) := Get_Character (Id); + Name_Buffer (3) := '''; + Name_Length := 3; + else + Image (Id); + end if; + return Create_String (Name_Buffer (1 .. Name_Length), + Create_Identifier ("RTISTR")); + end Generate_Name; + + function Get_Null_Loc return O_Cnode is + begin + return New_Null_Access (Ghdl_Ptr_Type); + end Get_Null_Loc; + + function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode + is + begin + if Is_Var_Field (Var) then + return Get_Var_Offset (Var, Ghdl_Ptr_Type); + else + return New_Global_Unchecked_Address (Get_Var_Label (Var), + Ghdl_Ptr_Type); + end if; + end Var_Acc_To_Loc; + + -- Generate a name constant for the name of type definition DEF. + -- If DEF is an anonymous subtype, returns O_LNODE_NULL. + -- Use function NEW_NAME_ADDRESS (defined below) to convert the + -- result into an address expression. + function Generate_Type_Name (Def : Iir) return O_Dnode + is + Decl : Iir; + begin + Decl := Get_Type_Declarator (Def); + if Decl /= Null_Iir then + return Generate_Name (Decl); + else + return O_Dnode_Null; + end if; + end Generate_Type_Name; + + -- Convert a name constant NAME into an address. + -- If NAME is O_LNODE_NULL, return a null address. + -- To be used with GENERATE_TYPE_NAME. + function New_Name_Address (Name : O_Dnode) return O_Cnode + is + begin + if Name = O_Dnode_Null then + return New_Null_Access (Char_Ptr_Type); + else + return New_Global_Unchecked_Address (Name, Char_Ptr_Type); + end if; + end New_Name_Address; + + function New_Rti_Address (Rti : O_Dnode) return O_Cnode is + begin + return New_Global_Unchecked_Address (Rti, Ghdl_Rti_Access); + end New_Rti_Address; + + -- Declare the RTI constant for type definition attached to INFO. + -- The only feature is not to declare it if it was already declared. + -- (due to an incomplete type declaration). + procedure Generate_Type_Rti (Info : Type_Info_Acc; Rti_Type : O_Tnode) + is + begin + if Info.Type_Rti = O_Dnode_Null then + New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + end if; + end Generate_Type_Rti; + + function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) + return O_Dnode; + + procedure Generate_Enumeration_Type_Definition (Atype : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Atype); + Val : O_Cnode; + begin + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Enum); + Info.T.Rti_Max_Depth := 0; + + if Global_Storage = O_Storage_External then + return; + end if; + + declare + Lit_List : constant Iir_List := + Get_Enumeration_Literal_List (Atype); + Nbr_Lit : constant Integer := Get_Nbr_Elements (Lit_List); + Lit : Iir; + + type Dnode_Array is array (Natural range <>) of O_Dnode; + Name_Lits : Dnode_Array (0 .. Nbr_Lit - 1); + Mark : Id_Mark_Type; + Name_Arr_Type : O_Tnode; + Name_Arr : O_Dnode; + + Arr_Aggr : O_Array_Aggr_List; + Rec_Aggr : O_Record_Aggr_List; + Kind : O_Cnode; + Name : O_Dnode; + begin + -- Generate name for each literal. + for I in Name_Lits'Range loop + Lit := Get_Nth_Element (Lit_List, I); + Push_Identifier_Prefix (Mark, Get_Identifier (Lit)); + Name_Lits (I) := Generate_Name (Lit); + Pop_Identifier_Prefix (Mark); + end loop; + + -- Generate array of names. + Name_Arr_Type := New_Constrained_Array_Type + (Char_Ptr_Array_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Lit))); + New_Const_Decl (Name_Arr, Create_Identifier ("RTINAMES"), + O_Storage_Private, Name_Arr_Type); + Start_Const_Value (Name_Arr); + Start_Array_Aggr (Arr_Aggr, Name_Arr_Type); + for I in Name_Lits'Range loop + New_Array_Aggr_El + (Arr_Aggr, New_Global_Address (Name_Lits (I), Char_Ptr_Type)); + end loop; + Finish_Array_Aggr (Arr_Aggr, Val); + Finish_Const_Value (Name_Arr, Val); + + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + case Info.Type_Mode is + when Type_Mode_B1 => + Kind := Ghdl_Rtik_Type_B1; + when Type_Mode_E8 => + Kind := Ghdl_Rtik_Type_E8; + when Type_Mode_E32 => + Kind := Ghdl_Rtik_Type_E32; + when others => + raise Internal_Error; + end case; + Start_Record_Aggr (Rec_Aggr, Ghdl_Rtin_Type_Enum); + New_Record_Aggr_El (Rec_Aggr, Generate_Common_Type (Kind, 0, 0)); + New_Record_Aggr_El (Rec_Aggr, New_Name_Address (Name)); + New_Record_Aggr_El + (Rec_Aggr, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Lit))); + New_Record_Aggr_El + (Rec_Aggr, + New_Global_Address (Name_Arr, Char_Ptr_Array_Ptr_Type)); + Finish_Record_Aggr (Rec_Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end; + end Generate_Enumeration_Type_Definition; + + procedure Generate_Scalar_Type_Definition (Atype : Iir; Name : O_Dnode) + is + Info : Type_Info_Acc; + Kind : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); + Info.T.Rti_Max_Depth := 0; + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Const_Value (Info.Type_Rti); + case Info.Type_Mode is + when Type_Mode_I32 => + Kind := Ghdl_Rtik_Type_I32; + when Type_Mode_I64 => + Kind := Ghdl_Rtik_Type_I64; + when Type_Mode_F64 => + Kind := Ghdl_Rtik_Type_F64; + when Type_Mode_P64 => + Kind := Ghdl_Rtik_Type_P64; + when others => + Error_Kind ("generate_scalar_type_definition", Atype); + end case; + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (List, Generate_Common_Type (Kind, 0, 0)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Scalar_Type_Definition; + + procedure Generate_Unit_Declaration (Unit : Iir_Unit_Declaration) + is + Name : O_Dnode; + Mark : Id_Mark_Type; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Const : O_Dnode; + Info : constant Object_Info_Acc := Get_Info (Unit); + Rti_Type : O_Tnode; + Rtik : O_Cnode; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Unit)); + Name := Generate_Name (Unit); + if Info /= null then + -- Non-static units. The only possibility is a unit of + -- std.standard.time. + Rti_Type := Ghdl_Rtin_Unitptr; + Rtik := Ghdl_Rtik_Unitptr; + else + Rti_Type := Ghdl_Rtin_Unit64; + Rtik := Ghdl_Rtik_Unit64; + end if; + New_Const_Decl (Const, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + Start_Const_Value (Const); + Start_Record_Aggr (Aggr, Rti_Type); + New_Record_Aggr_El (Aggr, Generate_Common (Rtik)); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + if Info /= null then + -- Handle non-static units. The only possibility is a unit of + -- std.standard.time. + Val := New_Global_Unchecked_Address + (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type); + else + Val := Chap7.Translate_Numeric_Literal (Unit, Ghdl_I64_Type); + end if; + New_Record_Aggr_El (Aggr, Val); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Const, Val); + Add_Rti_Node (Const); + Pop_Identifier_Prefix (Mark); + end Generate_Unit_Declaration; + + procedure Generate_Physical_Type_Definition (Atype : Iir; Name : O_Dnode) + is + Info : Type_Info_Acc; + Val : O_Cnode; + List : O_Record_Aggr_List; + Prev : Rti_Block; + Unit : Iir_Unit_Declaration; + Nbr_Units : Integer; + Unit_Arr : O_Dnode; + Rti_Kind : O_Cnode; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Physical); + + if Global_Storage = O_Storage_External then + return; + end if; + + Push_Rti_Node (Prev, False); + Unit := Get_Unit_Chain (Atype); + Nbr_Units := 0; + while Unit /= Null_Iir loop + Generate_Unit_Declaration (Unit); + Nbr_Units := Nbr_Units + 1; + Unit := Get_Chain (Unit); + end loop; + Unit_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + Pop_Rti_Node (Prev); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Physical); + case Info.Type_Mode is + when Type_Mode_P64 => + Rti_Kind := Ghdl_Rtik_Type_P64; + when Type_Mode_P32 => + Rti_Kind := Ghdl_Rtik_Type_P32; + when others => + raise Internal_Error; + end case; + New_Record_Aggr_El (List, Generate_Common_Type (Rti_Kind, 0, 0, 0)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Units))); + New_Record_Aggr_El + (List, New_Global_Address (Unit_Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Physical_Type_Definition; + + procedure Generate_Scalar_Subtype_Definition (Atype : Iir) + is + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Name : O_Dnode; + begin + Info := Get_Info (Atype); + + if Global_Storage = O_Storage_External then + Name := O_Dnode_Null; + else + Name := Generate_Type_Name (Atype); + end if; + + -- Generate base type definition, if necessary. + -- (do it even in packages). + Base_Type := Get_Base_Type (Atype); + Base_Info := Get_Info (Base_Type); + if Base_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "BT"); + if Get_Kind (Base_Type) = Iir_Kind_Physical_Type_Definition then + Generate_Physical_Type_Definition (Base_Type, Name); + else + Generate_Scalar_Type_Definition (Base_Type, Name); + end if; + Pop_Identifier_Prefix (Mark); + end; + end if; + + Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Scalar); + Info.T.Rti_Max_Depth := Get_Depth_From_Var (Info.T.Range_Var); + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Scalar); + New_Record_Aggr_El + (Aggr, Generate_Common_Type (Ghdl_Rtik_Subtype_Scalar, + Info.T.Rti_Max_Depth, + Info.T.Rti_Max_Depth)); + + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); + New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Info.T.Range_Var)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Scalar_Subtype_Definition; + + procedure Generate_Fileacc_Type_Definition (Atype : Iir) + is + Info : Type_Info_Acc; + Kind : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + Name : O_Dnode; + Base : O_Dnode; + Base_Type : Iir; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Fileacc); + + if Global_Storage = O_Storage_External then + return; + end if; + + case Get_Kind (Atype) is + when Iir_Kind_Access_Type_Definition => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "AT"); + Base := Generate_Type_Definition + (Get_Designated_Type (Atype)); + Pop_Identifier_Prefix (Mark); + end; + if Get_Kind (Atype) = Iir_Kind_Access_Subtype_Definition then + Kind := Ghdl_Rtik_Subtype_Access; + else + Kind := Ghdl_Rtik_Type_Access; + end if; + -- Don't bother with designated type. This at least avoid + -- loops. + Base_Type := Null_Iir; + when Iir_Kind_File_Type_Definition => + Base_Type := Get_Type (Get_File_Type_Mark (Atype)); + Base := Generate_Type_Definition (Base_Type); + Kind := Ghdl_Rtik_Type_File; + when Iir_Kind_Record_Subtype_Definition => + Base_Type := Get_Base_Type (Atype); + Base := Get_Info (Base_Type).Type_Rti; + Kind := Ghdl_Rtik_Subtype_Record; + when Iir_Kind_Access_Subtype_Definition => + Base_Type := Get_Base_Type (Atype); + Base := Get_Info (Base_Type).Type_Rti; + Kind := Ghdl_Rtik_Subtype_Access; + when others => + Error_Kind ("rti.generate_fileacc_type_definition", Atype); + end case; + if Base_Type = Null_Iir then + Info.T.Rti_Max_Depth := 0; + else + Info.T.Rti_Max_Depth := Get_Info (Base_Type).T.Rti_Max_Depth; + end if; + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Fileacc); + New_Record_Aggr_El + (List, Generate_Common_Type (Kind, 0, Info.T.Rti_Max_Depth)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + New_Record_Aggr_El (List, New_Rti_Address (Base)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Fileacc_Type_Definition; + + procedure Generate_Array_Type_Indexes + (Atype : Iir; Res : out O_Dnode; Max_Depth : in out Rti_Depth_Type) + is + List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Indexes : constant Natural := Get_Nbr_Elements (List); + Index : Iir; + Tmp : O_Dnode; + pragma Unreferenced (Tmp); + Arr_Type : O_Tnode; + Arr_Aggr : O_Array_Aggr_List; + Val : O_Cnode; + Mark : Id_Mark_Type; + begin + -- Translate each index. + for I in 1 .. Nbr_Indexes loop + Index := Get_Index_Type (List, I - 1); + Push_Identifier_Prefix (Mark, "DIM", Iir_Int32 (I)); + Tmp := Generate_Type_Definition (Index); + Max_Depth := Rti_Depth_Type'Max (Max_Depth, + Get_Info (Index).T.Rti_Max_Depth); + Pop_Identifier_Prefix (Mark); + end loop; + + -- Generate array of index. + Arr_Type := New_Constrained_Array_Type + (Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Indexes))); + New_Const_Decl (Res, Create_Identifier ("RTIINDEXES"), + Global_Storage, Arr_Type); + Start_Const_Value (Res); + + Start_Array_Aggr (Arr_Aggr, Arr_Type); + for I in 1 .. Nbr_Indexes loop + Index := Get_Index_Type (List, I - 1); + New_Array_Aggr_El + (Arr_Aggr, New_Rti_Address (Generate_Type_Definition (Index))); + end loop; + Finish_Array_Aggr (Arr_Aggr, Val); + Finish_Const_Value (Res, Val); + end Generate_Array_Type_Indexes; + + function Type_To_Mode (Atype : Iir) return Natural is + Res : Natural := 0; + begin + if Is_Complex_Type (Get_Info (Atype)) then + Res := Res + 1; + end if; + if Is_Anonymous_Type_Definition (Atype) + or else (Get_Kind (Get_Type_Declarator (Atype)) + = Iir_Kind_Anonymous_Type_Declaration) + then + Res := Res + 2; + end if; + return Res; + end Type_To_Mode; + + procedure Generate_Array_Type_Definition + (Atype : Iir_Array_Type_Definition) + is + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + List : Iir_List; + Arr : O_Dnode; + Element : Iir; + Name : O_Dnode; + El_Info : Type_Info_Acc; + Max_Depth : Rti_Depth_Type; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Array); + + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + Element := Get_Element_Subtype (Atype); + El_Info := Get_Info (Element); + if El_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + El_Rti : O_Dnode; + pragma Unreferenced (El_Rti); + begin + Push_Identifier_Prefix (Mark, "EL"); + El_Rti := Generate_Type_Definition (Element); + Pop_Identifier_Prefix (Mark); + end; + end if; + Max_Depth := El_Info.T.Rti_Max_Depth; + + -- Translate each index. + Generate_Array_Type_Indexes (Atype, Arr, Max_Depth); + Info.T.Rti_Max_Depth := Max_Depth; + List := Get_Index_Subtype_List (Atype); + + -- Generate node. + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Array); + New_Record_Aggr_El + (Aggr, + Generate_Common_Type + (Ghdl_Rtik_Type_Array, 0, Max_Depth, Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti)); + New_Record_Aggr_El + (Aggr, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Get_Nbr_Elements (List)))); + New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Array_Type_Definition; + + procedure Generate_Array_Subtype_Definition + (Atype : Iir_Array_Subtype_Definition) + is + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Base_Rti : O_Dnode; + pragma Unreferenced (Base_Rti); + Bounds : Var_Type; + Name : O_Dnode; + Kind : O_Cnode; + Mark : Id_Mark_Type; + Depth : Rti_Depth_Type; + begin + -- FIXME: temporary work-around + if Get_Constraint_State (Atype) /= Fully_Constrained then + return; + end if; + + Info := Get_Info (Atype); + + Base_Type := Get_Base_Type (Atype); + Base_Info := Get_Info (Base_Type); + if Base_Info.Type_Rti = O_Dnode_Null then + Push_Identifier_Prefix (Mark, "BT"); + Base_Rti := Generate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + end if; + + Bounds := Info.T.Array_Bounds; + Depth := Get_Depth_From_Var (Bounds); + Info.T.Rti_Max_Depth := + Rti_Depth_Type'Max (Depth, Base_Info.T.Rti_Max_Depth); + + -- Generate node. + Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Array); + + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Array); + case Info.Type_Mode is + when Type_Mode_Array => + Kind := Ghdl_Rtik_Subtype_Array; + when Type_Mode_Fat_Array => + Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; + New_Record_Aggr_El + (Aggr, + Generate_Common_Type + (Kind, Depth, Info.T.Rti_Max_Depth, Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); + if Bounds = Null_Var then + Val := Get_Null_Loc; + else + Val := Var_Acc_To_Loc (Bounds); + end if; + New_Record_Aggr_El (Aggr, Val); + for I in Mode_Value .. Mode_Signal loop + case Info.Type_Mode is + when Type_Mode_Array => + Val := Get_Null_Loc; + if Info.Ortho_Type (I) /= O_Tnode_Null then + if Is_Complex_Type (Info) then + if Info.C (I).Size_Var /= Null_Var then + Val := Var_Acc_To_Loc (Info.C (I).Size_Var); + end if; + else + Val := New_Sizeof (Info.Ortho_Type (I), + Ghdl_Ptr_Type); + end if; + end if; + when Type_Mode_Fat_Array => + Val := Get_Null_Loc; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; + New_Record_Aggr_El (Aggr, Val); + end loop; + + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Array_Subtype_Definition; + + procedure Generate_Record_Type_Definition (Atype : Iir) + is + El_List : Iir_List; + El : Iir; + Prev : Rti_Block; + El_Arr : O_Dnode; + Res : O_Cnode; + Info : constant Type_Info_Acc := Get_Info (Atype); + Max_Depth : Rti_Depth_Type; + begin + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Record); + if Global_Storage = O_Storage_External then + return; + end if; + + El_List := Get_Elements_Declaration_List (Atype); + Max_Depth := 0; + + -- Generate elements. + Push_Rti_Node (Prev, False); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + declare + Type_Rti : O_Dnode; + El_Name : O_Dnode; + El_Type : constant Iir := Get_Type (El); + Aggr : O_Record_Aggr_List; + Field_Info : constant Field_Info_Acc := Get_Info (El); + Val : O_Cnode; + El_Const : O_Dnode; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + Type_Rti := Generate_Type_Definition (El_Type); + Max_Depth := + Rti_Depth_Type'Max (Max_Depth, + Get_Info (El_Type).T.Rti_Max_Depth); + + El_Name := Generate_Name (El); + New_Const_Decl (El_Const, Create_Identifier ("RTIEL"), + Global_Storage, Ghdl_Rtin_Element); + Start_Const_Value (El_Const); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Element); + New_Record_Aggr_El (Aggr, + Generate_Common (Ghdl_Rtik_Element)); + New_Record_Aggr_El (Aggr, New_Name_Address (El_Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Type_Rti)); + for I in Object_Kind_Type loop + if Field_Info.Field_Node (I) /= O_Fnode_Null then + Val := New_Offsetof (Info.Ortho_Type (I), + Field_Info.Field_Node (I), + Ghdl_Index_Type); + else + Val := Ghdl_Index_0; + end if; + New_Record_Aggr_El (Aggr, Val); + end loop; + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (El_Const, Val); + Add_Rti_Node (El_Const); + + Pop_Identifier_Prefix (Mark); + end; + end loop; + El_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + Pop_Rti_Node (Prev); + + Info.T.Rti_Max_Depth := Max_Depth; + -- Generate record. + declare + Aggr : O_Record_Aggr_List; + Name : O_Dnode; + begin + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record); + New_Record_Aggr_El + (Aggr, + Generate_Common_Type (Ghdl_Rtik_Type_Record, 0, Max_Depth, + Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El + (Aggr, New_Unsigned_Literal + (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List)))); + New_Record_Aggr_El (Aggr, + New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (Aggr, Res); + Finish_Const_Value (Info.Type_Rti, Res); + end; + end Generate_Record_Type_Definition; + + procedure Generate_Protected_Type_Declaration (Atype : Iir) + is + Info : Type_Info_Acc; + Name : O_Dnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + begin + Info := Get_Info (Atype); + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El + (List, + Generate_Common_Type (Ghdl_Rtik_Type_Protected, 0, 0, + Type_To_Mode (Atype))); + New_Record_Aggr_El (List, New_Name_Address (Name)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Protected_Type_Declaration; + + -- If FORCE is true, force the creation of the type RTI. + -- Otherwise, only the declaration (and not the definition) may have + -- been created. + function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) + return O_Dnode + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if not Force and then Info.Type_Rti /= O_Dnode_Null then + return Info.Type_Rti; + end if; + case Get_Kind (Atype) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + raise Internal_Error; + when Iir_Kind_Enumeration_Type_Definition => + Generate_Enumeration_Type_Definition (Atype); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Generate_Scalar_Subtype_Definition (Atype); + when Iir_Kind_Array_Type_Definition => + Generate_Array_Type_Definition (Atype); + when Iir_Kind_Array_Subtype_Definition => + Generate_Array_Subtype_Definition (Atype); + when Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + Generate_Fileacc_Type_Definition (Atype); + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + -- FIXME: No separate infos (yet). + null; + when Iir_Kind_Record_Type_Definition => + Generate_Record_Type_Definition (Atype); + when Iir_Kind_Protected_Type_Declaration => + Generate_Protected_Type_Declaration (Atype); + when others => + Error_Kind ("rti.generate_type_definition", Atype); + return O_Dnode_Null; + end case; + return Info.Type_Rti; + end Generate_Type_Definition; + + function Generate_Incomplete_Type_Definition (Def : Iir) + return O_Dnode + is + Ndef : constant Iir := Get_Type (Get_Type_Declarator (Def)); + Info : constant Type_Info_Acc := Get_Info (Ndef); + Rti_Type : O_Tnode; + begin + case Get_Kind (Ndef) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Scalar; + when Iir_Kind_Physical_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Physical; + when Iir_Kind_Enumeration_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Enum; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Rti_Type := Ghdl_Rtin_Subtype_Scalar; + when Iir_Kind_Array_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Array; + when Iir_Kind_Array_Subtype_Definition => + Rti_Type := Ghdl_Rtin_Subtype_Array; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Fileacc; + when Iir_Kind_Record_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Record; + when others => + Error_Kind ("rti.generate_incomplete_type_definition", Ndef); + end case; + New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + return Info.Type_Rti; + end Generate_Incomplete_Type_Definition; + + function Generate_Type_Decl (Decl : Iir) return O_Dnode + is + Id : constant Name_Id := Get_Identifier (Decl); + Def : constant Iir := Get_Type (Decl); + Rti : O_Dnode; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Id); + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + Rti := Generate_Incomplete_Type_Definition (Def); + else + Rti := Generate_Type_Definition (Def, True); + end if; + Pop_Identifier_Prefix (Mark); + return Rti; + end Generate_Type_Decl; + + procedure Generate_Signal_Rti (Sig : Iir) + is + Info : Object_Info_Acc; + begin + Info := Get_Info (Sig); + New_Const_Decl (Info.Object_Rti, Create_Identifier (Sig, "__RTI"), + Global_Storage, Ghdl_Rtin_Object); + end Generate_Signal_Rti; + + procedure Generate_Object (Decl : Iir; Rti : in out O_Dnode) + is + Decl_Type : Iir; + Type_Info : Type_Info_Acc; + Name : O_Dnode; + Comm : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + Info : Ortho_Info_Acc; + Mark : Id_Mark_Type; + Var : Var_Type; + Mode : Natural; + Has_Id : Boolean; + begin + case Get_Kind (Decl) is + when Iir_Kind_Transaction_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + Has_Id := False; + Push_Identifier_Prefix_Uniq (Mark); + when others => + Has_Id := True; + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + end case; + + if Rti = O_Dnode_Null then + New_Const_Decl (Rti, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Object); + end if; + + if Global_Storage /= O_Storage_External then + Decl_Type := Get_Type (Decl); + Type_Info := Get_Info (Decl_Type); + if Type_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + Tmp : O_Dnode; + pragma Unreferenced (Tmp); + begin + Push_Identifier_Prefix (Mark, "OT"); + Tmp := Generate_Type_Definition (Decl_Type); + Pop_Identifier_Prefix (Mark); + end; + end if; + + if Has_Id then + Name := Generate_Name (Decl); + else + Name := O_Dnode_Null; + end if; + + Info := Get_Info (Decl); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Object); + Mode := 0; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration => + Comm := Ghdl_Rtik_Signal; + Var := Info.Object_Var; + when Iir_Kind_Interface_Signal_Declaration => + Comm := Ghdl_Rtik_Port; + Var := Info.Object_Var; + Mode := Iir_Mode'Pos (Get_Mode (Decl)); + when Iir_Kind_Constant_Declaration => + Comm := Ghdl_Rtik_Constant; + Var := Info.Object_Var; + when Iir_Kind_Interface_Constant_Declaration => + Comm := Ghdl_Rtik_Generic; + Var := Info.Object_Var; + when Iir_Kind_Variable_Declaration => + Comm := Ghdl_Rtik_Variable; + Var := Info.Object_Var; + when Iir_Kind_Guard_Signal_Declaration => + Comm := Ghdl_Rtik_Guard; + Var := Info.Object_Var; + when Iir_Kind_Iterator_Declaration => + Comm := Ghdl_Rtik_Iterator; + Var := Info.Iterator_Var; + when Iir_Kind_File_Declaration => + Comm := Ghdl_Rtik_File; + Var := Info.Object_Var; + when Iir_Kind_Attribute_Declaration => + Comm := Ghdl_Rtik_Attribute; + Var := Null_Var; + when Iir_Kind_Transaction_Attribute => + Comm := Ghdl_Rtik_Attribute_Transaction; + Var := Info.Object_Var; + when Iir_Kind_Quiet_Attribute => + Comm := Ghdl_Rtik_Attribute_Quiet; + Var := Info.Object_Var; + when Iir_Kind_Stable_Attribute => + Comm := Ghdl_Rtik_Attribute_Stable; + Var := Info.Object_Var; + when Iir_Kind_Object_Alias_Declaration => + Comm := Ghdl_Rtik_Alias; + Var := Info.Alias_Var; + Mode := Object_Kind_Type'Pos (Info.Alias_Kind); + when others => + Error_Kind ("rti.generate_object", Decl); + end case; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Mode := Mode + + 16 * Iir_Signal_Kind'Pos (Get_Signal_Kind (Decl)); + when others => + null; + end case; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + if Get_Has_Active_Flag (Decl) then + Mode := Mode + 64; + end if; + when others => + null; + end case; + New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + if Var = Null_Var then + Val := Get_Null_Loc; + else + Val := Var_Acc_To_Loc (Var); + end if; + New_Record_Aggr_El (List, Val); + New_Record_Aggr_El (List, New_Rti_Address (Type_Info.Type_Rti)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Rti, Val); + end if; + Pop_Identifier_Prefix (Mark); + end Generate_Object; + + procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode); + procedure Generate_Declaration_Chain (Chain : Iir); + + procedure Generate_Component_Declaration (Comp : Iir) + is + Prev : Rti_Block; + Name : O_Dnode; + Arr : O_Dnode; + List : O_Record_Aggr_List; + Res : O_Cnode; + Mark : Id_Mark_Type; + Info : Comp_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Comp)); + Info := Get_Info (Comp); + + New_Const_Decl (Info.Comp_Rti_Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Component); + + if Global_Storage /= O_Storage_External then + Push_Rti_Node (Prev); + + Generate_Declaration_Chain (Get_Generic_Chain (Comp)); + Generate_Declaration_Chain (Get_Port_Chain (Comp)); + + Name := Generate_Name (Comp); + + Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + + Start_Const_Value (Info.Comp_Rti_Const); + Start_Record_Aggr (List, Ghdl_Rtin_Component); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Component)); + New_Record_Aggr_El (List, + New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr))); + New_Record_Aggr_El (List, + New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Info.Comp_Rti_Const, Res); + Pop_Rti_Node (Prev); + end if; + + Pop_Identifier_Prefix (Mark); + Add_Rti_Node (Info.Comp_Rti_Const); + end Generate_Component_Declaration; + + -- Generate RTIs only for types. + procedure Generate_Declaration_Chain_Depleted (Chain : Iir) + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Type_Declaration => + -- FIXME: physicals ? + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Enumeration_Type_Definition + then + Add_Rti_Node (Generate_Type_Decl (Decl)); + end if; + when Iir_Kind_Subtype_Declaration => + -- In a subprogram, a subtype may depends on parameters. + -- Eg: array subtypes. + null; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Stable_Attribute => + null; + when Iir_Kind_Delayed_Attribute => + -- FIXME: to be added. + null; + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- FIXME: to be added (for foreign). + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Anonymous_Type_Declaration => + -- Handled in subtype declaration. + null; + when Iir_Kind_Configuration_Specification + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when others => + Error_Kind ("rti.generate_declaration_chain_depleted", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Generate_Declaration_Chain_Depleted; + + procedure Generate_Subprogram_Body (Bod : Iir) + is + --Decl : Iir; + --Mark : Id_Mark_Type; + begin + --Decl := Get_Subprogram_Specification (Bod); + + --Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + -- Generate RTI only for types. + Generate_Declaration_Chain_Depleted (Get_Declaration_Chain (Bod)); + --Pop_Identifier_Prefix (Mark); + end Generate_Subprogram_Body; + + procedure Generate_Instance (Stmt : Iir; Parent : O_Dnode) + is + Name : O_Dnode; + List : O_Record_Aggr_List; + Val : O_Cnode; + Inst : constant Iir := Get_Instantiated_Unit (Stmt); + Info : constant Block_Info_Acc := Get_Info (Stmt); + begin + Name := Generate_Name (Stmt); + + New_Const_Decl (Info.Block_Rti_Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Instance); + + Start_Const_Value (Info.Block_Rti_Const); + Start_Record_Aggr (List, Ghdl_Rtin_Instance); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El + (List, New_Offsetof (Get_Scope_Type + (Get_Info (Get_Parent (Stmt)).Block_Scope), + Info.Block_Link_Field, + Ghdl_Ptr_Type)); + New_Record_Aggr_El (List, New_Rti_Address (Parent)); + if Is_Component_Instantiation (Stmt) then + Val := New_Rti_Address + (Get_Info (Get_Named_Entity (Inst)).Comp_Rti_Const); + else + declare + Ent : constant Iir := Get_Entity_From_Entity_Aspect (Inst); + begin + Val := New_Rti_Address (Get_Info (Ent).Block_Rti_Const); + end; + end if; + + New_Record_Aggr_El (List, Val); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Block_Rti_Const, Val); + Add_Rti_Node (Info.Block_Rti_Const); + end Generate_Instance; + + procedure Generate_Psl_Directive (Stmt : Iir) + is + Name : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + Res : O_Cnode; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Name := Generate_Name (Stmt); + + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Type_Scalar); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Psl_Assert)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Rti, Res); + Info.Psl_Rti_Const := Rti; + Pop_Identifier_Prefix (Mark); + end Generate_Psl_Directive; + + procedure Generate_Declaration_Chain (Chain : Iir) + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Anonymous_Type_Declaration => + -- Handled in subtype declaration. + null; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Add_Rti_Node (Generate_Type_Decl (Decl)); + when Iir_Kind_Constant_Declaration => + -- Do not generate RTIs for full declarations. + -- (RTI will be generated for the deferred declaration). + if Get_Deferred_Declaration (Decl) = Null_Iir + or else Get_Deferred_Declaration_Flag (Decl) + then + declare + Info : Object_Info_Acc; + begin + Info := Get_Info (Decl); + Generate_Object (Decl, Info.Object_Rti); + Add_Rti_Node (Info.Object_Rti); + end; + end if; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Stable_Attribute => + declare + Info : Object_Info_Acc; + begin + Info := Get_Info (Decl); + Generate_Object (Decl, Info.Object_Rti); + Add_Rti_Node (Info.Object_Rti); + end; + when Iir_Kind_Delayed_Attribute => + -- FIXME: to be added. + null; + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Attribute_Declaration => + declare + Rti : O_Dnode := O_Dnode_Null; + begin + Generate_Object (Decl, Rti); + Add_Rti_Node (Rti); + end; + when Iir_Kind_Component_Declaration => + Generate_Component_Declaration (Decl); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- FIXME: to be added (for foreign). + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- Already handled by Translate_Subprogram_Body. + null; + when Iir_Kind_Configuration_Specification + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when others => + Error_Kind ("rti.generate_declaration_chain", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Generate_Declaration_Chain; + + procedure Generate_Concurrent_Statement_Chain + (Chain : Iir; Parent_Rti : O_Dnode) + is + Stmt : Iir; + Mark : Id_Mark_Type; + begin + Stmt := Chain; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Generate_Block (Stmt, Parent_Rti); + Pop_Identifier_Prefix (Mark); + when Iir_Kind_Component_Instantiation_Statement => + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Generate_Instance (Stmt, Parent_Rti); + Pop_Identifier_Prefix (Mark); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + Generate_Psl_Directive (Stmt); + when Iir_Kind_Psl_Cover_Statement => + Generate_Psl_Directive (Stmt); + when others => + Error_Kind ("rti.generate_concurrent_statement_chain", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Generate_Concurrent_Statement_Chain; + + procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode) + is + Name : O_Dnode; + Arr : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + + Kind : O_Cnode; + Res : O_Cnode; + + Prev : Rti_Block; + Info : Ortho_Info_Acc; + + Field_Off : O_Cnode; + Inst : O_Tnode; + begin + -- The type of a generator iterator is elaborated in the parent. + if Get_Kind (Blk) = Iir_Kind_Generate_Statement then + declare + Scheme : Iir; + Iter_Type : Iir; + Type_Info : Type_Info_Acc; + Mark : Id_Mark_Type; + Tmp : O_Dnode; + begin + Scheme := Get_Generation_Scheme (Blk); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Type_Info := Get_Info (Iter_Type); + if Type_Info.Type_Rti = O_Dnode_Null then + Push_Identifier_Prefix (Mark, "ITERATOR"); + Tmp := Generate_Type_Definition (Iter_Type); + Add_Rti_Node (Tmp); + Pop_Identifier_Prefix (Mark); + end if; + end if; + end; + end if; + + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Block); + Push_Rti_Node (Prev); + + Field_Off := O_Cnode_Null; + Inst := O_Tnode_Null; + Info := Get_Info (Blk); + case Get_Kind (Blk) is + when Iir_Kind_Package_Declaration => + Kind := Ghdl_Rtik_Package; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + when Iir_Kind_Package_Body => + Kind := Ghdl_Rtik_Package_Body; + -- Required at least for 'image + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + when Iir_Kind_Architecture_Body => + Kind := Ghdl_Rtik_Architecture; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Info.Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); + when Iir_Kind_Entity_Declaration => + Kind := Ghdl_Rtik_Entity; + Generate_Declaration_Chain (Get_Generic_Chain (Blk)); + Generate_Declaration_Chain (Get_Port_Chain (Blk)); + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Kind := Ghdl_Rtik_Process; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Field_Off := + Get_Scope_Offset (Info.Process_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Process_Scope); + when Iir_Kind_Block_Statement => + Kind := Ghdl_Rtik_Block; + declare + Guard : constant Iir := Get_Guard_Decl (Blk); + Header : constant Iir := Get_Block_Header (Blk); + Guard_Info : Object_Info_Acc; + begin + if Guard /= Null_Iir then + Guard_Info := Get_Info (Guard); + Generate_Object (Guard, Guard_Info.Object_Rti); + Add_Rti_Node (Guard_Info.Object_Rti); + end if; + if Header /= Null_Iir then + Generate_Declaration_Chain (Get_Generic_Chain (Header)); + Generate_Declaration_Chain (Get_Port_Chain (Header)); + end if; + end; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Field_Off := Get_Scope_Offset (Info.Block_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Block_Scope); + when Iir_Kind_Generate_Statement => + declare + Scheme : constant Iir := Get_Generation_Scheme (Blk); + Scheme_Rti : O_Dnode := O_Dnode_Null; + begin + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Generate_Object (Scheme, Scheme_Rti); + Add_Rti_Node (Scheme_Rti); + Kind := Ghdl_Rtik_For_Generate; + else + Kind := Ghdl_Rtik_If_Generate; + end if; + end; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); + when others => + Error_Kind ("rti.generate_block", Blk); + end case; + + Name := Generate_Name (Blk); + + Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Block); + New_Record_Aggr_El (List, Generate_Common (Kind)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + if Field_Off = O_Cnode_Null then + Field_Off := Get_Null_Loc; + end if; + New_Record_Aggr_El (List, Field_Off); + if Parent_Rti = O_Dnode_Null then + Res := New_Null_Access (Ghdl_Rti_Access); + else + Res := New_Rti_Address (Parent_Rti); + end if; + New_Record_Aggr_El (List, Res); + if Inst = O_Tnode_Null then + Res := Ghdl_Index_0; + else + Res := New_Sizeof (Inst, Ghdl_Index_Type); + end if; + New_Record_Aggr_El (List, Res); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr))); + New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Rti, Res); + + Pop_Rti_Node (Prev); + + -- Put children in the parent list. + case Get_Kind (Blk) is + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Add_Rti_Node (Rti); + when others => + null; + end case; + + -- Store the RTI. + case Get_Kind (Blk) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Info.Block_Rti_Const := Rti; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Info.Process_Rti_Const := Rti; + when Iir_Kind_Package_Declaration => + Info.Package_Rti_Const := Rti; + when Iir_Kind_Package_Body => + -- Replace package declaration RTI with the body one. + Get_Info (Get_Package (Blk)).Package_Rti_Const := Rti; + when others => + Error_Kind ("rti.generate_block", Blk); + end case; + end Generate_Block; + + procedure Generate_Library (Lib : Iir_Library_Declaration; + Public : Boolean) + is + use Name_Table; + Info : Library_Info_Acc; + Id : Name_Id; + Val : O_Cnode; + Aggr : O_Record_Aggr_List; + Name : O_Dnode; + Storage : O_Storage; + begin + Info := Get_Info (Lib); + if Info /= null then + return; + end if; + Info := Add_Info (Lib, Kind_Library); + + if Lib = Libraries.Work_Library then + Id := Libraries.Work_Library_Name; + else + Id := Get_Identifier (Lib); + end if; + + if Public then + Storage := O_Storage_Public; + else + Storage := O_Storage_External; + end if; + + New_Const_Decl (Info.Library_Rti_Const, + Create_Identifier_Without_Prefix (Id, "__RTI"), + Storage, Ghdl_Rtin_Type_Scalar); + + if Public then + Image (Id); + Name := Create_String + (Name_Buffer (1 .. Name_Length), + Create_Identifier_Without_Prefix (Id, "__RTISTR")); + Start_Const_Value (Info.Library_Rti_Const); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Library)); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Library_Rti_Const, Val); + end if; + end Generate_Library; + + procedure Generate_Unit (Lib_Unit : Iir) + is + Rti : O_Dnode; + Info : Ortho_Info_Acc; + Mark : Id_Mark_Type; + begin + Info := Get_Info (Lib_Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Configuration_Declaration => + return; + when Iir_Kind_Architecture_Body => + if Info.Block_Rti_Const /= O_Dnode_Null then + return; + end if; + when Iir_Kind_Package_Body => + Push_Identifier_Prefix (Mark, "BODY"); + when others => + null; + end case; + + -- Declare node. + if Global_Storage = O_Storage_External then + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_External, Ghdl_Rtin_Block); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration => + declare + Prev : Rti_Block; + begin + Push_Rti_Node (Prev); + Generate_Declaration_Chain + (Get_Declaration_Chain (Lib_Unit)); + Pop_Rti_Node (Prev); + end; + when others => + null; + end case; + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body => + Info.Block_Rti_Const := Rti; + when Iir_Kind_Package_Declaration => + Info.Package_Rti_Const := Rti; + when Iir_Kind_Package_Body => + -- Replace package declaration RTI with the body one. + Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const := Rti; + when others => + null; + end case; + else + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration => + declare + Lib : Iir_Library_Declaration; + begin + Lib := Get_Library (Get_Design_File + (Get_Design_Unit (Lib_Unit))); + Generate_Library (Lib, False); + Rti := Get_Info (Lib).Library_Rti_Const; + end; + when Iir_Kind_Package_Body => + Rti := Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const; + when Iir_Kind_Architecture_Body => + Rti := Get_Info (Get_Entity (Lib_Unit)).Block_Rti_Const; + when others => + raise Internal_Error; + end case; + Generate_Block (Lib_Unit, Rti); + end if; + + if Get_Kind (Lib_Unit) = Iir_Kind_Package_Body then + Pop_Identifier_Prefix (Mark); + end if; + end Generate_Unit; + + procedure Generate_Top (Nbr_Pkgs : out Natural) + is + use Configuration; + + Unit : Iir_Design_Unit; + Lib : Iir_Library_Declaration; + Prev : Rti_Block; + begin + Push_Rti_Node (Prev); + + -- Generate RTI for libraries, count number of packages. + Nbr_Pkgs := 1; -- At least std.standard. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + + -- Generate RTI for the library. + Lib := Get_Library (Get_Design_File (Unit)); + Generate_Library (Lib, True); + + if Get_Kind (Get_Library_Unit (Unit)) + = Iir_Kind_Package_Declaration + then + Nbr_Pkgs := Nbr_Pkgs + 1; + end if; + end loop; + + Pop_Rti_Node (Prev); + end Generate_Top; + + function Get_Context_Rti (Node : Iir) return O_Cnode + is + Node_Info : Ortho_Info_Acc; + + Rti_Const : O_Dnode; + begin + Node_Info := Get_Info (Node); + + case Get_Kind (Node) is + when Iir_Kind_Component_Declaration => + Rti_Const := Node_Info.Comp_Rti_Const; + when Iir_Kind_Component_Instantiation_Statement => + Rti_Const := Node_Info.Block_Rti_Const; + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Rti_Const := Node_Info.Block_Rti_Const; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + Rti_Const := Node_Info.Package_Rti_Const; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Rti_Const := Node_Info.Process_Rti_Const; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Rti_Const := Node_Info.Psl_Rti_Const; + when others => + Error_Kind ("get_context_rti", Node); + end case; + return New_Rti_Address (Rti_Const); + end Get_Context_Rti; + + function Get_Context_Addr (Node : Iir) return O_Enode + is + Node_Info : constant Ortho_Info_Acc := Get_Info (Node); + Ref : O_Lnode; + begin + case Get_Kind (Node) is + when Iir_Kind_Component_Declaration => + Ref := Get_Instance_Ref (Node_Info.Comp_Scope); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Ref := Get_Instance_Ref (Node_Info.Block_Scope); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + return New_Lit (New_Null_Access (Ghdl_Ptr_Type)); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Ref := Get_Instance_Ref (Node_Info.Process_Scope); + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Ref := Get_Instance_Ref (Node_Info.Psl_Scope); + when others => + Error_Kind ("get_context_addr", Node); + end case; + return New_Unchecked_Address (Ref, Ghdl_Ptr_Type); + end Get_Context_Addr; + + procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir) + is + begin + New_Association (Assoc, New_Lit (Get_Context_Rti (Node))); + New_Association (Assoc, Get_Context_Addr (Node)); + end Associate_Rti_Context; + + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List) is + begin + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Rti_Access))); + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end Associate_Null_Rti_Context; + end Rtis; + + procedure Gen_Filename (Design_File : Iir) + is + Info : Design_File_Info_Acc; + begin + if Current_Filename_Node /= O_Dnode_Null then + raise Internal_Error; + end if; + Info := Get_Info (Design_File); + if Info = null then + Info := Add_Info (Design_File, Kind_Design_File); + Info.Design_Filename := Create_String + (Get_Design_File_Filename (Design_File), + Create_Uniq_Identifier, O_Storage_Private); + end if; + Current_Filename_Node := Info.Design_Filename; + end Gen_Filename; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Translate (Unit : Iir_Design_Unit; Main : Boolean) + is + Design_File : Iir_Design_File; + El : Iir; + Lib : Iir_Library_Declaration; + Lib_Mark, Ent_Mark, Sep_Mark, Unit_Mark : Id_Mark_Type; + Id : Name_Id; + begin + Update_Node_Infos; + + Design_File := Get_Design_File (Unit); + + if False then + El := Get_Context_Items (Unit); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Library_Clause => + null; + when others => + Error_Kind ("translate1", El); + end case; + El := Get_Chain (El); + end loop; + end if; + + El := Get_Library_Unit (Unit); + if Flags.Verbose then + Ada.Text_IO.Put ("translating "); + if Main then + Ada.Text_IO.Put ("(with code generation) "); + end if; + Ada.Text_IO.Put_Line (Disp_Node (El)); + end if; + + -- Create the prefix for identifiers. + Lib := Get_Library (Get_Design_File (Unit)); + Reset_Identifier_Prefix; + if Lib = Libraries.Work_Library then + Id := Libraries.Work_Library_Name; + else + Id := Get_Identifier (Lib); + end if; + Push_Identifier_Prefix (Lib_Mark, Id); + + if Get_Kind (El) = Iir_Kind_Architecture_Body then + -- Put 'ARCH' between the entity name and the architecture name, to + -- avoid a name clash with names from entity (eg an entity port with + -- the same name as an architecture). + Push_Identifier_Prefix (Ent_Mark, Get_Identifier (Get_Entity (El))); + Push_Identifier_Prefix (Sep_Mark, "ARCH"); + end if; + Id := Get_Identifier (El); + if Id /= Null_Identifier then + Push_Identifier_Prefix (Unit_Mark, Id); + end if; + + if Main then + Set_Global_Storage (O_Storage_Public); + -- Create the variable containing the current file name. + Gen_Filename (Get_Design_File (Unit)); + else + Set_Global_Storage (O_Storage_External); + end if; + + New_Debug_Filename_Decl + (Name_Table.Image (Get_Design_File_Filename (Design_File))); + + Current_Library_Unit := El; + + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + New_Debug_Comment_Decl + ("package declaration " & Image_Identifier (El)); + Chap2.Translate_Package_Declaration (El); + when Iir_Kind_Package_Body => + New_Debug_Comment_Decl ("package body " & Image_Identifier (El)); + Chap2.Translate_Package_Body (El); + when Iir_Kind_Package_Instantiation_Declaration => + New_Debug_Comment_Decl + ("package instantiation " & Image_Identifier (El)); + Chap2.Translate_Package_Instantiation_Declaration (El); + when Iir_Kind_Entity_Declaration => + New_Debug_Comment_Decl ("entity " & Image_Identifier (El)); + Chap1.Translate_Entity_Declaration (El); + when Iir_Kind_Architecture_Body => + New_Debug_Comment_Decl ("architecture " & Image_Identifier (El)); + Chap1.Translate_Architecture_Body (El); + when Iir_Kind_Configuration_Declaration => + New_Debug_Comment_Decl ("configuration " & Image_Identifier (El)); + if Id = Null_Identifier then + declare + Mark : Id_Mark_Type; + Mark_Entity : Id_Mark_Type; + Mark_Arch : Id_Mark_Type; + Mark_Sep : Id_Mark_Type; + Arch : Iir; + Entity : constant Iir := Get_Entity (El); + begin + -- Note: this is done inside the architecture identifier. + Push_Identifier_Prefix + (Mark_Entity, Get_Identifier (Entity)); + Arch := Get_Block_Specification + (Get_Block_Configuration (El)); + Push_Identifier_Prefix (Mark_Sep, "ARCH"); + Push_Identifier_Prefix (Mark_Arch, Get_Identifier (Arch)); + Push_Identifier_Prefix + (Mark, Name_Table.Get_Identifier ("DEFAULT_CONFIG")); + Chap1.Translate_Configuration_Declaration (El); + Pop_Identifier_Prefix (Mark); + Pop_Identifier_Prefix (Mark_Arch); + Pop_Identifier_Prefix (Mark_Sep); + Pop_Identifier_Prefix (Mark_Entity); + end; + else + Chap1.Translate_Configuration_Declaration (El); + end if; + when others => + Error_Kind ("translate", El); + end case; + + Current_Filename_Node := O_Dnode_Null; + Current_Library_Unit := Null_Iir; + + --Pop_Global_Factory; + if Id /= Null_Identifier then + Pop_Identifier_Prefix (Unit_Mark); + end if; + if Get_Kind (El) = Iir_Kind_Architecture_Body then + Pop_Identifier_Prefix (Sep_Mark); + Pop_Identifier_Prefix (Ent_Mark); + end if; + Pop_Identifier_Prefix (Lib_Mark); + end Translate; + + procedure Initialize + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + -- Create the node extension for translate. + Node_Infos.Init; + Node_Infos.Set_Last (4); + Node_Infos.Table (0 .. 4) := (others => null); + + -- Force to unnest subprograms is the code generator doesn't support + -- nested subprograms. + if not Ortho_Nodes.Has_Nested_Subprograms then + Flag_Unnest_Subprograms := True; + end if; + + New_Debug_Comment_Decl ("internal declarations, part 1"); + + -- Create well known identifiers. + Wki_This := Get_Identifier ("this"); + Wki_Size := Get_Identifier ("size"); + Wki_Res := Get_Identifier ("res"); + Wki_Dir_To := Get_Identifier ("dir_to"); + Wki_Dir_Downto := Get_Identifier ("dir_downto"); + Wki_Left := Get_Identifier ("left"); + Wki_Right := Get_Identifier ("right"); + Wki_Dir := Get_Identifier ("dir"); + Wki_Length := Get_Identifier ("length"); + Wki_I := Get_Identifier ("I"); + Wki_Instance := Get_Identifier ("INSTANCE"); + Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE"); + Wki_Name := Get_Identifier ("NAME"); + Wki_Sig := Get_Identifier ("sig"); + Wki_Obj := Get_Identifier ("OBJ"); + Wki_Rti := Get_Identifier ("RTI"); + Wki_Parent := Get_Identifier ("parent"); + Wki_Filename := Get_Identifier ("filename"); + Wki_Line := Get_Identifier ("line"); + Wki_Lo := Get_Identifier ("lo"); + Wki_Hi := Get_Identifier ("hi"); + Wki_Mid := Get_Identifier ("mid"); + Wki_Cmp := Get_Identifier ("cmp"); + Wki_Upframe := Get_Identifier ("UPFRAME"); + Wki_Frame := Get_Identifier ("FRAME"); + Wki_Val := Get_Identifier ("val"); + Wki_L_Len := Get_Identifier ("l_len"); + Wki_R_Len := Get_Identifier ("r_len"); + + Sizetype := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); + + -- Create __ghdl_index_type, which is the type for *all* array index. + Ghdl_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_index_type"), Ghdl_Index_Type); + + Ghdl_Index_0 := New_Unsigned_Literal (Ghdl_Index_Type, 0); + Ghdl_Index_1 := New_Unsigned_Literal (Ghdl_Index_Type, 1); + + Ghdl_I32_Type := New_Signed_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_i32"), Ghdl_I32_Type); + + Ghdl_Real_Type := New_Float_Type; + New_Type_Decl (Get_Identifier ("__ghdl_real"), Ghdl_Real_Type); + + if not Flag_Only_32b then + Ghdl_I64_Type := New_Signed_Type (64); + New_Type_Decl (Get_Identifier ("__ghdl_i64"), Ghdl_I64_Type); + end if; + + -- File index for elaborated file object. + Ghdl_File_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_file_index"), + Ghdl_File_Index_Type); + Ghdl_File_Index_Ptr_Type := New_Access_Type (Ghdl_File_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_file_index_ptr"), + Ghdl_File_Index_Ptr_Type); + + -- Create char, char [] and char *. + Char_Type_Node := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_char"), Char_Type_Node); + + Chararray_Type := New_Array_Type (Char_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_chararray"), Chararray_Type); + + Char_Ptr_Type := New_Access_Type (Chararray_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr"), Char_Ptr_Type); + + Char_Ptr_Array_Type := New_Array_Type (Char_Ptr_Type, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array"), + Char_Ptr_Array_Type); + + Char_Ptr_Array_Ptr_Type := New_Access_Type (Char_Ptr_Array_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array_ptr"), + Char_Ptr_Array_Ptr_Type); + + -- Generic pointer. + Ghdl_Ptr_Type := New_Access_Type (Char_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_ptr"), Ghdl_Ptr_Type); + + -- Create record + -- len : natural; + -- str : C_String; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Str_Len_Type_Len_Field, + Get_Identifier ("len"), Ghdl_Index_Type); + New_Record_Field + (Constr, Ghdl_Str_Len_Type_Str_Field, + Get_Identifier ("str"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len"), + Ghdl_Str_Len_Type_Node); + end; + + Ghdl_Str_Len_Array_Type_Node := New_Array_Type + (Ghdl_Str_Len_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_array"), + Ghdl_Str_Len_Array_Type_Node); + + -- Create type __ghdl_str_len_ptr is access all __ghdl_str_len + Ghdl_Str_Len_Ptr_Node := New_Access_Type (Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_ptr"), + Ghdl_Str_Len_Ptr_Node); + + -- Create type __ghdl_bool_type is (false, true) + New_Boolean_Type (Ghdl_Bool_Type, + Get_Identifier ("false"), + Ghdl_Bool_False_Node, + Get_Identifier ("true"), + Ghdl_Bool_True_Node); + New_Type_Decl (Get_Identifier ("__ghdl_bool_type"), + Ghdl_Bool_Type); + + -- __ghdl_bool_array is array (ghdl_index_type) of ghdl_bool_type + Ghdl_Bool_Array_Type := + New_Array_Type (Ghdl_Bool_Type, Ghdl_Index_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_type"), Ghdl_Bool_Array_Type); + + -- __ghdl_bool_array_ptr is access __ghdl_bool_array; + Ghdl_Bool_Array_Ptr := New_Access_Type (Ghdl_Bool_Array_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_ptr"), Ghdl_Bool_Array_Ptr); + + -- Create type ghdl_compare_type is (lt, eq, ge); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Get_Identifier ("lt"), Ghdl_Compare_Lt); + New_Enum_Literal (Constr, Get_Identifier ("eq"), Ghdl_Compare_Eq); + New_Enum_Literal (Constr, Get_Identifier ("gt"), Ghdl_Compare_Gt); + Finish_Enum_Type (Constr, Ghdl_Compare_Type); + New_Type_Decl (Get_Identifier ("__ghdl_compare_type"), + Ghdl_Compare_Type); + end; + + -- Create: + -- type __ghdl_location is record + -- file : char_ptr_type; + -- line : ghdl_i32; + -- col : ghdl_i32; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field + (Constr, Ghdl_Location_Filename_Node, Wki_Filename, Char_Ptr_Type); + New_Record_Field + (Constr, Ghdl_Location_Line_Node, Wki_Line, Ghdl_I32_Type); + New_Record_Field (Constr, Ghdl_Location_Col_Node, + Get_Identifier ("col"), + Ghdl_I32_Type); + Finish_Record_Type (Constr, Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location"), + Ghdl_Location_Type_Node); + end; + -- Create type __ghdl_location_ptr is access __ghdl_location; + Ghdl_Location_Ptr_Node := New_Access_Type (Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location_ptr"), + Ghdl_Location_Ptr_Node); + + -- Create type ghdl_dir_type is (dir_to, dir_downto); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Wki_Dir_To, Ghdl_Dir_To_Node); + New_Enum_Literal (Constr, Wki_Dir_Downto, Ghdl_Dir_Downto_Node); + Finish_Enum_Type (Constr, Ghdl_Dir_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_dir_type"), + Ghdl_Dir_Type_Node); + end; + + -- Create void* __ghdl_alloc (unsigned size); + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_alloc"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Sizetype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Alloc_Ptr); + + -- procedure __ghdl_program_error (filename : char_ptr_type; + -- line : ghdl_i32; + -- code : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_program_error"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("code"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Program_Error); + + -- procedure __ghdl_bound_check_failed_l1 (filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_bound_check_failed_l1"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Bound_Check_Failed_L1); + + -- Secondary stack subprograms. + -- function __ghdl_stack2_allocate (size : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_allocate"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Allocate); + + -- function __ghdl_stack2_mark return ghdl_ptr_type; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_stack2_mark"), + O_Storage_External, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Mark); + + -- procedure __ghdl_stack2_release (mark : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_release"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mark"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Release); + + -- procedure __ghdl_memcpy (dest : ghdl_ptr_type; + -- src : ghdl_ptr_type; + -- length : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_memcpy"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("dest"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Memcpy); + + -- procedure __ghdl_deallocate (ptr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_deallocate"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Deallocate); + + -- function __ghdl_malloc (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc); + + -- function __ghdl_malloc0 (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc0"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc0); + + -- function __ghdl_text_file_elaborate return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Elaborate); + + -- function __ghdl_file_elaborate (name : char_ptr_type) + -- return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Name, Char_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Elaborate); + + -- procedure __ghdl_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Finalize); + + -- procedure __ghdl_text_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Finalize); + + declare + procedure Create_Protected_Subprg + (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Protected_Subprg; + begin + -- procedure __ghdl_protected_enter (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_enter", Ghdl_Protected_Enter); + + -- procedure __ghdl_protected_leave (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_leave", Ghdl_Protected_Leave); + + Create_Protected_Subprg + ("__ghdl_protected_init", Ghdl_Protected_Init); + + Create_Protected_Subprg + ("__ghdl_protected_fini", Ghdl_Protected_Fini); + end; + + if Flag_Rti then + Rtis.Rti_Initialize; + end if; + + -- procedure __ghdl_signal_name_rti + -- (obj : ghdl_rti_access; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_name_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Name_Rti); + + declare + -- procedure NAME (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + procedure Create_Process_Register (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Process_Register; + begin + Create_Process_Register ("__ghdl_process_register", + Ghdl_Process_Register); + Create_Process_Register ("__ghdl_sensitized_process_register", + Ghdl_Sensitized_Process_Register); + Create_Process_Register ("__ghdl_postponed_process_register", + Ghdl_Postponed_Process_Register); + Create_Process_Register + ("__ghdl_postponed_sensitized_process_register", + Ghdl_Postponed_Sensitized_Process_Register); + end; + + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_finalize_register"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Finalize_Register); + end Initialize; + + procedure Create_Signal_Subprograms + (Suffix : String; + Val_Type : O_Tnode; + Create_Signal : out O_Dnode; + Init_Signal : out O_Dnode; + Simple_Assign : out O_Dnode; + Start_Assign : out O_Dnode; + Next_Assign : out O_Dnode; + Associate_Value : out O_Dnode; + Driving_Value : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + -- function __ghdl_create_signal_XXX (init_val : VAL_TYPE) + -- resolv_func : ghdl_ptr_type; + -- resolv_inst : ghdl_ptr_type; + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_signal_" & Suffix), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("init_val"), Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_func"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_inst"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Create_Signal); + + -- procedure __ghdl_signal_init_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_init_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); + Finish_Subprogram_Decl (Interfaces, Init_Signal); + + -- procedure __ghdl_signal_simple_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); + Finish_Subprogram_Decl (Interfaces, Simple_Assign); + + -- procedure __ghdl_signal_start_assign_XXX (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Start_Assign); + + -- procedure __ghdl_signal_next_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Next_Assign); + + -- procedure __ghdl_signal_associate_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_associate_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + Finish_Subprogram_Decl (Interfaces, Associate_Value); + + -- function __ghdl_signal_driving_value_XXX (sign : __ghdl_signal_ptr) + -- return VAL_TYPE; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving_value_" & Suffix), + O_Storage_External, Val_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Driving_Value); + end Create_Signal_Subprograms; + + -- procedure __ghdl_image_NAME (res : std_string_ptr_node; + -- val : VAL_TYPE; + -- rti : ghdl_rti_access); + -- + -- function __ghdl_value_NAME (val : std_string_ptr_node; + -- rti : ghdl_rti_access); + -- return VAL_TYPE; + procedure Create_Image_Value_Subprograms (Name : String; + Val_Type : O_Tnode; + Has_Td : Boolean; + Image_Subprg : out O_Dnode; + Value_Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_image_" & Name), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("res"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Val_Type); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Image_Subprg); + + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_value_" & Name), + O_Storage_External, Val_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Std_String_Ptr_Node); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Value_Subprg); + end Create_Image_Value_Subprograms; + + -- function __ghdl_std_ulogic_match_NAME (l : __ghdl_e8; r : __ghdl_e8) + -- return __ghdl_e8; + procedure Create_Std_Ulogic_Match_Subprogram (Name : String; + Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_std_ulogic_match_" & Name), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Std_Ulogic_Match_Subprogram; + + -- function __ghdl_std_ulogic_array_match_NAME + -- (l : __ghdl_ptr; l_len : ghdl_index_type; + -- r : __ghdl_ptr; r_len : ghdl_index_type) + -- return __ghdl_i32; + procedure Create_Std_Ulogic_Array_Match_Subprogram (Name : String; + Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_std_ulogic_array_match_" & Name), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_L_Len, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_R_Len, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Std_Ulogic_Array_Match_Subprogram; + + -- procedure NAME (res : std_string_ptr_node; + -- val : VAL_TYPE; + -- ARG2_NAME : ARG2_TYPE); + procedure Create_To_String_Subprogram (Name : String; + Subprg : out O_Dnode; + Val_Type : O_Tnode; + Arg2_Type : O_Tnode := O_Tnode_Null; + Arg2_Id : O_Ident := O_Ident_Nul; + Arg3_Type : O_Tnode := O_Tnode_Null; + Arg3_Id : O_Ident := O_Ident_Nul) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Val_Type); + if Arg2_Type /= O_Tnode_Null then + New_Interface_Decl + (Interfaces, Param, Arg2_Id, Arg2_Type); + if Arg3_Type /= O_Tnode_Null then + New_Interface_Decl + (Interfaces, Param, Arg3_Id, Arg3_Type); + end if; + end if; + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_To_String_Subprogram; + + -- Do internal declarations that need std.standard declarations. + procedure Post_Initialize + is + Interfaces : O_Inter_List; + Rec : O_Element_List; + Param : O_Dnode; + Info : Type_Info_Acc; + begin + New_Debug_Comment_Decl ("internal declarations, part 2"); + + -- Remember some pervasive types. + Info := Get_Info (String_Type_Definition); + Std_String_Node := Info.Ortho_Type (Mode_Value); + Std_String_Ptr_Node := Info.Ortho_Ptr_Type (Mode_Value); + + Std_Integer_Otype := + Get_Ortho_Type (Integer_Type_Definition, Mode_Value); + Std_Real_Otype := + Get_Ortho_Type (Real_Type_Definition, Mode_Value); + Std_Time_Otype := Get_Ortho_Type (Time_Type_Definition, Mode_Value); + + -- __ghdl_now : time; + -- ??? maybe this should be a function ? + New_Var_Decl (Ghdl_Now, Get_Identifier ("__ghdl_now"), + O_Storage_External, Std_Time_Otype); + + -- procedure __ghdl_assert_failed (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + + -- procedure __ghdl_report (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + declare + procedure Create_Report_Subprg (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("msg"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("severity"), + Get_Ortho_Type (Severity_Level_Type_Definition, Mode_Value)); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("location"), + Ghdl_Location_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Report_Subprg; + begin + Create_Report_Subprg + ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg + ("__ghdl_ieee_assert_failed", Ghdl_Ieee_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_assert_failed", + Ghdl_Psl_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_cover", Ghdl_Psl_Cover); + Create_Report_Subprg ("__ghdl_psl_cover_failed", + Ghdl_Psl_Cover_Failed); + Create_Report_Subprg ("__ghdl_report", Ghdl_Report); + end; + + -- procedure __ghdl_text_write (file : __ghdl_file_index; + -- str : std_string_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_write"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Write); + + -- function __ghdl_text_read_length (file : __ghdl_file_index; + -- str : std_string_ptr) + -- return std__standard_integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_read_length"), + O_Storage_External, Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Read_Length); + + -- procedure __ghdl_write_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_write_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Write_Scalar); + + -- procedure __ghdl_read_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_read_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Read_Scalar); + + -- function __ghdl_real_exp (left : std__standard__real; + -- right : std__standard__integer) + -- return std__standard__real; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_real_exp"), O_Storage_External, + Std_Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("left"), + Std_Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("right"), + Std_Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Real_Exp); + + -- function __ghdl_integer_exp (left : std__standard__integer; + -- right : std__standard__integer) + -- return std__standard__integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_integer_exp"), O_Storage_External, + Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Left, Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Integer_Exp); + + + -- procedure __ghdl_image_b1 (res : std_string_ptr_node; + -- val : ghdl_bool_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("b1", Ghdl_Bool_Type, True, Ghdl_Image_B1, Ghdl_Value_B1); + + -- procedure __ghdl_image_e8 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("e8", Ghdl_I32_Type, True, Ghdl_Image_E8, Ghdl_Value_E8); + + -- procedure __ghdl_image_e32 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("e32", Ghdl_I32_Type, True, Ghdl_Image_E32, Ghdl_Value_E32); + + -- procedure __ghdl_image_i32 (res : std_string_ptr_node; + -- val : ghdl_i32_type); + Create_Image_Value_Subprograms + ("i32", Ghdl_I32_Type, False, Ghdl_Image_I32, Ghdl_Value_I32); + + -- procedure __ghdl_image_p32 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("p32", Ghdl_I32_Type, True, Ghdl_Image_P32, Ghdl_Value_P32); + + -- procedure __ghdl_image_p64 (res : std_string_ptr_node; + -- val : ghdl_i64_type; + -- rti : ghdl_rti_access); + if not Flag_Only_32b then + Create_Image_Value_Subprograms + ("p64", Ghdl_I64_Type, True, Ghdl_Image_P64, Ghdl_Value_P64); + end if; + + -- procedure __ghdl_image_f64 (res : std_string_ptr_node; + -- val : ghdl_real_type); + Create_Image_Value_Subprograms + ("f64", Ghdl_Real_Type, False, Ghdl_Image_F64, Ghdl_Value_F64); + + ------------- + -- files -- + ------------- + + -- procedure __ghdl_text_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open); + + -- procedure __ghdl_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open); + + -- function __ghdl_text_file_open_status + -- (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open_Status); + + -- function __ghdl_file_open_status (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open_Status); + + -- function __ghdl_file_endfile (file : file_index_type) + -- return std_boolean_type_node; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_file_endfile"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Endfile); + + -- procedure __ghdl_text_file_close (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Close); + + -- procedure __ghdl_file_close (file : file_index_type); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Close); + + -- procedure __ghdl_file_flush (file : file_index_type); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_flush"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Flush); + + --------------- + -- signals -- + --------------- + + -- procedure __ghdl_signal_create_resolution + -- (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- sig : ghdl_ptr_type; + -- nbr_sig : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_resolution"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("nbr_sig"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Resolution); + + -- Declarations for signals. + -- Max length of a scalar type. + -- type __ghdl_scalar_bytes is __ghdl_chararray (0 .. 8); + Ghdl_Scalar_Bytes := New_Constrained_Array_Type + (Chararray_Type, New_Unsigned_Literal (Ghdl_Index_Type, 8)); + New_Type_Decl (Get_Identifier ("__ghdl_scalar_bytes"), + Ghdl_Scalar_Bytes); + + New_Uncomplete_Record_Type (Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal"), Ghdl_Signal_Type); + + Ghdl_Signal_Ptr := New_Access_Type (Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr"), Ghdl_Signal_Ptr); + + -- Type __signal_signal is record + Start_Uncomplete_Record_Type (Ghdl_Signal_Type, Rec); + New_Record_Field (Rec, Ghdl_Signal_Value_Field, + Get_Identifier ("value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Driving_Value_Field, + Get_Identifier ("driving_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Value_Field, + Get_Identifier ("last_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Event_Field, + Get_Identifier ("last_event"), + Std_Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Last_Active_Field, + Get_Identifier ("last_active"), + Std_Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Event_Field, + Get_Identifier ("event"), + Std_Boolean_Type_Node); + New_Record_Field (Rec, Ghdl_Signal_Active_Field, + Get_Identifier ("active"), + Std_Boolean_Type_Node); + New_Record_Field (Rec, Ghdl_Signal_Has_Active_Field, + Get_Identifier ("has_active"), + Ghdl_Bool_Type); + Finish_Record_Type (Rec, Ghdl_Signal_Type); + + Ghdl_Signal_Ptr_Ptr := New_Access_Type (Ghdl_Signal_Ptr); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr_ptr"), + Ghdl_Signal_Ptr_Ptr); + + -- procedure __ghdl_signal_merge_rti + -- (sig : ghdl_signal_ptr; rti : ghdl_rti_access) + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_merge_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Merge_Rti); + + -- procedure __ghdl_signal_add_source (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_add_source"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Source); + + -- procedure __ghdl_signal_effective_value (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_effective_value"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Effective_Value); + + -- procedure __ghdl_signal_set_disconnect (sig : __ghdl_signal_ptr; + -- val : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_set_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("time"), Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Set_Disconnect); + + -- procedure __ghdl_signal_disconnect (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Disconnect); + + -- function __ghdl_signal_get_nbr_drivers (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_drivers"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Drivers); + + -- function __ghdl_signal_get_nbr_sources (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_ports"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Ports); + + -- function __ghdl_signal_read_driver (sig : __ghdl_signal_ptr; + -- num : ghdl_index_type) + -- return ghdl_ptr_type; + declare + procedure Create_Signal_Read (Name : String; Subprg : out O_Dnode) is + begin + Start_Function_Decl + (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("num"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Signal_Read; + begin + Create_Signal_Read + ("__ghdl_signal_read_driver", Ghdl_Signal_Read_Driver); + Create_Signal_Read + ("__ghdl_signal_read_port", Ghdl_Signal_Read_Port); + end; + + -- function __ghdl_signal_driving (sig : __ghdl_signal_ptr) + -- return std_boolean; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Driving); + + -- procedure __ghdl_signal_simple_assign_error + -- (sig : __ghdl_signal_ptr; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Simple_Assign_Error); + + -- procedure __ghdl_signal_start_assign_error (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Error); + + -- procedure __ghdl_signal_next_assign_error (sig : __ghdl_signal_ptr; + -- after : std_time; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Error); + + -- procedure __ghdl_signal_start_assign_null (sig : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Null); + + -- procedure __ghdl_signal_next_assign_null (sig : __ghdl_signal_ptr; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Null); + + -- function __ghdl_create_signal_e8 (init_val : ghdl_i32_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_e8 (sign : __ghdl_signal_ptr; + -- val : __ghdl_integer); + Create_Signal_Subprograms ("e8", Ghdl_I32_Type, + Ghdl_Create_Signal_E8, + Ghdl_Signal_Init_E8, + Ghdl_Signal_Simple_Assign_E8, + Ghdl_Signal_Start_Assign_E8, + Ghdl_Signal_Next_Assign_E8, + Ghdl_Signal_Associate_E8, + Ghdl_Signal_Driving_Value_E8); + + -- function __ghdl_create_signal_e32 (init_val : ghdl_i32_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_e32 (sign : __ghdl_signal_ptr; + -- val : __ghdl_integer); + Create_Signal_Subprograms ("e32", Ghdl_I32_Type, + Ghdl_Create_Signal_E32, + Ghdl_Signal_Init_E32, + Ghdl_Signal_Simple_Assign_E32, + Ghdl_Signal_Start_Assign_E32, + Ghdl_Signal_Next_Assign_E32, + Ghdl_Signal_Associate_E32, + Ghdl_Signal_Driving_Value_E32); + + -- function __ghdl_create_signal_b1 (init_val : ghdl_bool_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_b1 (sign : __ghdl_signal_ptr; + -- val : ghdl_bool_type); + Create_Signal_Subprograms ("b1", Ghdl_Bool_Type, + Ghdl_Create_Signal_B1, + Ghdl_Signal_Init_B1, + Ghdl_Signal_Simple_Assign_B1, + Ghdl_Signal_Start_Assign_B1, + Ghdl_Signal_Next_Assign_B1, + Ghdl_Signal_Associate_B1, + Ghdl_Signal_Driving_Value_B1); + + Create_Signal_Subprograms ("i32", Ghdl_I32_Type, + Ghdl_Create_Signal_I32, + Ghdl_Signal_Init_I32, + Ghdl_Signal_Simple_Assign_I32, + Ghdl_Signal_Start_Assign_I32, + Ghdl_Signal_Next_Assign_I32, + Ghdl_Signal_Associate_I32, + Ghdl_Signal_Driving_Value_I32); + + Create_Signal_Subprograms ("f64", Ghdl_Real_Type, + Ghdl_Create_Signal_F64, + Ghdl_Signal_Init_F64, + Ghdl_Signal_Simple_Assign_F64, + Ghdl_Signal_Start_Assign_F64, + Ghdl_Signal_Next_Assign_F64, + Ghdl_Signal_Associate_F64, + Ghdl_Signal_Driving_Value_F64); + + if not Flag_Only_32b then + Create_Signal_Subprograms ("i64", Ghdl_I64_Type, + Ghdl_Create_Signal_I64, + Ghdl_Signal_Init_I64, + Ghdl_Signal_Simple_Assign_I64, + Ghdl_Signal_Start_Assign_I64, + Ghdl_Signal_Next_Assign_I64, + Ghdl_Signal_Associate_I64, + Ghdl_Signal_Driving_Value_I64); + end if; + + -- procedure __ghdl_process_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Sensitivity); + + -- procedure __ghdl_process_add_driver (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_driver"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Driver); + + -- procedure __ghdl_signal_add_direct_driver (sig : __ghdl_signal_ptr; + -- Drv : Ghdl_Ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_add_direct_driver"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("drv"), Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Direct_Driver); + + -- procedure __ghdl_signal_direct_assign (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_direct_assign"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Direct_Assign); + + declare + procedure Create_Signal_Conversion (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src_len"), Ghdl_Index_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst_len"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Conversion; + begin + -- procedure __ghdl_signal_in_conversion (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- src : ghdl_signal_ptr; + -- src_len : ghdl_index_type; + -- dst : ghdl_signal_ptr; + -- dst_len : ghdl_index_type); + Create_Signal_Conversion + ("__ghdl_signal_in_conversion", Ghdl_Signal_In_Conversion); + Create_Signal_Conversion + ("__ghdl_signal_out_conversion", Ghdl_Signal_Out_Conversion); + end; + + declare + -- function __ghdl_create_XXX_signal (val : std_time) + -- return __ghdl_signal_ptr; + procedure Create_Signal_Attribute (Name : String; Res : out O_Dnode) + is + begin + Start_Function_Decl (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Attribute; + begin + -- function __ghdl_create_stable_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_stable_signal", Ghdl_Create_Stable_Signal); + + -- function __ghdl_create_quiet_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_quiet_signal", Ghdl_Create_Quiet_Signal); + + -- function __ghdl_create_transaction_signal + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_transaction_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Transaction_Signal); + end; + + -- procedure __ghdl_signal_attribute_register_prefix + -- (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, + Get_Identifier ("__ghdl_signal_attribute_register_prefix"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl + (Interfaces, Ghdl_Signal_Attribute_Register_Prefix); + + -- function __ghdl_create_delayed_signal (sig : __ghdl_signal_ptr; + -- val : std_time) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_delayed_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("sig"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Delayed_Signal); + + -- function __ghdl_signal_create_guard + -- (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- instance_name : __ghdl_instance_name_acc) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_guard"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("this"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("proc"), + Ghdl_Ptr_Type); +-- New_Interface_Decl (Interfaces, Param, Get_Identifier ("instance_name"), +-- Ghdl_Instance_Name_Acc); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Guard); + + -- procedure __ghdl_signal_guard_dependence (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_guard_dependence"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Guard_Dependence); + + -- procedure __ghdl_process_wait_exit (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_exit"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Exit); + + -- void __ghdl_process_wait_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Timeout); + + -- void __ghdl_process_wait_set_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_set_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Set_Timeout); + + -- void __ghdl_process_wait_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Add_Sensitivity); + + -- function __ghdl_process_wait_suspend return __ghdl_bool_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_suspend"), + O_Storage_External, Ghdl_Bool_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Suspend); + + -- void __ghdl_process_wait_close (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_close"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Close); + + declare + procedure Create_Get_Name (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("name"), + Ghdl_Str_Len_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Get_Name; + begin + -- procedure __ghdl_get_path_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_path_name", Ghdl_Get_Path_Name); + + -- procedure __ghdl_get_instance_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_instance_name", Ghdl_Get_Instance_Name); + end; + + -- procedure __ghdl_rti_add_package (rti : ghdl_rti_access) + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_rti_add_package"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Package); + + -- procedure __ghdl_rti_add_top (max_pkgs : ghdl_index_type; + -- pkgs : ghdl_rti_arr_acc); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_rti_add_top"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("max_pkgs"), + Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("pkgs"), + Rtis.Ghdl_Rti_Arr_Acc); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + New_Interface_Decl + (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Top); + + -- Create match subprograms for std_ulogic type. + Create_Std_Ulogic_Match_Subprogram ("eq", Ghdl_Std_Ulogic_Match_Eq); + Create_Std_Ulogic_Match_Subprogram ("ne", Ghdl_Std_Ulogic_Match_Ne); + Create_Std_Ulogic_Match_Subprogram ("lt", Ghdl_Std_Ulogic_Match_Lt); + Create_Std_Ulogic_Match_Subprogram ("le", Ghdl_Std_Ulogic_Match_Le); + + Create_Std_Ulogic_Array_Match_Subprogram + ("eq", Ghdl_Std_Ulogic_Array_Match_Eq); + Create_Std_Ulogic_Array_Match_Subprogram + ("ne", Ghdl_Std_Ulogic_Array_Match_Ne); + + -- Create To_String subprograms. + Create_To_String_Subprogram + ("__ghdl_to_string_i32", Ghdl_To_String_I32, Ghdl_I32_Type); + Create_To_String_Subprogram + ("__ghdl_to_string_f64", Ghdl_To_String_F64, Ghdl_Real_Type); + Create_To_String_Subprogram + ("__ghdl_to_string_f64_digits", Ghdl_To_String_F64_Digits, + Ghdl_Real_Type, Ghdl_I32_Type, Get_Identifier ("nbr_digits")); + Create_To_String_Subprogram + ("__ghdl_to_string_f64_format", Ghdl_To_String_F64_Format, + Ghdl_Real_Type, Std_String_Ptr_Node, Get_Identifier ("format")); + declare + Bv_Base_Ptr : constant O_Tnode := + Get_Info (Bit_Vector_Type_Definition).T.Base_Ptr_Type (Mode_Value); + begin + Create_To_String_Subprogram + ("__ghdl_bv_to_ostring", Ghdl_BV_To_Ostring, + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); + Create_To_String_Subprogram + ("__ghdl_bv_to_hstring", Ghdl_BV_To_Hstring, + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); + end; + Create_To_String_Subprogram + ("__ghdl_to_string_b1", Ghdl_To_String_B1, Ghdl_Bool_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_e8", Ghdl_To_String_E8, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_char", Ghdl_To_String_Char, + Get_Ortho_Type (Character_Type_Definition, Mode_Value)); + Create_To_String_Subprogram + ("__ghdl_to_string_e32", Ghdl_To_String_E32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p32", Ghdl_To_String_P32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p64", Ghdl_To_String_P64, Ghdl_I64_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_timue_to_string_unit", Ghdl_Time_To_String_Unit, + Std_Time_Otype, Std_Time_Otype, Get_Identifier ("unit"), + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_b1", Ghdl_Array_Char_To_String_B1, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e8", Ghdl_Array_Char_To_String_E8, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e32", Ghdl_Array_Char_To_String_E32, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + + end Post_Initialize; + + procedure Translate_Type_Implicit_Subprograms (Decl : in out Iir) + is + Infos : Chap7.Implicit_Subprogram_Infos; + begin + -- Skip type declaration. + pragma Assert (Get_Kind (Decl) in Iir_Kinds_Type_Declaration); + Decl := Get_Chain (Decl); + + Chap7.Init_Implicit_Subprogram_Infos (Infos); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Chap7.Translate_Implicit_Subprogram (Decl, Infos); + Decl := Get_Chain (Decl); + when others => + exit; + end case; + end loop; + end Translate_Type_Implicit_Subprograms; + + procedure Translate_Standard (Main : Boolean) + is + Lib_Mark, Unit_Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + pragma Unreferenced (Info); + Decl : Iir; + Time_Type_Staticness : Iir_Staticness; + Time_Subtype_Staticness : Iir_Staticness; + begin + Update_Node_Infos; + + New_Debug_Comment_Decl ("package std.standard"); + if Main then + Gen_Filename (Std_Standard_File); + Set_Global_Storage (O_Storage_Public); + else + Set_Global_Storage (O_Storage_External); + end if; + + Info := Add_Info (Standard_Package, Kind_Package); + + Reset_Identifier_Prefix; + Push_Identifier_Prefix + (Lib_Mark, Get_Identifier (Libraries.Std_Library)); + Push_Identifier_Prefix + (Unit_Mark, Get_Identifier (Standard_Package)); + + -- With VHDL93 and later, time type is globally static. As a result, + -- it will be elaborated at run-time (and not statically). + -- However, there is no elaboration of std.standard. Furthermore, + -- time type can be pre-elaborated without any difficulties. + -- There is a kludge here: set type staticess of time type locally + -- and then revert it just after its translation. + Time_Type_Staticness := Get_Type_Staticness (Time_Type_Definition); + Time_Subtype_Staticness := Get_Type_Staticness (Time_Subtype_Definition); + if Flags.Flag_Time_64 then + Set_Type_Staticness (Time_Type_Definition, Locally); + end if; + Set_Type_Staticness (Time_Subtype_Definition, Locally); + if Flags.Vhdl_Std > Vhdl_87 then + Set_Type_Staticness (Delay_Length_Subtype_Definition, Locally); + end if; + + Decl := Get_Declaration_Chain (Standard_Package); + + -- The first (and one of the most important) declaration is the + -- boolean type declaration. + pragma Assert (Decl = Boolean_Type_Declaration); + Chap4.Translate_Bool_Type_Declaration (Boolean_Type_Declaration); + -- We need this type very early, for predefined functions. + Std_Boolean_Type_Node := + Get_Ortho_Type (Boolean_Type_Definition, Mode_Value); + Std_Boolean_True_Node := Get_Ortho_Expr (Boolean_True); + Std_Boolean_False_Node := Get_Ortho_Expr (Boolean_False); + + Std_Boolean_Array_Type := + New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"), + Std_Boolean_Array_Type); + Translate_Type_Implicit_Subprograms (Decl); + + -- Second declaration: bit. + pragma Assert (Decl = Bit_Type_Declaration); + Chap4.Translate_Bool_Type_Declaration (Bit_Type_Declaration); + Translate_Type_Implicit_Subprograms (Decl); + + -- Nothing special for other declarations. + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Type_Declaration => + Chap4.Translate_Type_Declaration (Decl); + Translate_Type_Implicit_Subprograms (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Chap4.Translate_Anonymous_Type_Declaration (Decl); + Translate_Type_Implicit_Subprograms (Decl); + when Iir_Kind_Subtype_Declaration => + Chap4.Translate_Subtype_Declaration (Decl); + Decl := Get_Chain (Decl); + when Iir_Kind_Attribute_Declaration => + Decl := Get_Chain (Decl); + when Iir_Kind_Implicit_Function_Declaration => + case Get_Implicit_Definition (Decl) is + when Iir_Predefined_Now_Function => + null; + when Iir_Predefined_Enum_To_String + | Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + -- These are defined after the types. + null; + when others => + Error_Kind + ("translate_standard (" + & Iir_Predefined_Functions'Image + (Get_Implicit_Definition (Decl)) & ")", + Decl); + end case; + Decl := Get_Chain (Decl); + when others => + Error_Kind ("translate_standard", Decl); + end case; + -- DECL was updated by Translate_Type_Implicit_Subprograms or + -- explicitly in other branches. + end loop; + + -- These types don't appear in std.standard. + Chap4.Translate_Anonymous_Type_Declaration + (Convertible_Integer_Type_Declaration); + Chap4.Translate_Anonymous_Type_Declaration + (Convertible_Real_Type_Declaration); + + -- Restore time type staticness. + + if Flags.Vhdl_Std > Vhdl_87 then + Set_Type_Staticness (Delay_Length_Subtype_Definition, + Time_Subtype_Staticness); + end if; + Set_Type_Staticness (Time_Type_Definition, Time_Type_Staticness); + Set_Type_Staticness (Time_Subtype_Definition, Time_Subtype_Staticness); + + if Flag_Rti then + Rtis.Generate_Unit (Standard_Package); + Std_Standard_Boolean_Rti + := Get_Info (Boolean_Type_Definition).Type_Rti; + Std_Standard_Bit_Rti + := Get_Info (Bit_Type_Definition).Type_Rti; + end if; + + -- Std_Ulogic indexed array of STD.Boolean. + -- Used by PSL to convert Std_Ulogic to boolean. + Std_Ulogic_Boolean_Array_Type := + New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Index_Lit (9)); + New_Type_Decl (Get_Identifier ("__ghdl_std_ulogic_boolean_array_type"), + Std_Ulogic_Boolean_Array_Type); + New_Const_Decl (Ghdl_Std_Ulogic_To_Boolean_Array, + Get_Identifier ("__ghdl_std_ulogic_to_boolean_array"), + O_Storage_External, Std_Ulogic_Boolean_Array_Type); + + Pop_Identifier_Prefix (Unit_Mark); + Pop_Identifier_Prefix (Lib_Mark); + + Post_Initialize; + Current_Filename_Node := O_Dnode_Null; + --Pop_Global_Factory; + end Translate_Standard; + + procedure Finalize + is + Info : Ortho_Info_Acc; + Prev_Info : Ortho_Info_Acc; + begin + Prev_Info := null; + for I in Node_Infos.First .. Node_Infos.Last loop + Info := Get_Info (I); + if Info /= null and then Info /= Prev_Info then + case Get_Kind (I) is + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration_Flag (I) = False + and then Get_Deferred_Declaration (I) /= Null_Iir + then + -- Info are copied from incomplete constant declaration + -- to full constant declaration. + Clear_Info (I); + else + Free_Info (I); + end if; + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Free_Type_Info (Info); + when Iir_Kind_Array_Subtype_Definition => + if Get_Index_Constraint_Flag (I) then + Info.T := Ortho_Info_Type_Array_Init; + Free_Type_Info (Info); + end if; + when Iir_Kind_Implicit_Function_Declaration => + case Get_Implicit_Definition (I) is + when Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => + -- Not in sequence. + null; + when others => + -- By default, info are not shared. + -- The exception is infos for implicit subprograms, + -- but they are always consecutive and not free twice + -- due to prev_info mechanism. + Free_Info (I); + end case; + when others => + -- By default, info are not shared. + Free_Info (I); + end case; + Prev_Info := Info; + end if; + end loop; + Node_Infos.Free; + Free_Old_Temp; + end Finalize; + + package body Chap12 is + -- Create __ghdl_ELABORATE + procedure Gen_Main (Entity : Iir_Entity_Declaration; + Arch : Iir_Architecture_Body; + Config_Subprg : O_Dnode; + Nbr_Pkgs : Natural) + is + Entity_Info : Block_Info_Acc; + Arch_Info : Block_Info_Acc; + Inter_List : O_Inter_List; + Assoc : O_Assoc_List; + Instance : O_Dnode; + Arch_Instance : O_Dnode; + Mark : Id_Mark_Type; + Arr_Type : O_Tnode; + Arr : O_Dnode; + begin + Arch_Info := Get_Info (Arch); + Entity_Info := Get_Info (Entity); + + -- We need to create code. + Set_Global_Storage (O_Storage_Private); + + -- Create the array of RTIs for packages (as a variable, initialized + -- during elaboration). + Arr_Type := New_Constrained_Array_Type + (Rtis.Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs))); + New_Var_Decl (Arr, Get_Identifier ("__ghdl_top_RTIARRAY"), + O_Storage_Private, Arr_Type); + + -- The elaboration entry point. + Start_Procedure_Decl (Inter_List, Get_Identifier ("__ghdl_ELABORATE"), + O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Ghdl_Elaborate); + + Start_Subprogram_Body (Ghdl_Elaborate); + New_Var_Decl (Arch_Instance, Wki_Arch_Instance, + O_Storage_Local, Arch_Info.Block_Decls_Ptr_Type); + + New_Var_Decl (Instance, Wki_Instance, O_Storage_Local, + Entity_Info.Block_Decls_Ptr_Type); + + -- Create instance for the architecture. + New_Assign_Stmt + (New_Obj (Arch_Instance), + Gen_Alloc (Alloc_System, + New_Lit (Get_Scope_Size (Arch_Info.Block_Scope)), + Arch_Info.Block_Decls_Ptr_Type)); + + -- Set the top instance. + New_Assign_Stmt + (New_Obj (Instance), + New_Address (New_Selected_Acc_Value (New_Obj (Arch_Instance), + Arch_Info.Block_Parent_Field), + Entity_Info.Block_Decls_Ptr_Type)); + + -- Clear parent field of entity link. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Instance), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Parent), + New_Lit (New_Null_Access (Rtis.Ghdl_Component_Link_Acc))); + + -- Set top instances and RTI. + -- Do it before the elaboration code, since it may be used to + -- diagnose errors. + -- Call ghdl_rti_add_top + Start_Association (Assoc, Ghdl_Rti_Add_Top); + New_Association + (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Pkgs)))); + New_Association + (Assoc, New_Lit (New_Global_Address (Arr, Rtis.Ghdl_Rti_Arr_Acc))); + New_Association + (Assoc, + New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const))); + New_Association + (Assoc, New_Convert_Ov (New_Obj_Value (Arch_Instance), + Ghdl_Ptr_Type)); + New_Procedure_Call (Assoc); + + -- Add std.standard rti + Start_Association (Assoc, Ghdl_Rti_Add_Package); + New_Association + (Assoc, + New_Lit (Rtis.New_Rti_Address + (Get_Info (Standard_Package).Package_Rti_Const))); + New_Procedure_Call (Assoc); + + Gen_Filename (Get_Design_File (Get_Design_Unit (Entity))); + + -- Elab package dependences of top entity (so that default + -- expressions can be evaluated). + Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); + New_Procedure_Call (Assoc); + + -- init instance + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Instance); + Push_Identifier_Prefix (Mark, ""); + Chap1.Translate_Entity_Init (Entity); + + -- elab instance + Start_Association (Assoc, Arch_Info.Block_Elab_Subprg); + New_Association (Assoc, New_Obj_Value (Instance)); + New_Procedure_Call (Assoc); + + --Chap6.Link_Instance_Name (Null_Iir, Entity); + + -- configure instance. + Start_Association (Assoc, Config_Subprg); + New_Association (Assoc, New_Obj_Value (Arch_Instance)); + New_Procedure_Call (Assoc); + + Pop_Identifier_Prefix (Mark); + Clear_Scope (Entity_Info.Block_Scope); + Finish_Subprogram_Body; + + Current_Filename_Node := O_Dnode_Null; + end Gen_Main; + + procedure Gen_Setup_Info + is + Cst : O_Dnode; + pragma Unreferenced (Cst); + begin + Cst := Create_String (Flags.Flag_String, + Get_Identifier ("__ghdl_flag_string"), + O_Storage_Public); + end Gen_Setup_Info; + + procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration) + is + Entity_Info : Block_Info_Acc; + + Arch : Iir_Architecture_Body; + Arch_Info : Block_Info_Acc; + + Lib : Iir_Library_Declaration; + Lib_Mark, Entity_Mark, Arch_Mark : Id_Mark_Type; + + Config : Iir_Configuration_Declaration; + Config_Info : Config_Info_Acc; + + Const : O_Dnode; + Instance : O_Dnode; + Inter_List : O_Inter_List; + Constr : O_Assoc_List; + Subprg : O_Dnode; + begin + Arch := Libraries.Get_Latest_Architecture (Entity); + if Arch = Null_Iir then + Error_Msg_Elab ("no architecture for " & Disp_Node (Entity)); + end if; + Arch_Info := Get_Info (Arch); + if Arch_Info = null then + -- Nothing to do here, since the architecture is not used. + return; + end if; + Entity_Info := Get_Info (Entity); + + -- Create trampoline for elab, default_architecture + -- re-create instsize. + Reset_Identifier_Prefix; + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); + Push_Identifier_Prefix (Arch_Mark, "LASTARCH"); + + -- Instance size. + New_Const_Decl + (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public, + Ghdl_Index_Type); + Start_Const_Value (Const); + Finish_Const_Value (Const, Get_Scope_Size (Arch_Info.Block_Scope)); + + -- Elaborator. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("ELAB"), O_Storage_Public); + New_Interface_Decl + (Inter_List, Instance, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Start_Association (Constr, Arch_Info.Block_Elab_Subprg); + New_Association (Constr, New_Obj_Value (Instance)); + New_Procedure_Call (Constr); + Finish_Subprogram_Body; + + -- Default config. + Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + Config_Info := Get_Info (Config); + if Config_Info /= null then + -- Do not create a trampoline for the default_config if it is not + -- used. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), + O_Storage_Public); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Arch_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Start_Association (Constr, Config_Info.Config_Subprg); + New_Association (Constr, New_Obj_Value (Instance)); + New_Procedure_Call (Constr); + Finish_Subprogram_Body; + end if; + + Pop_Identifier_Prefix (Arch_Mark); + Pop_Identifier_Prefix (Entity_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Last_Arch; + + procedure Gen_Dummy_Default_Config (Arch : Iir_Architecture_Body) + is + Entity : Iir_Entity_Declaration; + Lib : Iir_Library_Declaration; + Lib_Mark, Entity_Mark, Sep_Mark, Arch_Mark : Id_Mark_Type; + + Inter_List : O_Inter_List; + + Subprg : O_Dnode; + begin + Reset_Identifier_Prefix; + Entity := Get_Entity (Arch); + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Arch))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); + Push_Identifier_Prefix (Sep_Mark, "ARCH"); + Push_Identifier_Prefix (Arch_Mark, Get_Identifier (Arch)); + + -- Elaborator. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), + O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Chap6.Gen_Program_Error (Arch, Chap6.Prg_Err_Dummy_Config); + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Arch_Mark); + Pop_Identifier_Prefix (Sep_Mark); + Pop_Identifier_Prefix (Entity_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Dummy_Default_Config; + + procedure Gen_Dummy_Package_Declaration (Unit : Iir_Design_Unit) + is + Pkg : Iir_Package_Declaration; + Lib : Iir_Library_Declaration; + Lib_Mark, Pkg_Mark : Id_Mark_Type; + + Decl : Iir; + begin + Libraries.Load_Design_Unit (Unit, Null_Iir); + Pkg := Get_Library_Unit (Unit); + Reset_Identifier_Prefix; + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Pkg))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Pkg_Mark, Get_Identifier (Pkg)); + + if Get_Need_Body (Pkg) then + Decl := Get_Declaration_Chain (Pkg); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- Generate empty body. + + -- Never a second spec, as this is within a package + -- declaration. + pragma Assert + (not Is_Second_Subprogram_Specification (Decl)); + + if not Get_Foreign_Flag (Decl) then + declare + Mark : Id_Mark_Type; + Inter_List : O_Inter_List; + Proc : O_Dnode; + begin + Chap2.Push_Subprg_Identifier (Decl, Mark); + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Proc); + Start_Subprogram_Body (Proc); + Finish_Subprogram_Body; + Pop_Identifier_Prefix (Mark); + end; + end if; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end if; + + -- Create the body elaborator. + declare + Inter_List : O_Inter_List; + Proc : O_Dnode; + begin + Start_Procedure_Decl + (Inter_List, Create_Identifier ("ELAB_BODY"), O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Proc); + Start_Subprogram_Body (Proc); + Finish_Subprogram_Body; + end; + + Pop_Identifier_Prefix (Pkg_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Dummy_Package_Declaration; + + procedure Write_File_List (Filelist : String) + is + use Interfaces.C_Streams; + use System; + use Configuration; + use Name_Table; + + -- Add all dependences of UNIT. + -- UNIT is not used, but added during link. + procedure Add_Unit_Dependences (Unit : Iir_Design_Unit) + is + Dep_List : Iir_List; + Dep : Iir; + Dep_Unit : Iir_Design_Unit; + Lib_Unit : Iir; + begin + -- Load the unit in memory to compute the dependence list. + Libraries.Load_Design_Unit (Unit, Null_Iir); + Update_Node_Infos; + + Set_Elab_Flag (Unit, True); + Design_Units.Append (Unit); + + if Flag_Rti then + Rtis.Generate_Library + (Get_Library (Get_Design_File (Unit)), True); + end if; + + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + -- The body may be required due to incomplete constant + -- declarations, or to call to a subprogram. + declare + Pack_Body : Iir; + begin + Pack_Body := Libraries.Find_Secondary_Unit + (Unit, Null_Identifier); + if Pack_Body /= Null_Iir then + Add_Unit_Dependences (Pack_Body); + else + Gen_Dummy_Package_Declaration (Unit); + end if; + end; + when Iir_Kind_Architecture_Body => + Gen_Dummy_Default_Config (Lib_Unit); + when others => + null; + end case; + + Dep_List := Get_Dependence_List (Unit); + for I in Natural loop + Dep := Get_Nth_Element (Dep_List, I); + exit when Dep = Null_Iir; + Dep_Unit := Libraries.Find_Design_Unit (Dep); + if Dep_Unit = Null_Iir then + Error_Msg_Elab + ("could not find design unit " & Disp_Node (Dep)); + elsif not Get_Elab_Flag (Dep_Unit) then + Add_Unit_Dependences (Dep_Unit); + end if; + end loop; + end Add_Unit_Dependences; + + -- Add not yet added units of FILE. + procedure Add_File_Units (File : Iir_Design_File) + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if not Get_Elab_Flag (Unit) then + -- Unit not used. + Add_Unit_Dependences (Unit); + end if; + Unit := Get_Chain (Unit); + end loop; + end Add_File_Units; + + Nul : constant Character := Character'Val (0); + Fname : String := Filelist & Nul; + Mode : constant String := "wt" & Nul; + F : FILEs; + R : int; + S : size_t; + pragma Unreferenced (R, S); -- FIXME + Id : Name_Id; + Lib : Iir_Library_Declaration; + File : Iir_Design_File; + Unit : Iir_Design_Unit; + J : Natural; + begin + F := fopen (Fname'Address, Mode'Address); + if F = NULL_Stream then + Error_Msg_Elab ("cannot open " & Filelist); + end if; + + -- Set elab flags on units, and remove it on design files. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Set_Elab_Flag (Unit, True); + File := Get_Design_File (Unit); + Set_Elab_Flag (File, False); + end loop; + + J := Design_Units.First; + while J <= Design_Units.Last loop + Unit := Design_Units.Table (J); + File := Get_Design_File (Unit); + if not Get_Elab_Flag (File) then + Set_Elab_Flag (File, True); + + -- Add dependences of unused design units, otherwise the object + -- link case failed. + Add_File_Units (File); + + Lib := Get_Library (File); + R := fputc (Character'Pos ('>'), F); + Id := Get_Library_Directory (Lib); + S := fwrite (Get_Address (Id), + size_t (Get_Name_Length (Id)), 1, F); + R := fputc (10, F); + + Id := Get_Design_File_Filename (File); + S := fwrite (Get_Address (Id), + size_t (Get_Name_Length (Id)), 1, F); + R := fputc (10, F); + end if; + J := J + 1; + end loop; + end Write_File_List; + + procedure Elaborate + (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean) + is + use Name_Table; + use Configuration; + + Primary_Id : Name_Id; + Secondary_Id : Name_Id; + Unit : Iir_Design_Unit; + Lib_Unit : Iir; + Config : Iir_Design_Unit; + Config_Lib : Iir_Configuration_Declaration; + Entity : Iir_Entity_Declaration; + Arch : Iir_Architecture_Body; + Conf_Info : Config_Info_Acc; + Last_Design_Unit : Natural; + Nbr_Pkgs : Natural; + begin + Primary_Id := Get_Identifier (Primary); + if Secondary /= "" then + Secondary_Id := Get_Identifier (Secondary); + else + Secondary_Id := Null_Identifier; + end if; + Config := Configure (Primary_Id, Secondary_Id); + if Config = Null_Iir then + return; + end if; + Config_Lib := Get_Library_Unit (Config); + Entity := Get_Entity (Config_Lib); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config_Lib)); + + -- Be sure the entity can be at the top of a design. + Check_Entity_Declaration_Top (Entity); + + -- If all design units are loaded, late semantic checks can be + -- performed. + if Flag_Load_All_Design_Units then + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Sem.Sem_Analysis_Checks_List (Unit, False); + -- There cannot be remaining checks to do. + pragma Assert + (Get_Analysis_Checks_List (Unit) = Null_Iir_List); + end loop; + end if; + + -- Return now in case of errors. + if Nbr_Errors /= 0 then + return; + end if; + + if Flags.Verbose then + Ada.Text_IO.Put_Line ("List of units in the hierarchy design:"); + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); + end loop; + end if; + + if Whole then + -- In compile-and-elaborate mode, do not generate code for + -- unused subprograms. + -- FIXME: should be improved by creating a span-tree. + Flag_Discard_Unused := True; + Flag_Discard_Unused_Implicit := True; + end if; + + -- Generate_Library add infos, therefore the info array must be + -- adjusted. + Update_Node_Infos; + Rtis.Generate_Library (Libraries.Std_Library, True); + Translate_Standard (Whole); + + -- Translate all configurations needed. + -- Also, set the ELAB_FLAG on package with body. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + + if Whole then + -- In whole compilation mode, force to generate RTIS of + -- libraries. + Rtis.Generate_Library + (Get_Library (Get_Design_File (Unit)), True); + end if; + + case Get_Kind (Lib_Unit) is + when Iir_Kind_Configuration_Declaration => + -- Always generate code for configuration. + -- Because default binding may be changed between analysis + -- and elaboration. + Translate (Unit, True); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + -- For package spec, mark it as 'body is not present', this + -- flag will be set below when the body is translated. + Set_Elab_Flag (Unit, False); + Translate (Unit, Whole); + when Iir_Kind_Package_Body => + -- Mark the spec with 'body is present' flag. + Set_Elab_Flag + (Get_Design_Unit (Get_Package (Lib_Unit)), True); + Translate (Unit, Whole); + when others => + Error_Kind ("elaborate", Lib_Unit); + end case; + end loop; + + -- Generate code to elaboration body-less package. + -- + -- When a package is analyzed, we don't know wether there is body + -- or not. Therefore, we assume there is always a body, and will + -- elaborate the body (which elaborates its spec). If a package + -- has no body, create the body elaboration procedure. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + if not Get_Elab_Flag (Unit) then + Chap2.Elab_Package_Body (Lib_Unit, Null_Iir); + end if; + when Iir_Kind_Entity_Declaration => + Gen_Last_Arch (Lib_Unit); + when Iir_Kind_Architecture_Body + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + null; + when others => + Error_Kind ("elaborate(2)", Lib_Unit); + end case; + end loop; + + Rtis.Generate_Top (Nbr_Pkgs); + + -- Create main code. + Conf_Info := Get_Info (Config_Lib); + Gen_Main (Entity, Arch, Conf_Info.Config_Subprg, Nbr_Pkgs); + + Gen_Setup_Info; + + -- Index of the last design unit, required by the design. + Last_Design_Unit := Design_Units.Last; + + -- Disp list of files needed. + -- FIXME: extract the link completion part of WRITE_FILE_LIST. + if Filelist /= "" then + Write_File_List (Filelist); + end if; + + if Flags.Verbose then + Ada.Text_IO.Put_Line ("List of units not used:"); + for I in Last_Design_Unit + 1 .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); + end loop; + end if; + end Elaborate; + end Chap12; +end Translation; diff --git a/src/vhdl/translate/translation.ads b/src/vhdl/translate/translation.ads new file mode 100644 index 000000000..e779685f2 --- /dev/null +++ b/src/vhdl/translate/translation.ads @@ -0,0 +1,120 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; 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 Ortho_Nodes; + +package Translation is + -- Initialize the package: create internal nodes. + procedure Initialize; + + -- Translate (generate code) for design unit UNIT. + -- If MAIN is true, the unit is really the unit being compiled (not an + -- external unit). Code shouldn't be generated for external units. + procedure Translate (Unit : Iir_Design_Unit; Main : Boolean); + + -- Translate std.standard. + procedure Translate_Standard (Main : Boolean); + + -- Get the ortho node for subprogram declaration DECL. + function Get_Ortho_Decl (Subprg : Iir) return Ortho_Nodes.O_Dnode; + + -- Get the internal _RESOLV function for FUNC. + function Get_Resolv_Ortho_Decl (Func : Iir) return Ortho_Nodes.O_Dnode; + + procedure Finalize; + + package Chap12 is + -- Primary unit + secondary unit (architecture name which may be null) + -- to elaborate. + procedure Elaborate (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean); + end Chap12; + + -- If set, generate Run-Time Information nodes. + Flag_Rti : Boolean := True; + + -- If set, do not generate 64 bits integer types and operations. + Flag_Only_32b : Boolean := False; + + -- If set, do not generate code for unused subprograms. + -- Be careful: unless you are in whole compilation mode, this + -- flag shouldn't be set for packages and entities. + Flag_Discard_Unused : Boolean := False; + + -- If set, do not generate code for unused implicit subprograms. + Flag_Discard_Unused_Implicit : Boolean := False; + + -- If set, dump drivers per process during compilation. + Flag_Dump_Drivers : Boolean := False; + + -- If set, try to create direct drivers. + Flag_Direct_Drivers : Boolean := True; + + -- If set, checks ranges (subtype ranges). + Flag_Range_Checks : Boolean := True; + + -- If set, checks indexes (arrays index and slice). + Flag_Index_Checks : Boolean := True; + + -- If set, do not create identifiers (for in memory compilation). + Flag_Discard_Identifiers : Boolean := False; + + -- If true, do not create nested subprograms. + -- This flag is forced during initialization if the code generated doesn't + -- support nested subprograms. + Flag_Unnest_Subprograms : Boolean := False; + + type Foreign_Kind_Type is (Foreign_Unknown, + Foreign_Vhpidirect, + Foreign_Intrinsic); + + type Foreign_Info_Type (Kind : Foreign_Kind_Type := Foreign_Unknown) + is record + case Kind is + when Foreign_Unknown => + null; + when Foreign_Vhpidirect => + -- Positions in name_table.name_buffer. + Lib_First : Natural; + Lib_Last : Natural; + Subprg_First : Natural; + Subprg_Last : Natural; + when Foreign_Intrinsic => + null; + end case; + end record; + + Foreign_Bad : constant Foreign_Info_Type := (Kind => Foreign_Unknown); + + -- Return a foreign_info for DECL. + -- Can generate error messages, if the attribute expression is ill-formed. + -- If EXTRACT_NAME is set, internal fields of foreign_info are set. + -- Otherwise, only KIND discriminent is set. + -- EXTRACT_NAME should be set only inside translation itself, since the + -- name can be based on the prefix. + function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type; + + -- If not null, this procedure is called when a foreign subprogram is + -- created. + type Foreign_Hook_Access is access procedure (Decl : Iir; + Info : Foreign_Info_Type; + Ortho : Ortho_Nodes.O_Dnode); + Foreign_Hook : Foreign_Hook_Access := null; +end Translation; |