diff options
Diffstat (limited to 'src/vhdl')
33 files changed, 26972 insertions, 26270 deletions
diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index 56c7e61dd..0473899af 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -285,7 +285,7 @@ package body Ortho_Front is when Action_Elaborate => Flags.Flag_Elaborate := True; Flags.Flag_Only_Elab_Warnings := True; - Translation.Chap12.Elaborate + Translation.Elaborate (Elab_Entity.all, Elab_Architecture.all, Elab_Filelist.all, False); @@ -324,7 +324,7 @@ package body Ortho_Front is Flags.Flag_Elaborate := True; Flags.Flag_Only_Elab_Warnings := False; - Translation.Chap12.Elaborate + Translation.Elaborate (Elab_Entity.all, Elab_Architecture.all, "", True); if Errorout.Nbr_Errors > 0 then diff --git a/src/vhdl/translate/trans-chap1.adb b/src/vhdl/translate/trans-chap1.adb new file mode 100644 index 000000000..38bfba695 --- /dev/null +++ b/src/vhdl/translate/trans-chap1.adb @@ -0,0 +1,843 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Translation; use Translation; +with Trans.Chap2; +with Trans.Chap3; +with Trans.Chap4; +with Trans.Chap5; +with Trans.Chap6; +with Trans.Chap7; +with Trans.Chap9; +with Trans.Rtis; +with Trans.Helpers2; use Trans.Helpers2; + +package body Trans.Chap1 is + use Trans.Helpers; + + 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 : Subprgs.Subprg_Instance_Type; + Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; + begin + Info := Add_Info (Entity, Kind_Block); + 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); + + Subprgs.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); + Subprgs.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; + Subprgs.Start_Subprg_Instance_Use (Instance); + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + + Chap9.Elab_Block_Declarations (Entity, Entity); + Subprgs.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); + Subprgs.Add_Subprg_Instance_Interfaces + (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Init_Subprg); + + Start_Subprogram_Body (Init_Subprg); + Subprgs.Start_Subprg_Instance_Use (Instance); + Translate_Entity_Init (Entity); + Subprgs.Finish_Subprg_Instance_Use (Instance); + Finish_Subprogram_Body; + end; + end if; + end if; + Subprgs.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 : Subprgs.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. + Subprgs.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); + Subprgs.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 Trans.Chap1; diff --git a/src/vhdl/translate/trans-chap1.ads b/src/vhdl/translate/trans-chap1.ads new file mode 100644 index 000000000..1b4b11691 --- /dev/null +++ b/src/vhdl/translate/trans-chap1.ads @@ -0,0 +1,36 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap1; diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb new file mode 100644 index 000000000..677a6d772 --- /dev/null +++ b/src/vhdl/translate/trans-chap12.adb @@ -0,0 +1,655 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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 Configuration; +with Interfaces.C_Streams; +with Ada.Text_IO; +with Errorout; use Errorout; +with Std_Package; use Std_Package; +with Iirs_Utils; use Iirs_Utils; +with Name_Table; +with Libraries; +with Flags; +with Sem; +with Trans.Chap1; +with Trans.Chap2; +with Trans.Chap6; +with Trans.Rtis; +with Trans.Helpers2; use Trans.Helpers2; +with Translation; use Translation; +with Trans_Decls; use Trans_Decls; + +package body Trans.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 Trans.Chap12; diff --git a/src/vhdl/translate/trans-chap12.ads b/src/vhdl/translate/trans-chap12.ads new file mode 100644 index 000000000..646cb0295 --- /dev/null +++ b/src/vhdl/translate/trans-chap12.ads @@ -0,0 +1,26 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap12; diff --git a/src/vhdl/translate/trans-chap14.adb b/src/vhdl/translate/trans-chap14.adb new file mode 100644 index 000000000..430edccd2 --- /dev/null +++ b/src/vhdl/translate/trans-chap14.adb @@ -0,0 +1,938 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Evaluation; use Evaluation; +with Std_Package; use Std_Package; +with Iirs_Utils; use Iirs_Utils; +with Trans_Decls; use Trans_Decls; +with Trans.Chap3; +with Trans.Chap6; +with Trans.Chap7; +with Trans.Rtis; +with Trans.Helpers2; use Trans.Helpers2; +with Trans.Foreach_Non_Composite; + +package body Trans.Chap14 is + use Trans.Helpers; + + 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 Trans.Chap14; diff --git a/src/vhdl/translate/trans-chap14.ads b/src/vhdl/translate/trans-chap14.ads new file mode 100644 index 000000000..cdf279588 --- /dev/null +++ b/src/vhdl/translate/trans-chap14.ads @@ -0,0 +1,69 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap14; diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb new file mode 100644 index 000000000..c4845a0e8 --- /dev/null +++ b/src/vhdl/translate/trans-chap2.adb @@ -0,0 +1,1263 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Name_Table; +with Std_Names; +with Std_Package; use Std_Package; +with Errorout; use Errorout; +with Sem_Inst; +with Nodes_Meta; +with Iirs_Utils; use Iirs_Utils; +with Trans.Chap3; +with Trans.Chap4; +with Trans.Chap5; +with Trans.Chap6; +with Trans.Chap8; +with Trans.Rtis; +with Trans_Decls; use Trans_Decls; +with Translation; use Translation; + +package body Trans.Chap2 is + use Trans.Subprgs; + use Trans.Helpers; + + 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 + Subprgs.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 : Subprgs.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 + Subprgs.Push_Subprg_Instance + (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, + Wki_Upframe, Prev_Subprg_Instances); + -- Link to previous frame + Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); + + -- Link to previous frame + Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + -- Local frame + Subprgs.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 + Subprgs.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. + Subprgs.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; + + Subprgs.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 : Subprgs.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. + Subprgs.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); + Subprgs.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 + Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + + -- The spec elaborator has a spec instance argument. + Subprgs.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); + Subprgs.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 + Subprgs.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 : Subprgs.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 + Subprgs.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); + Subprgs.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; + Subprgs.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; + + Subprgs.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; + Subprgs.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; + + Subprgs.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; + +end Trans.Chap2; diff --git a/src/vhdl/translate/trans-chap2.ads b/src/vhdl/translate/trans-chap2.ads new file mode 100644 index 000000000..5394cba14 --- /dev/null +++ b/src/vhdl/translate/trans-chap2.ads @@ -0,0 +1,51 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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); +end Trans.Chap2; diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb new file mode 100644 index 000000000..30ea1fa08 --- /dev/null +++ b/src/vhdl/translate/trans-chap3.adb @@ -0,0 +1,3362 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Name_Table; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Evaluation; use Evaluation; +with Trans.Chap2; +with Trans.Chap4; +with Trans.Chap6; +with Trans.Chap7; +with Trans.Chap14; +with Trans_Decls; use Trans_Decls; +with Trans.Helpers2; use Trans.Helpers2; +with Translation; + +package body Trans.Chap3 is + use Trans.Helpers; + + 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); + Subprgs.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); + Subprgs.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 Translation.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); + Subprgs.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)); + + Subprgs.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); + Subprgs.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))); + Subprgs.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 : Subprgs.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)); + Subprgs.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. + Subprgs.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); + Subprgs.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; + + Subprgs.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. + Subprgs.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 : Subprgs.Subprg_Instance_Stack; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + -- Subprograms of BOD. + Subprgs.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj, + Prev_Subprg_Instance); + Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Bod); + + Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + Subprgs.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); + Subprgs.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))); + + Subprgs.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)); + Subprgs.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + + Finish_Subprogram_Body; + end; + + -- Fini subprogram + begin + Start_Subprogram_Body (Info.T.Prot_Final_Subprg); + Subprgs.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); + + Subprgs.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 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 Trans.Chap3; diff --git a/src/vhdl/translate/trans-chap3.ads b/src/vhdl/translate/trans-chap3.ads new file mode 100644 index 000000000..1b1128560 --- /dev/null +++ b/src/vhdl/translate/trans-chap3.ads @@ -0,0 +1,264 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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); + + -- 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 Trans.Chap3; diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb new file mode 100644 index 000000000..7b18f5744 --- /dev/null +++ b/src/vhdl/translate/trans-chap4.adb @@ -0,0 +1,2735 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Errorout; use Errorout; +with Files_Map; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Translation; use Translation; +with Trans.Chap2; +with Trans.Chap3; +with Trans.Chap5; +with Trans.Chap6; +with Trans.Chap7; +with Trans.Chap14; +with Trans.Rtis; +with Trans.Helpers2; use Trans.Helpers2; +with Trans_Decls; use Trans_Decls; +with Trans.Foreach_Non_Composite; + +package body Trans.Chap4 is + use Trans.Helpers; + + -- 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); + Subprgs.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 Subprgs.Has_Subprg_Instance (Resolv_Info.Var_Instance) then + Val := New_Convert_Ov + (Subprgs.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 Subprgs.Has_Current_Subprg_Instance then + Subprgs.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 := Subprgs.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 Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then + Subprgs.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; + Subprgs.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 Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then + Subprgs.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; + + Subprgs.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 Trans.Chap4; diff --git a/src/vhdl/translate/trans-chap4.ads b/src/vhdl/translate/trans-chap4.ads new file mode 100644 index 000000000..129942437 --- /dev/null +++ b/src/vhdl/translate/trans-chap4.ads @@ -0,0 +1,112 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap4; diff --git a/src/vhdl/translate/trans-chap5.adb b/src/vhdl/translate/trans-chap5.adb new file mode 100644 index 000000000..a58bd956c --- /dev/null +++ b/src/vhdl/translate/trans-chap5.adb @@ -0,0 +1,765 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Errorout; use Errorout; +with Sem_Names; +with Iirs_Utils; use Iirs_Utils; +with Trans.Chap3; +with Trans.Chap4; +with Trans.Chap6; +with Trans.Chap7; +with Trans_Decls; use Trans_Decls; +with Trans.Helpers2; use Trans.Helpers2; +with Trans.Foreach_Non_Composite; + +package body Trans.Chap5 is + use Trans.Helpers; + + 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 : Mnode; + 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 Trans.Chap5; diff --git a/src/vhdl/translate/trans-chap5.ads b/src/vhdl/translate/trans-chap5.ads new file mode 100644 index 000000000..b959bd318 --- /dev/null +++ b/src/vhdl/translate/trans-chap5.ads @@ -0,0 +1,44 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap5; diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb new file mode 100644 index 000000000..35544cff1 --- /dev/null +++ b/src/vhdl/translate/trans-chap6.adb @@ -0,0 +1,1087 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Files_Map; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Evaluation; use Evaluation; +with Canon; +with Trans.Chap3; +with Trans.Chap7; +with Trans.Chap14; +with Trans.Helpers2; use Trans.Helpers2; +with Trans_Decls; use Trans_Decls; + +package body Trans.Chap6 is + use Trans.Helpers; + + 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 Trans.Chap6; diff --git a/src/vhdl/translate/trans-chap6.ads b/src/vhdl/translate/trans-chap6.ads new file mode 100644 index 000000000..5a11fb6c3 --- /dev/null +++ b/src/vhdl/translate/trans-chap6.ads @@ -0,0 +1,85 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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; + pragma Unreferenced (Prg_Err_Block_Configured); + 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 Trans.Chap6; diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb new file mode 100644 index 000000000..a8fdeb466 --- /dev/null +++ b/src/vhdl/translate/trans-chap7.adb @@ -0,0 +1,5802 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; 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 Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Iir_Chains; use Iir_Chains; +with Std_Package; use Std_Package; +with Errorout; use Errorout; +with Flags; use Flags; +with Canon; +with Evaluation; use Evaluation; +with Trans.Chap3; +with Trans.Chap4; +with Trans.Chap6; +with Trans.Chap8; +with Trans.Chap14; +with Trans.Rtis; +with Trans_Decls; use Trans_Decls; +with Trans.Helpers2; use Trans.Helpers2; +with Trans.Foreach_Non_Composite; + +package body Trans.Chap7 is + use Trans.Helpers; + + 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 + Subprgs.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); + Subprgs.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); + Subprgs.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); + Subprgs.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); + Subprgs.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); + Subprgs.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); + Subprgs.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); + Subprgs.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)); + Subprgs.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. + Subprgs.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); + Subprgs.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; + Subprgs.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 : O_Dnode; + Var_L_Base : O_Dnode; + 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; + Subprgs.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); + Subprgs.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; + Subprgs.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 Trans.Chap7; diff --git a/src/vhdl/translate/trans-chap7.ads b/src/vhdl/translate/trans-chap7.ads new file mode 100644 index 000000000..d3fcfee25 --- /dev/null +++ b/src/vhdl/translate/trans-chap7.ads @@ -0,0 +1,159 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap7; diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb new file mode 100644 index 000000000..72aa77ae9 --- /dev/null +++ b/src/vhdl/translate/trans-chap8.adb @@ -0,0 +1,2959 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; 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 Std_Names; +with Errorout; use Errorout; +with Iir_Chains; +with Canon; +with Evaluation; use Evaluation; +with Std_Package; use Std_Package; +with Iirs_Utils; use Iirs_Utils; +with Trans.Chap2; +with Trans.Chap3; +with Trans.Chap4; +with Trans.Chap6; +with Trans.Chap7; +with Trans.Chap14; +with Trans_Decls; use Trans_Decls; +with Translation; use Translation; +with Trans.Helpers2; use Trans.Helpers2; +with Trans.Foreach_Non_Composite; + +package body Trans.Chap8 is + use Trans.Helpers; + + 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); + Subprgs.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); + Subprgs.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); + Subprgs.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); + Subprgs.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; + + Subprgs.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 + Subprgs.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 Trans.Chap8; diff --git a/src/vhdl/translate/trans-chap8.ads b/src/vhdl/translate/trans-chap8.ads new file mode 100644 index 000000000..b358d5b1d --- /dev/null +++ b/src/vhdl/translate/trans-chap8.ads @@ -0,0 +1,40 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap8; + diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb new file mode 100644 index 000000000..d04b240ec --- /dev/null +++ b/src/vhdl/translate/trans-chap9.adb @@ -0,0 +1,1953 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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 Errorout; use Errorout; +with Std_Package; use Std_Package; +with Flags; +with Libraries; +with Canon; +with Canon_PSL; +with Trans_Analyzes; +with PSL.Nodes; +with PSL.NFAs; +with PSL.NFAs.Utils; +with Ieee.Std_Logic_1164; +with Trans.Chap1; +with Trans.Chap3; +with Trans.Chap4; +with Trans.Chap5; +with Trans.Chap6; +with Trans.Chap7; +with Trans.Chap8; +with Trans.Chap14; +with Trans.Rtis; +with Translation; use Translation; +with Trans_Decls; use Trans_Decls; +with Trans.Helpers2; use Trans.Helpers2; +with Trans.Foreach_Non_Composite; + +package body Trans.Chap9 is + use Trans.Helpers; + + 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 : Subprgs.Subprg_Instance_Stack; + begin + Subprgs.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); + Subprgs.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 Trans.Chap9; diff --git a/src/vhdl/translate/trans-chap9.ads b/src/vhdl/translate/trans-chap9.ads new file mode 100644 index 000000000..51d059090 --- /dev/null +++ b/src/vhdl/translate/trans-chap9.ads @@ -0,0 +1,34 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Chap9; + diff --git a/src/vhdl/translate/trans-foreach_non_composite.adb b/src/vhdl/translate/trans-foreach_non_composite.adb new file mode 100644 index 000000000..2035f920e --- /dev/null +++ b/src/vhdl/translate/trans-foreach_non_composite.adb @@ -0,0 +1,112 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Errorout; use Errorout; +with Trans.Chap3; +with Trans.Chap6; + +procedure Trans.Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) +is + use Trans.Helpers; + + 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 Trans.Foreach_Non_Composite; diff --git a/src/vhdl/translate/trans-foreach_non_composite.ads b/src/vhdl/translate/trans-foreach_non_composite.ads new file mode 100644 index 000000000..9413a8200 --- /dev/null +++ b/src/vhdl/translate/trans-foreach_non_composite.ads @@ -0,0 +1,62 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- 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 Trans.Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); diff --git a/src/vhdl/translate/trans-helpers2.adb b/src/vhdl/translate/trans-helpers2.adb new file mode 100644 index 000000000..cf61883a7 --- /dev/null +++ b/src/vhdl/translate/trans-helpers2.adb @@ -0,0 +1,318 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Name_Table; +with Trans.Chap3; +with Trans.Chap6; +with Trans_Decls; use Trans_Decls; +with Files_Map; +with Trans.Foreach_Non_Composite; + +package body Trans.Helpers2 is + use Trans.Helpers; + + 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; + + -- 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 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 Trans.Helpers2; + diff --git a/src/vhdl/translate/trans-helpers2.ads b/src/vhdl/translate/trans-helpers2.ads new file mode 100644 index 000000000..86edd82c6 --- /dev/null +++ b/src/vhdl/translate/trans-helpers2.ads @@ -0,0 +1,73 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.Helpers2 is + -- Copy a fat pointer. + -- D and S are stabilized fat pointers. + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); + + -- 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; + + -- 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); + + function Get_Line_Number (Target: Iir) return Natural; + + procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; + Line : Natural); +end Trans.Helpers2; diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb new file mode 100644 index 000000000..1789050ef --- /dev/null +++ b/src/vhdl/translate/trans-rtis.adb @@ -0,0 +1,2559 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Name_Table; +with Errorout; use Errorout; +with Iirs_Utils; use Iirs_Utils; +with Configuration; +with Libraries; +with Trans.Chap7; +with Trans.Helpers2; use Trans.Helpers2; + +package body Trans.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 Trans.Rtis; diff --git a/src/vhdl/translate/trans-rtis.ads b/src/vhdl/translate/trans-rtis.ads new file mode 100644 index 000000000..85fbe1156 --- /dev/null +++ b/src/vhdl/translate/trans-rtis.ads @@ -0,0 +1,138 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002 - 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 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.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 Trans.Rtis; diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb index faed4b6f8..f099a9075 100644 --- a/src/vhdl/translate/trans.adb +++ b/src/vhdl/translate/trans.adb @@ -31,10 +31,10 @@ package body Trans is Current_Subprg_Instance := Null_Subprg_Instance_Stack; end Clear_Subprg_Instance; - procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; Ptr_Type : O_Tnode; - Ident : O_Ident; - Prev : out Subprg_Instance_Stack) + Ident : O_Ident; + Prev : out Subprg_Instance_Stack) is begin Prev := Current_Subprg_Instance; @@ -49,7 +49,7 @@ package body Trans is end Has_Current_Subprg_Instance; procedure Pop_Subprg_Instance (Ident : O_Ident; - Prev : Subprg_Instance_Stack) + Prev : Subprg_Instance_Stack) is begin if Is_Equal (Current_Subprg_Instance.Ident, Ident) then @@ -88,13 +88,13 @@ package body Trans is end Add_Subprg_Instance_Field; function Has_Subprg_Instance (Vars : Subprg_Instance_Type) - return Boolean is + 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 + return O_Enode is begin pragma Assert (Has_Subprg_Instance (Vars)); return New_Address (Get_Instance_Ref (Vars.Scope.all), @@ -151,7 +151,7 @@ package body Trans is end Finish_Prev_Subprg_Instance_Use_Via_Field; procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; - Subprg : Iir) + Subprg : Iir) is begin Add_Subprg_Instance_Interfaces @@ -169,7 +169,7 @@ package body Trans is end Finish_Subprg_Instance_Use; function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) - return Subprg_Instance_Type is + return Subprg_Instance_Type is begin return Subprg_Instance_Type' (Inter => Inst.Inter, @@ -182,9 +182,9 @@ package body Trans 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; + Identifier_Len : Natural := 0; + Identifier_Start : Natural := 1; + Identifier_Local : Local_Identifier_Type := 0; Inst_Build : Inst_Build_Acc := null; @@ -261,7 +261,7 @@ package body Trans is end Push_Instance_Factory; function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) - return O_Fnode + return O_Fnode is Res : O_Fnode; begin @@ -279,7 +279,7 @@ package body Trans is end Add_Scope_Field; function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) - return O_Cnode is + return O_Cnode is begin return New_Offsetof (Get_Scope_Type (Child.Up_Link.all), Child.Field, Otype); @@ -320,7 +320,7 @@ package body Trans is when O_Storage_Public => Global_Storage := O_Storage_Private; when O_Storage_Private - | O_Storage_External => + | O_Storage_External => null; when O_Storage_Local => raise Internal_Error; @@ -335,7 +335,7 @@ package body Trans is end if; case Inst_Build.Kind is when Local - | Instance => + | Instance => return True; when Global => return False; @@ -353,7 +353,7 @@ package body Trans is end Pop_Local_Factory; procedure Set_Scope_Via_Field - (Scope : in out Var_Scope_Type; + (Scope : in out Var_Scope_Type; Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is begin pragma Assert (Scope.Kind = Var_Scope_None); @@ -363,7 +363,7 @@ package body Trans is end Set_Scope_Via_Field; procedure Set_Scope_Via_Field_Ptr - (Scope : in out Var_Scope_Type; + (Scope : in out Var_Scope_Type; Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is begin pragma Assert (Scope.Kind = Var_Scope_None); @@ -406,7 +406,7 @@ package body Trans is function Create_Global_Var (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) - return Var_Type + return Var_Type is Var : O_Dnode; begin @@ -415,11 +415,11 @@ package body Trans is end Create_Global_Var; function Create_Global_Const - (Name : O_Ident; - Vtype : O_Tnode; - Storage : O_Storage; + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; Initial_Value : O_Cnode) - return Var_Type + return Var_Type is Res : O_Dnode; begin @@ -440,14 +440,14 @@ package body Trans is end Define_Global_Const; function Create_Var - (Name : Var_Ident_Type; - Vtype : O_Tnode; + (Name : Var_Ident_Type; + Vtype : O_Tnode; Storage : O_Storage := Global_Storage) - return Var_Type + return Var_Type is - Res : O_Dnode; + Res : O_Dnode; Field : O_Fnode; - K : Inst_Build_Kind_Type; + K : Inst_Build_Kind_Type; begin if Inst_Build = null then K := Global; @@ -473,21 +473,21 @@ package body Trans is -- 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; + 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 => + | Var_Scope_Decl => Res := New_Obj (Scope.D); Is_Ptr := Scope.Kind = Var_Scope_Ptr; when Var_Scope_Field - | Var_Scope_Field_Ptr => + | Var_Scope_Field_Ptr => declare - Parent : O_Lnode; + Parent : O_Lnode; Parent_Ptr : Boolean; begin Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr); @@ -511,8 +511,8 @@ package body Trans is function Get_Instance_Access (Block : Iir) return O_Enode is - Info : constant Block_Info_Acc := Get_Info (Block); - Res : O_Lnode; + Info : constant Block_Info_Acc := Get_Info (Block); + Res : O_Lnode; Is_Ptr : Boolean; begin Check_Not_Building; @@ -526,7 +526,7 @@ package body Trans is function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode is - Res : O_Lnode; + Res : O_Lnode; Is_Ptr : Boolean; begin Check_Not_Building; @@ -545,7 +545,7 @@ package body Trans is when Var_None => raise Internal_Error; when Var_Local - | Var_Global => + | Var_Global => return New_Obj (Var.E); when Var_Scope => return New_Selected_Element @@ -554,13 +554,13 @@ package body Trans is end Get_Var; function Get_Alloc_Kind_For_Var (Var : Var_Type) - return Allocation_Kind is + return Allocation_Kind is begin case Var.Kind is when Var_Local => return Alloc_Stack; when Var_Global - | Var_Scope => + | Var_Scope => return Alloc_System; when Var_None => raise Internal_Error; @@ -571,7 +571,7 @@ package body Trans is begin case Var.Kind is when Var_Local - | Var_Global => + | Var_Global => return True; when Var_Scope => return False; @@ -584,7 +584,7 @@ package body Trans is begin case Var.Kind is when Var_Local - | Var_Global => + | Var_Global => return False; when Var_Scope => return True; @@ -604,10 +604,10 @@ package body Trans is begin case Var.Kind is when Var_Local - | Var_Global => + | Var_Global => return Var.E; when Var_Scope - | Var_None => + | Var_None => raise Internal_Error; end case; end Get_Var_Label; @@ -650,8 +650,8 @@ package body Trans is procedure Add_Nat (Len : in out Natural; Val : Natural) is Num : String (1 .. 10); - V : Natural; - P : Natural; + V : Natural; + P : Natural; begin P := Num'Last; V := Val; @@ -685,8 +685,8 @@ package body Trans is others => True); N_Len : Natural; - P : Natural; - C : Character; + P : Natural; + C : Character; begin if Is_Character (Name) then P := Character'Pos (Name_Table.Get_Character (Name)); @@ -743,7 +743,7 @@ package body Trans is procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; Name : String; - Val : Iir_Int32 := 0) + Val : Iir_Int32 := 0) is P : Natural; begin @@ -796,7 +796,7 @@ package body Trans is end Create_Identifier_Without_Prefix; function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) - return O_Ident + return O_Ident is use Name_Table; begin @@ -807,7 +807,7 @@ package body Trans is -- Create an identifier from IIR node ID with prefix. function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean) - return O_Ident + return O_Ident is L : Natural; begin @@ -824,14 +824,14 @@ package body Trans is end Create_Id; function Create_Identifier (Id : Name_Id; Str : String := "") - return O_Ident + return O_Ident is begin return Create_Id (Id, Str, False); end Create_Identifier; function Create_Identifier (Id : Iir; Str : String := "") - return O_Ident + return O_Ident is begin return Create_Id (Get_Identifier (Id), Str, False); @@ -839,7 +839,7 @@ package body Trans is function Create_Identifier (Id : Iir; Val : Iir_Int32; Str : String := "") - return O_Ident + return O_Ident is Len : Natural; begin @@ -855,7 +855,7 @@ package body Trans is end Create_Identifier; function Create_Identifier (Str : String) - return O_Ident + return O_Ident is Len : Natural; begin @@ -871,7 +871,7 @@ package body Trans is end Create_Identifier; function Create_Var_Identifier_From_Buffer (L : Natural) - return Var_Ident_Type + return Var_Ident_Type is Start : Natural; begin @@ -884,7 +884,7 @@ package body Trans is end Create_Var_Identifier_From_Buffer; function Create_Var_Identifier (Id : Iir) - return Var_Ident_Type + return Var_Ident_Type is L : Natural := Identifier_Len; begin @@ -893,7 +893,7 @@ package body Trans is end Create_Var_Identifier; function Create_Var_Identifier (Id : String) - return Var_Ident_Type + return Var_Ident_Type is L : Natural := Identifier_Len; begin @@ -902,7 +902,7 @@ package body Trans is end Create_Var_Identifier; function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) - return Var_Ident_Type + return Var_Ident_Type is L : Natural := Identifier_Len; begin @@ -929,10 +929,10 @@ package body Trans is type Instantiate_Var_Stack is record Orig_Scope : Var_Scope_Acc; Inst_Scope : Var_Scope_Acc; - Prev : Instantiate_Var_Stack_Acc; + Prev : Instantiate_Var_Stack_Acc; end record; - Top_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; + Top_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; Free_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; procedure Push_Instantiate_Var_Scope @@ -967,7 +967,7 @@ package body Trans is end Pop_Instantiate_Var_Scope; function Instantiated_Var_Scope (Scope : Var_Scope_Acc) - return Var_Scope_Acc + return Var_Scope_Acc is Item : Instantiate_Var_Stack_Acc; begin @@ -989,8 +989,8 @@ package body Trans is begin case Var.Kind is when Var_None - | Var_Global - | Var_Local => + | Var_Global + | Var_Local => return Var; when Var_Scope => return Var_Type' @@ -1001,12 +1001,12 @@ package body Trans is end Instantiate_Var; function Instantiate_Var_Scope (Scope : Var_Scope_Type) - return Var_Scope_Type is + return Var_Scope_Type is begin case Scope.Kind is when Var_Scope_None - | Var_Scope_Ptr - | Var_Scope_Decl => + | Var_Scope_Ptr + | Var_Scope_Decl => return Scope; when Var_Scope_Field => return Var_Scope_Type' @@ -1031,10 +1031,10 @@ package body Trans is function Get_Var (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) - return Mnode + return Mnode is - L : O_Lnode; - D : O_Dnode; + L : O_Lnode; + D : O_Dnode; Stable : Boolean; begin -- FIXME: there may be Vv2M and Vp2M. @@ -1046,18 +1046,18 @@ package body Trans is 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 => + | 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 => + | Type_Mode_Record + | Type_Mode_Protected => if Is_Complex_Type (Vtype) then if Stable then return Dp2M (D, Vtype, Mode); @@ -1122,10 +1122,10 @@ package body Trans is Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); end if; when Mstate_Dp - | Mstate_Dv => + | Mstate_Dv => return M; when Mstate_Bad - | Mstate_Null => + | Mstate_Null => raise Internal_Error; end case; end Stabilize; @@ -1152,10 +1152,10 @@ package body Trans is when Mstate_Lv => E := New_Value (M.M1.Lv); when Mstate_Dp - | Mstate_Dv => + | Mstate_Dv => return M; when Mstate_Bad - | Mstate_Null => + | Mstate_Null => raise Internal_Error; end case; @@ -1168,7 +1168,7 @@ package body Trans is function Create_Temp (Info : Type_Info_Acc; Kind : Object_Kind_Type := Mode_Value) - return Mnode is + return Mnode is begin if Is_Complex_Type (Info) and then Info.Type_Mode /= Type_Mode_Fat_Array @@ -1182,14 +1182,14 @@ package body Trans is end Create_Temp; function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) - return O_Enode is + 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 + return O_Lnode is begin return New_Selected_Element (New_Access_Element (New_Value (L)), Field); @@ -1253,7 +1253,7 @@ package body Trans is -- 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 + return Ortho_Info_Acc is Res : Ortho_Info_Acc; begin @@ -1295,7 +1295,7 @@ package body Trans is end Get_Ortho_Expr; function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type) - return O_Tnode is + return O_Tnode is begin return Get_Info (Target).Ortho_Type (Is_Sig); end Get_Ortho_Type; @@ -1312,7 +1312,7 @@ package body Trans is procedure Free_Node_Infos is - Info : Ortho_Info_Acc; + Info : Ortho_Info_Acc; Prev_Info : Ortho_Info_Acc; begin Prev_Info := null; @@ -1331,14 +1331,14 @@ package body Trans is Free_Info (I); end if; when Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Access_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 => + | 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 @@ -1348,7 +1348,7 @@ package body Trans is 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 => + | Iir_Predefined_Bit_Array_Match_Inequality => -- Not in sequence. null; when others => @@ -1374,7 +1374,7 @@ package body Trans is end Get_Type_Info; function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_E, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1384,7 +1384,7 @@ package body Trans is end E2M; function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Lv, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1393,12 +1393,12 @@ package body Trans is Ptype => T.Ortho_Ptr_Type (Kind))); end Lv2M; - function Lv2M (L : O_Lnode; - Comp : Boolean; + function Lv2M (L : O_Lnode; + Comp : Boolean; Vtype : O_Tnode; Ptype : O_Tnode; - T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode is + T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is begin return Mnode'(M1 => (State => Mstate_Lv, Comp => Comp, @@ -1407,7 +1407,7 @@ package body Trans is end Lv2M; function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Lp, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1416,12 +1416,12 @@ package body Trans is Ptype => T.Ortho_Ptr_Type (Kind))); end Lp2M; - function Lp2M (L : O_Lnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Lp2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Lp, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1429,12 +1429,12 @@ package body Trans is Vtype => Vtype, Ptype => Ptype)); end Lp2M; - function Lv2M (L : O_Lnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Lv2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Lv, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1442,10 +1442,10 @@ package body Trans is Vtype => Vtype, Ptype => Ptype)); end Lv2M; - function Dv2M (D : O_Dnode; - T : Type_Info_Acc; + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Dv, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1454,12 +1454,12 @@ package body Trans is Ptype => T.Ortho_Ptr_Type (Kind))); end Dv2M; - function Dv2M (D : O_Dnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Dv, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1468,12 +1468,12 @@ package body Trans is Ptype => Ptype)); end Dv2M; - function Dp2M (D : O_Dnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Dp, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1481,10 +1481,10 @@ package body Trans is Vtype => Vtype, Ptype => Ptype)); end Dp2M; - function Dp2M (D : O_Dnode; - T : Type_Info_Acc; + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode is + return Mnode is begin return Mnode'(M1 => (State => Mstate_Dp, Comp => T.Type_Mode in Type_Mode_Fat, @@ -1517,7 +1517,7 @@ package body Trans is when Mstate_Dv => return New_Obj (M.M1.Dv); when Mstate_Null - | Mstate_Bad => + | Mstate_Bad => raise Internal_Error; end case; end M2Lv; @@ -1535,13 +1535,13 @@ package body Trans is 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))); + New_Address (M.M1.Lv, M.M1.Ptype))); else raise Internal_Error; end if; when Mstate_Dv - | Mstate_Null - | Mstate_Bad => + | Mstate_Null + | Mstate_Bad => raise Internal_Error; end case; end M2Lp; @@ -1624,7 +1624,7 @@ package body Trans is return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); end case; when Mstate_Bad - | Mstate_Null => + | Mstate_Null => raise Internal_Error; end case; end M2E; @@ -1647,58 +1647,58 @@ package body Trans is raise Internal_Error; end if; when Mstate_Bad - | Mstate_Null => + | 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_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 => + | 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; 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; + function Varv2M (Var : Var_Type; Var_Type : Type_Info_Acc; - Mode : Object_Kind_Type; - Vtype : O_Tnode; - Ptype : O_Tnode) - return Mnode is + 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 + 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 => + | 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 => + | Type_Mode_Record + | Type_Mode_Protected => if Is_Complex_Type (Vtype) then return Lp2M (L, Vtype, Mode); else @@ -1710,18 +1710,18 @@ package body Trans is end Lo2M; function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) - return Mnode is + 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 => + | 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 => + | Type_Mode_Record + | Type_Mode_Protected => if Is_Complex_Type (Vtype) then return Dp2M (D, Vtype, Mode); else @@ -1737,16 +1737,16 @@ package body Trans is begin New_Assign_Stmt (New_Obj (V), New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (V), - New_Lit (Ghdl_Index_1))); + 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))); + New_Obj_Value (V), + New_Lit (Ghdl_Index_1))); end Dec_Var; procedure Init_Var (V : O_Dnode) is @@ -1767,11 +1767,11 @@ package body Trans is 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; + Prev : Temp_Level_Acc; + Level : Natural; + Id : Natural; + Emitted : Boolean; + Stack2_Mark : O_Dnode; Transient_Types : Iir; end record; -- Current level. @@ -1944,7 +1944,7 @@ package body Trans is Str : String (1 .. 12); Val : Natural; Res : O_Dnode; - P : Natural; + P : Natural; begin if Temp_Level = null then -- OPEN_TEMP was never called. @@ -1986,7 +1986,7 @@ package body Trans is end Create_Temp; function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) - return O_Dnode + return O_Dnode is Res : O_Dnode; begin @@ -1996,7 +1996,7 @@ package body Trans is end Create_Temp_Init; function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) - return O_Dnode is + return O_Dnode is begin return Create_Temp_Init (Atype, New_Address (Name, Atype)); end Create_Temp_Ptr; diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads index adf009104..04aca3cb3 100644 --- a/src/vhdl/translate/trans.ads +++ b/src/vhdl/translate/trans.ads @@ -25,16 +25,16 @@ with Types; use Types; package Trans 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; + 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_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; + Std_String_Ptr_Node : O_Tnode; + Std_String_Node : O_Tnode; -- Ortho type for std.standard.integer. Std_Integer_Otype : O_Tnode; @@ -47,45 +47,45 @@ package Trans is -- Node for the variable containing the current filename. Current_Filename_Node : O_Dnode := O_Dnode_Null; - Current_Library_Unit : Iir := Null_Iir; + 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; + 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; + Char_Type_Node : O_Tnode; -- Array of char. - Chararray_Type : O_Tnode; + Chararray_Type : O_Tnode; -- Pointer to array of char. - Char_Ptr_Type : O_Tnode; + Char_Ptr_Type : O_Tnode; -- Array of char ptr. - Char_Ptr_Array_Type : O_Tnode; + 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; + 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_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_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_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; + 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; @@ -98,65 +98,65 @@ package Trans is Ghdl_Bool_True_Node : O_Cnode renames Ghdl_Bool_Nodes (True); Ghdl_Bool_Array_Type : O_Tnode; - Ghdl_Bool_Array_Ptr : 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; + 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_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_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_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_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; + 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 @@ -223,7 +223,7 @@ package Trans is -- Manually add a field to the current instance being built. function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) - return O_Fnode; + 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 @@ -233,7 +233,7 @@ package Trans is -- 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; + return O_Cnode; -- Finish the building of the current instance and return the type -- built. @@ -250,13 +250,13 @@ package Trans is -- 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 : 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 : in out Var_Scope_Type; Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); -- Variables/scopes defined in SCOPE can be accessed via @@ -284,10 +284,10 @@ package Trans is procedure Reset_Identifier_Prefix; procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; Name : String; - Val : Iir_Int32 := 0); + Val : Iir_Int32 := 0); procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; Name : Name_Id; - Val : Iir_Int32 := 0); + Val : Iir_Int32 := 0); procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type); procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type); @@ -300,21 +300,21 @@ package Trans is -- Create an identifier from IIR node ID without the prefix. function Create_Identifier_Without_Prefix (Id : Iir) - return O_Ident; + return O_Ident; function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) - return O_Ident; + 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; + return O_Ident; function Create_Identifier (Id : Iir; Val : Iir_Int32; Str : String := "") - return O_Ident; + return O_Ident; function Create_Identifier (Id : Name_Id; Str : String := "") - return O_Ident; + return O_Ident; -- Create a prefixed identifier from a string. function Create_Identifier (Str : String) return O_Ident; @@ -325,7 +325,7 @@ package Trans is 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; + return Var_Ident_Type; function Create_Uniq_Identifier return Var_Ident_Type; -- Create variable NAME of type VTYPE in the current scope. @@ -334,23 +334,23 @@ package Trans is -- 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; + (Name : Var_Ident_Type; + Vtype : O_Tnode; Storage : O_Storage := Global_Storage) - return Var_Type; + return Var_Type; -- Create a global variable. function Create_Global_Var (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) - return Var_Type; + 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; + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; Initial_Value : O_Cnode) - return Var_Type; + 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. @@ -386,18 +386,18 @@ package Trans is -- Get the associated instantiated scope for SCOPE. function Instantiated_Var_Scope (Scope : Var_Scope_Acc) - return 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; + return Var_Scope_Type; private type Local_Identifier_Type is new Natural; type Id_Mark_Type is record - Len : Natural; + Len : Natural; Local_Id : Local_Identifier_Type; end record; @@ -417,7 +417,7 @@ package Trans is 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 : Inst_Build_Acc; Prev_Id_Start : Natural; case Kind is when Local => @@ -426,8 +426,8 @@ package Trans is when Global => null; when Instance => - Scope : Var_Scope_Acc; - Elements : O_Element_List; + Scope : Var_Scope_Acc; + Elements : O_Element_List; end case; end record; @@ -443,8 +443,8 @@ package Trans is when Var_None => null; when Var_Global - | Var_Local => - E : O_Dnode; + | Var_Local => + E : O_Dnode; when Var_Scope => I_Field : O_Fnode; I_Scope : Var_Scope_Acc; @@ -467,17 +467,17 @@ package Trans is -- Not set, cannot be referenced. null; when Var_Scope_Ptr - | Var_Scope_Decl => + | 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; + D : O_Dnode; when Var_Scope_Field - | Var_Scope_Field_Ptr => + | 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; + Field : O_Fnode; Up_Link : Var_Scope_Acc; end case; end record; @@ -516,10 +516,10 @@ package Trans is -- 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; + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; Ptr_Type : O_Tnode; - Ident : O_Ident; - Prev : out Subprg_Instance_Stack); + 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. @@ -531,7 +531,7 @@ package Trans is -- 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); + Prev : Subprg_Instance_Stack); -- True iff there is currently a subprogram instance. function Has_Current_Subprg_Instance return Boolean; @@ -555,11 +555,11 @@ package Trans is -- Get the value to be associated to the instance interface. function Get_Subprg_Instance (Vars : Subprg_Instance_Type) - return O_Enode; + return O_Enode; -- True iff VARS is associated with an instance. function Has_Subprg_Instance (Vars : Subprg_Instance_Type) - return Boolean; + return Boolean; -- Assign the instance field FIELD of VAR. procedure Set_Subprg_Instance_Field @@ -578,26 +578,26 @@ package Trans is -- Same as above, but for IIR. procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; - Subprg : Iir); + 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; + return Subprg_Instance_Type; private type Subprg_Instance_Type is record - Inter : O_Dnode; + Inter : O_Dnode; Inter_Type : O_Tnode; - Scope : Var_Scope_Acc; + 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; + Scope : Var_Scope_Acc; Ptr_Type : O_Tnode; - Ident : O_Ident; + Ident : O_Ident; end record; Null_Subprg_Instance_Stack : constant Subprg_Instance_Stack := @@ -632,7 +632,7 @@ package Trans is Kind_Str_Choice, Kind_Design_File, Kind_Library - ); + ); type Ortho_Info_Type_Kind is ( @@ -641,7 +641,7 @@ package Trans is 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; @@ -659,7 +659,7 @@ package Trans is -- For scalar types: -- True if no need to check against low/high bound. Nocheck_Low : Boolean := False; - Nocheck_Hi : Boolean := False; + Nocheck_Hi : Boolean := False; -- Ortho type for the range record type. Range_Type : O_Tnode; @@ -671,18 +671,18 @@ package Trans is Range_Var : Var_Type; -- Fields of TYPE_RANGE_TYPE. - Range_Left : O_Fnode; - Range_Right : O_Fnode; - Range_Dir : O_Fnode; + 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; + 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; + Base_Field : O_Fnode_Array; Bounds_Field : O_Fnode_Array; -- True if the array bounds are static. @@ -710,27 +710,27 @@ package Trans is Prot_Scope : aliased Var_Scope_Type; -- Init procedure for the protected type. - Prot_Init_Subprg : O_Dnode; - Prot_Init_Instance : Subprgs.Subprg_Instance_Type; + Prot_Init_Subprg : O_Dnode; + Prot_Init_Instance : Subprgs.Subprg_Instance_Type; -- Final procedure. - Prot_Final_Subprg : O_Dnode; - Prot_Final_Instance : Subprgs.Subprg_Instance_Type; + Prot_Final_Subprg : O_Dnode; + Prot_Final_Instance : Subprgs.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; + 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_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, @@ -806,14 +806,14 @@ package Trans is Type_Mode_Fat_Array); subtype Type_Mode_Scalar is Type_Mode_Type - range Type_Mode_B1 .. Type_Mode_F64; + range Type_Mode_B1 .. Type_Mode_F64; subtype Type_Mode_Non_Composite is Type_Mode_Type - range Type_Mode_B1 .. Type_Mode_Fat_Acc; + 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; + range Type_Mode_Record .. Type_Mode_Fat_Array; -- Array types. subtype Type_Mode_Arrays is Type_Mode_Type range @@ -821,41 +821,41 @@ package Trans is -- Thin types, ie types whose length is a scalar. subtype Type_Mode_Thin is Type_Mode_Type - range Type_Mode_B1 .. Type_Mode_Acc; + 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; + 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; + 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; + 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; + range Type_Mode_Record .. Type_Mode_Fat_Array; -- Additional informations for a resolving function. type Subprg_Resolv_Info is record - Resolv_Func : O_Dnode; + Resolv_Func : O_Dnode; -- Parameter nodes. Var_Instance : Subprgs.Subprg_Instance_Type; -- Signals - Var_Vals : O_Dnode; + Var_Vals : O_Dnode; -- Driving vector. - Var_Vec : O_Dnode; + Var_Vec : O_Dnode; -- Length of Vector. - Var_Vlen : O_Dnode; - Var_Nbr_Drv : O_Dnode; + 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; @@ -977,10 +977,10 @@ package Trans is -- Parameters for type builders. -- NOTE: this is only set for types (and *not* for subtypes). - Builder_Instance : Subprgs.Subprg_Instance_Type; - Builder_Base_Param : O_Dnode; + Builder_Instance : Subprgs.Subprg_Instance_Type; + Builder_Base_Param : O_Dnode; Builder_Bound_Param : O_Dnode; - Builder_Func : 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; @@ -989,19 +989,19 @@ package Trans is type Assoc_Conv_Info is record -- The subprogram created to do the conversion. - Subprg : O_Dnode; + Subprg : O_Dnode; -- The local base block - Instance_Block : Iir; + Instance_Block : Iir; -- and its address. - Instance_Field : O_Fnode; + 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; + 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 @@ -1059,7 +1059,7 @@ package Trans is when Kind_Incomplete_Type => -- The declaration of the incomplete type. - Incomplete_Type : Iir; + Incomplete_Type : Iir; Incomplete_Array : Ortho_Info_Acc; when Kind_Index => @@ -1100,7 +1100,7 @@ package Trans is -- 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; + Res_Record_Ptr : O_Tnode := O_Tnode_Null; -- Access to the declarations within this subprogram. Subprg_Frame_Scope : aliased Var_Scope_Type; @@ -1117,24 +1117,24 @@ package Trans is -- 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_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; + Object_Static : Boolean; -- The object itself. - Object_Var : Var_Type; + Object_Var : Var_Type; -- Direct driver for signal (if any). - Object_Driver : Var_Type := Null_Var; + Object_Driver : Var_Type := Null_Var; -- RTI constant for the object. - Object_Rti : O_Dnode := O_Dnode_Null; + 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_Var : Var_Type; Alias_Kind : Object_Kind_Type; when Kind_Iterator => @@ -1151,12 +1151,12 @@ package Trans is -- 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; + 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; + Interface_Type : O_Tnode; when Kind_Disconnect => -- Variable which contains the time_expression of the @@ -1179,7 +1179,7 @@ package Trans is Psl_Scope : aliased Var_Scope_Type; -- Procedure for the state machine. - Psl_Proc_Subprg : O_Dnode; + Psl_Proc_Subprg : O_Dnode; -- Procedure for finalization. Handles EOS. Psl_Proc_Final_Subprg : O_Dnode; @@ -1228,7 +1228,7 @@ package Trans is -- 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; + 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 @@ -1236,11 +1236,11 @@ package Trans is Block_Configured_Field : O_Fnode; -- For iterative generate block: array of instances. - Block_Decls_Array_Type : O_Tnode; + 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; + Block_Elab_Subprg : O_Dnode; -- Size of the block instance. Block_Instance_Size : O_Dnode; @@ -1257,9 +1257,9 @@ package Trans is Comp_Scope : aliased Var_Scope_Type; -- Instance for the component. - Comp_Ptr_Type : O_Tnode; + Comp_Ptr_Type : O_Tnode; -- Field containing a pointer to the instance link. - Comp_Link : O_Fnode; + Comp_Link : O_Fnode; -- RTI for the component. Comp_Rti_Const : O_Dnode; @@ -1294,7 +1294,7 @@ package Trans is -- Instance type for uninstantiated package Package_Spec_Ptr_Type : O_Tnode; - Package_Body_Scope : aliased Var_Scope_Type; + Package_Body_Scope : aliased Var_Scope_Type; Package_Body_Ptr_Type : O_Tnode; -- Field to the spec within the body. @@ -1322,16 +1322,16 @@ package Trans is when Kind_Assoc => -- Association informations. - Assoc_In : Assoc_Conv_Info; + 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; + Choice_Chain : Ortho_Info_Acc; -- Association index. - Choice_Assoc : Natural; + Choice_Assoc : Natural; -- Corresponding choice simple expression. - Choice_Expr : Iir; + Choice_Expr : Iir; -- Corresponding choice. Choice_Parent : Iir; @@ -1418,7 +1418,7 @@ package Trans is case State is when Mstate_E => - E : O_Enode; + E : O_Enode; when Mstate_Lv => Lv : O_Lnode; when Mstate_Lp => @@ -1428,7 +1428,7 @@ package Trans is when Mstate_Dp => Dp : O_Dnode; when Mstate_Bad - | Mstate_Null => + | Mstate_Null => null; end case; end record; @@ -1453,7 +1453,7 @@ package Trans is -- Transform VAR to Mnode. function Get_Var (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) - return Mnode; + return Mnode; -- Return a stabilized node for M. -- The former M is not usuable anymore. @@ -1469,7 +1469,7 @@ package Trans is -- Create a temporary of type INFO and kind KIND. function Create_Temp (Info : Type_Info_Acc; Kind : Object_Kind_Type := Mode_Value) - return Mnode; + return Mnode; -- Return the value of field FIELD of lnode L that is contains -- a pointer to a record. @@ -1500,7 +1500,7 @@ package Trans is -- 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; + return Ortho_Info_Acc; procedure Free_Info (Target : Iir); @@ -1511,7 +1511,7 @@ package Trans is function Get_Ortho_Expr (Target : Iir) return O_Cnode; function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type) - return O_Tnode; + return O_Tnode; -- Return true is INFO is a type info for a composite type, ie: -- * a record @@ -1530,57 +1530,57 @@ package Trans is pragma Inline (Get_Type_Info); function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode; + return Mnode; function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode; - function Lv2M (L : O_Lnode; - Comp : Boolean; + return Mnode; + function Lv2M (L : O_Lnode; + Comp : Boolean; Vtype : O_Tnode; Ptype : O_Tnode; - T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode; function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode; + return Mnode; - function Lp2M (L : O_Lnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Lp2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode; + return Mnode; - function Lv2M (L : O_Lnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Lv2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode; + return Mnode; - function Dv2M (D : O_Dnode; - T : Type_Info_Acc; + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode; + return Mnode; - function Dv2M (D : O_Dnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode; + return Mnode; - function Dp2M (D : O_Dnode; - T : Type_Info_Acc; - Kind : Object_Kind_Type; + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) - return Mnode; + return Mnode; - function Dp2M (D : O_Dnode; - T : Type_Info_Acc; + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) - return Mnode; + return Mnode; function M2Lv (M : Mnode) return O_Lnode; @@ -1596,33 +1596,33 @@ package Trans is function M2Addr (M : Mnode) return O_Enode; --- function Is_Null (M : Mnode) return Boolean is --- begin --- return M.M1.State = Mstate_Null; --- end Is_Null; + -- 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; --- 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; 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; + function Varv2M (Var : Var_Type; Var_Type : Type_Info_Acc; - Mode : Object_Kind_Type; - Vtype : O_Tnode; - Ptype : O_Tnode) - return Mnode; + Mode : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode; -- 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; + return Mnode; function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) - return Mnode; + return Mnode; package Helpers is -- Generate code to initialize a ghdl_index_type variable V to 0. @@ -1641,11 +1641,11 @@ package Trans is 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; + 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; + 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. diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 9f0e416fb..2d89a62e1 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -15,12 +15,8 @@ -- 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; @@ -29,29 +25,22 @@ 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_Meta; -with Ieee.Std_Logic_1164; -with Canon; -with Canon_PSL; -with PSL.Nodes; -with PSL.NFAs; -with PSL.NFAs.Utils; with Trans; with Trans_Decls; use Trans_Decls; -with Trans_Analyzes; +with Trans.Chap1; +with Trans.Chap2; +with Trans.Chap4; +with Trans.Chap7; +with Trans.Chap12; +with Trans.Rtis; +with Trans.Helpers2; package body Translation is use Trans; use Trans.Chap10; use Trans.Helpers; + use Trans.Helpers2; function Get_Ortho_Decl (Subprg : Iir) return O_Dnode is begin @@ -71,952 +60,6 @@ package body Translation is end if; end Get_Resolv_Ortho_Decl; - 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); - 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; - - 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); - - -- 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 - -- Copy a fat pointer. - -- D and S are stabilized fat pointers. - procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); - - -- 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); - - function Get_Line_Number (Target: Iir) return Natural; - - procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; - Line : Natural); - end Helpers; - use Helpers; - - function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type is use Name_Table; @@ -1152,24278 +195,6 @@ package body Translation is end if; end Translate_Foreign_Id; - package body Helpers is - 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; - - -- 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 : Subprgs.Subprg_Instance_Type; - Prev_Subprg_Instance : Subprgs.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); - - Subprgs.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); - Subprgs.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; - Subprgs.Start_Subprg_Instance_Use (Instance); - New_Debug_Line_Stmt (Get_Line_Number (Entity)); - - Chap9.Elab_Block_Declarations (Entity, Entity); - Subprgs.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); - Subprgs.Add_Subprg_Instance_Interfaces - (Interface_List, Instance); - Finish_Subprogram_Decl (Interface_List, Init_Subprg); - - Start_Subprogram_Body (Init_Subprg); - Subprgs.Start_Subprg_Instance_Use (Instance); - Translate_Entity_Init (Entity); - Subprgs.Finish_Subprg_Instance_Use (Instance); - Finish_Subprogram_Body; - end; - end if; - end if; - Subprgs.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 : Subprgs.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. - Subprgs.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); - Subprgs.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 - use Trans.Subprgs; - - 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 - Subprgs.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 : Subprgs.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 - Subprgs.Push_Subprg_Instance - (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, - Wki_Upframe, Prev_Subprg_Instances); - -- Link to previous frame - Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instances, Upframe_Field); - - Chap4.Translate_Declaration_Chain_Subprograms (Subprg); - - -- Link to previous frame - Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instances, Upframe_Field); - -- Local frame - Subprgs.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 - Subprgs.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. - Subprgs.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; - - Subprgs.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 : Subprgs.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. - Subprgs.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); - Subprgs.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 - Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); - - -- The spec elaborator has a spec instance argument. - Subprgs.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); - Subprgs.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 - Subprgs.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 : Subprgs.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 - Subprgs.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); - Subprgs.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; - Subprgs.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; - - Subprgs.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; - Subprgs.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; - - Subprgs.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; - - 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); - Subprgs.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); - Subprgs.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); - Subprgs.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)); - - Subprgs.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); - Subprgs.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))); - Subprgs.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 : Subprgs.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)); - Subprgs.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. - Subprgs.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); - Subprgs.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; - - Subprgs.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. - Subprgs.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 : Subprgs.Subprg_Instance_Stack; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); - - -- Subprograms of BOD. - Subprgs.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, - Info.Ortho_Ptr_Type (Mode_Value), - Wki_Obj, - Prev_Subprg_Instance); - Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); - - Chap4.Translate_Declaration_Chain_Subprograms (Bod); - - Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); - Subprgs.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); - Subprgs.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))); - - Subprgs.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)); - Subprgs.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); - - Finish_Subprogram_Body; - end; - - -- Fini subprogram - begin - Start_Subprogram_Body (Info.T.Prot_Final_Subprg); - Subprgs.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); - - Subprgs.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 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); - Subprgs.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 Subprgs.Has_Subprg_Instance (Resolv_Info.Var_Instance) then - Val := New_Convert_Ov - (Subprgs.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 Subprgs.Has_Current_Subprg_Instance then - Subprgs.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 := Subprgs.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 Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then - Subprgs.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; - Subprgs.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 Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then - Subprgs.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; - - Subprgs.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 - Subprgs.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); - Subprgs.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); - Subprgs.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); - Subprgs.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); - Subprgs.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); - Subprgs.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); - Subprgs.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); - Subprgs.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)); - Subprgs.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. - Subprgs.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); - Subprgs.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; - Subprgs.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; - Subprgs.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); - Subprgs.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; - Subprgs.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); - Subprgs.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); - Subprgs.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); - Subprgs.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); - Subprgs.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; - - Subprgs.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 - Subprgs.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 : Subprgs.Subprg_Instance_Stack; - begin - Subprgs.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); - Subprgs.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 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; @@ -27216,622 +1987,9 @@ package body Translation is 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; + procedure Elaborate (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean) renames Trans.Chap12.Elaborate; - -- 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 index e779685f2..37a8c72df 100644 --- a/src/vhdl/translate/translation.ads +++ b/src/vhdl/translate/translation.ads @@ -38,14 +38,14 @@ package Translation is 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; + procedure Gen_Filename (Design_File : Iir); + + -- Primary unit + secondary unit (architecture name which may be null) + -- to elaborate. + procedure Elaborate (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean); -- If set, generate Run-Time Information nodes. Flag_Rti : Boolean := True; |