diff options
Diffstat (limited to 'translate/translation.adb')
| -rw-r--r-- | translate/translation.adb | 27760 |
1 files changed, 27760 insertions, 0 deletions
diff --git a/translate/translation.adb b/translate/translation.adb new file mode 100644 index 000000000..786a9b299 --- /dev/null +++ b/translate/translation.adb @@ -0,0 +1,27760 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with 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; +with Ada.Text_IO; +with Types; use Types; +with Errorout; use Errorout; +with Name_Table; -- use Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Libraries; +with Files_Map; +with Std_Names; +with Configuration; +with Interfaces.C_Streams; +with Sem_Names; +with Sem; +with Iir_Chains; use Iir_Chains; +with Nodes; +with GNAT.Table; +with Canon; +with Trans_Decls; use Trans_Decls; + +package body Translation is + + -- Ortho type node for STD.BOOLEAN. + Std_Boolean_Type_Node : O_Tnode; + Std_Boolean_True_Node : O_Cnode; + Std_Boolean_False_Node : O_Cnode; + -- Ortho type node for string template pointer. + Std_String_Ptr_Node : O_Tnode; + Std_String_Node : O_Tnode; + + -- Ortho type for std.integer. + Std_Integer_Type_Node : O_Tnode; + + -- Ortho type for std.real. + Std_Real_Type_Node : O_Tnode; + + -- Ortho type node for std.time. + Std_Time_Type : O_Tnode; + + -- Ortho type for std.file_open_status. + Std_File_Open_Status_Type : O_Tnode; + + -- Node for the variable containing the current filename. + Current_Filename_Node : O_Dnode := O_Dnode_Null; + + -- Global declarations. + Ghdl_Ptr_Type : O_Tnode; + Const_Ptr_Type_Node : O_Tnode; + Sizetype : O_Tnode; + Ghdl_I32_Type : O_Tnode; + Ghdl_I64_Type : O_Tnode; + Ghdl_Real_Type : O_Tnode; + -- Constant character. + Char_Type_Node : O_Tnode; + -- Array of char. + Chararray_Type : O_Tnode; + -- Pointer to array of char. + Char_Ptr_Type : O_Tnode; + -- Array of char ptr. + Char_Ptr_Array_Type : O_Tnode; + Char_Ptr_Array_Ptr_Type : O_Tnode; + + Ghdl_Index_Type : O_Tnode; + + -- Type for a file (this is in fact a index in a private table). + Ghdl_File_Index_Type : O_Tnode; + Ghdl_File_Index_Ptr_Type : O_Tnode; + + -- Record containing a len and string fields. + Ghdl_Str_Len_Type_Node : O_Tnode; + Ghdl_Str_Len_Type_Len_Field : O_Fnode; + Ghdl_Str_Len_Type_Str_Field : O_Fnode; + Ghdl_Str_Len_Ptr_Node : O_Tnode; + Ghdl_Str_Len_Array_Type_Node : O_Tnode; + + -- Location. + Ghdl_Location_Type_Node : O_Tnode; + Ghdl_Location_Filename_Node : O_Fnode; + Ghdl_Location_Line_Node : O_Fnode; + Ghdl_Location_Col_Node : O_Fnode; + Ghdl_Location_Ptr_Node : O_Tnode; + + -- Allocate memory for a block. + Ghdl_Alloc_Ptr : O_Dnode; + + -- bool type. + Ghdl_Bool_Type : O_Tnode; + type Enode_Boolean_Array is array (Boolean) of O_Cnode; + Ghdl_Bool_Nodes : Enode_Boolean_Array; + Ghdl_Bool_False_Node : O_Cnode renames Ghdl_Bool_Nodes (False); + Ghdl_Bool_True_Node : O_Cnode renames Ghdl_Bool_Nodes (True); + + Ghdl_Bool_Array_Type : O_Tnode; + Ghdl_Bool_Array_Ptr : O_Tnode; + + -- Comparaison type. + Ghdl_Compare_Type : O_Tnode; + Ghdl_Compare_Lt : O_Cnode; + Ghdl_Compare_Eq : O_Cnode; + Ghdl_Compare_Gt : O_Cnode; + + -- Dir type. + Ghdl_Dir_Type_Node : O_Tnode; + Ghdl_Dir_To_Node : O_Cnode; + Ghdl_Dir_Downto_Node : O_Cnode; + + -- Signals. + Ghdl_Scalar_Bytes : O_Tnode; + Ghdl_Signal_Type : O_Tnode; + Ghdl_Signal_Value_Node : O_Fnode; + Ghdl_Signal_Driving_Value_Node : O_Fnode; + Ghdl_Signal_Last_Value_Node : O_Fnode; + Ghdl_Signal_Last_Event_Node : O_Fnode; + Ghdl_Signal_Last_Active_Node : O_Fnode; + Ghdl_Signal_Event_Node : O_Fnode; + Ghdl_Signal_Active_Node : 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. + type Wk_Ident_Type is + ( + Wkie_This, Wkie_Size, Wkie_Res, Wkie_Dir_To, Wkie_Dir_Downto, + Wkie_Left, Wkie_Right, Wkie_Dir, Wkie_Length, Wkie_Kind, Wkie_Dim, + Wkie_I, Wkie_Instance, Wkie_Arch_Instance, Wkie_Name, Wkie_Sig, + Wkie_Obj, Wkie_Rti, Wkie_Parent + ); + type Wk_Ident_Tree_Array is array (Wk_Ident_Type) of O_Ident; + Wk_Idents : Wk_Ident_Tree_Array; + Wki_This : O_Ident renames Wk_Idents (Wkie_This); + Wki_Size : O_Ident renames Wk_Idents (Wkie_Size); + Wki_Res : O_Ident renames Wk_Idents (Wkie_Res); + Wki_Dir_To : O_Ident renames Wk_Idents (Wkie_Dir_To); + Wki_Dir_Downto : O_Ident renames Wk_Idents (Wkie_Dir_Downto); + Wki_Left : O_Ident renames Wk_Idents (Wkie_Left); + Wki_Right : O_Ident renames Wk_Idents (Wkie_Right); + Wki_Dir : O_Ident renames Wk_Idents (Wkie_Dir); + Wki_Length : O_Ident renames Wk_Idents (Wkie_Length); + Wki_Kind : O_Ident renames Wk_Idents (Wkie_Kind); + Wki_Dim : O_Ident renames Wk_Idents (Wkie_Dim); + Wki_I : O_Ident renames Wk_Idents (Wkie_I); + Wki_Instance : O_Ident renames Wk_Idents (Wkie_Instance); + Wki_Arch_Instance : O_Ident renames Wk_Idents (Wkie_Arch_Instance); + Wki_Name : O_Ident renames Wk_Idents (Wkie_Name); + Wki_Sig : O_Ident renames Wk_Idents (Wkie_Sig); + Wki_Obj : O_Ident renames Wk_Idents (Wkie_Obj); + Wki_Rti : O_Ident renames Wk_Idents (Wkie_Rti); + Wki_Parent : O_Ident renames Wk_Idents (Wkie_Parent); + + -- ALLOCATION_KIND defines the type of memory storage. + -- ALLOC_STACK means the object is allocated on the local stack and + -- deallocated at the end of the function. + -- ALLOC_SYSTEM for object created during design elaboration and whose + -- life is infinite. + -- ALLOC_RETURN for unconstrained object returns by function. + -- ALLOC_HEAP for object created by new. + type Allocation_Kind is + (Alloc_Stack, Alloc_Return, Alloc_Heap, Alloc_System); + + package Chap10 is + -- There are three data storage kind: global, local or instance. + -- For example, a constant can have: + -- * a global storage when declared inside a package. This storage + -- can be accessed from any point. + -- * a local storage when declared in a subprogram. This storage + -- can be accessed from the subprogram, is created when the subprogram + -- is called and destroy when the subprogram exit. + -- * an instance storage when declared inside a process. This storage + -- can be accessed from the process via an instance pointer, is + -- created during elaboration. + --procedure Push_Global_Factory (Storage : O_Storage); + --procedure Pop_Global_Factory; + procedure Set_Global_Storage (Storage : O_Storage); + + -- Set the global scope handling. + Global_Storage : O_Storage; + + -- Start to build an instance. + -- If INSTANCE_TYPE is not O_TNODE_NULL, it must be an uncompleted + -- record type, that will be completed. + procedure Push_Instance_Factory (Instance_Type : O_Tnode); + -- Manually add a field to the current instance being built. + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode; + -- Finish the building of the current instance and return the type + -- built. + procedure Pop_Instance_Factory (Instance_Type : out O_Tnode); + + -- Create a new scope, in which variable are created locally + -- (ie, on the stack). Always created unlocked. + procedure Push_Local_Factory; + + -- Destroy a local scope. + procedure Pop_Local_Factory; + + -- Push_scope defines how to access to a variable stored in an instance. + -- Variables defined in SCOPE_TYPE can be accessed via field SCOPE_FIELD + -- in scope SCOPE_PARENT. + procedure Push_Scope (Scope_Type : O_Tnode; + Scope_Field : O_Fnode; Scope_Parent : O_Tnode); + -- Variables defined in SCOPE_TYPE can be accessed by dereferencing + -- fiel SCOPE_FIELD defined in SCOPE_PARENT. + procedure Push_Scope_Via_Field_Ptr + (Scope_Type : O_Tnode; + Scope_Field : O_Fnode; Scope_Parent : O_Tnode); + -- Variables/scopes defined in SCOPE_TYPE can be accessed via + -- dereference of parameter SCOPE_PARAM. + procedure Push_Scope (Scope_Type : O_Tnode; Scope_Param : O_Dnode); + -- No more accesses to SCOPE_TYPE are allowed. + -- Scopes must be poped in the reverse order they are pushed. + procedure Pop_Scope (Scope_Type : O_Tnode); + + -- Same as Push_Scope/Pop_Scope, but act only if SCOPE_TYPE is not + -- null. + procedure Push_Scope_Soft (Scope_Type : O_Tnode; Scope_Param : O_Dnode); + procedure Pop_Scope_Soft (Scope_Type : O_Tnode); + pragma Inline (Push_Scope_Soft); + pragma Inline (Pop_Scope_Soft); + + -- Reset the identifier. + type Id_Mark_Type is limited private; + type Local_Identifier_Type is limited private; + + procedure Reset_Identifier_Prefix; + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : Name_Id; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type); + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type); + + -- Save/restore the local identifier number; this is used by package + -- body, which has the same prefix as the package declaration, so it + -- must continue local identifiers numbers. + -- This is used by subprogram bodies too. + procedure Save_Local_Identifier (Id : out Local_Identifier_Type); + procedure Restore_Local_Identifier (Id : Local_Identifier_Type); + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) + return O_Ident; + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident; + + -- Create an identifier from the current prefix. + function Create_Identifier return O_Ident; + + -- Create an identifier from IIR node ID with prefix. + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident; + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident; + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident; + -- Create a prefixed identifier from a string. + function Create_Identifier (Str : String) return O_Ident; + + -- Create an identifier for a variable. + -- IE, if the variable is global, prepend the prefix, + -- if the variable belong to an instance, no prefix is added. + type Var_Ident_Type is private; + --function Create_Var_Identifier (Id : Name_Id; Str : String) + -- return Var_Ident_Type; + function Create_Var_Identifier (Id : Iir) + return Var_Ident_Type; + function Create_Var_Identifier (Id : String) + return Var_Ident_Type; + function Create_Uniq_Identifier return Var_Ident_Type; + + type Var_Type (<>) is limited private; + type Var_Acc is access Var_Type; + + -- Create a variable in the current scope. + -- If the current scope is the global scope, then a variable is + -- created at the top level (using decl_global_storage). + -- If the current scope is not the global scope, then a field is added + -- to the current scope. + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Acc; + + -- Create a global variable. + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Acc; + + -- Create a global constant and initialize it to INITIAL_VALUE. + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Acc; + procedure Define_Global_Const (Const : Var_Acc; Val : O_Cnode); + + -- Return the (real) reference to a variable created by Create_Var. + function Get_Var (Var : Var_Acc) return O_Lnode; + --function Get_Var (Var : Var_Acc) return O_Dnode; + + procedure Free_Var (Var : in out Var_Acc); + + + -- Return a reference to the instance of type ITYPE. + function Get_Instance_Ref (Itype : O_Tnode) return O_Lnode; + + -- Return the address of the instance for block BLOCK. + function Get_Instance_Access (Block : Iir) return O_Enode; + + -- Return the storage for the variable VAR. + function Get_Alloc_Kind_For_Var (Var : Var_Acc) return Allocation_Kind; + + -- Return TRUE iff VAR is stable, ie get_var (VAR) can be referenced + -- several times. + function Is_Var_Stable (Var : Var_Acc) return Boolean; + + -- Used only to generate RTI. + function Is_Var_Field (Var : Var_Acc) return Boolean; + function Get_Var_Field (Var : Var_Acc) return O_Fnode; + function Get_Var_Label (Var : Var_Acc) return O_Dnode; + private + type Local_Identifier_Type is new Natural; + type Id_Mark_Type is record + Len : Natural; + Local_Id : Local_Identifier_Type; + end record; + + type Var_Ident_Type is record + Id : O_Ident; + end record; + + -- Kind of variable: + -- VAR_GLOBAL: the variable is a global variable (static or not). + -- VAR_LOCAL: the variable is on the stack. + -- VAR_SCOPE: the variable is in the instance record. + type Var_Kind is (Var_Global, Var_Scope, Var_Local); + + -- An instance contains all the data (variable, signals, constant...) + -- which are declared by an entity and an architecture. + -- (An architecture inherits the data of its entity). + -- + -- The processes and implicit guard signals of an entity/architecture + -- are translated into functions. The first argument of these functions + -- is a pointer to the instance. + + type Inst_Build_Kind_Type is (Local, Global, Instance); + type Inst_Build_Type (Kind : Inst_Build_Kind_Type); + type Inst_Build_Acc is access Inst_Build_Type; + type Inst_Build_Type (Kind : Inst_Build_Kind_Type) is record + Prev : Inst_Build_Acc; + Prev_Id_Start : Natural; + case Kind is + when Local => + -- Previous global storage. + Prev_Global_Storage : O_Storage; + when Global => + null; + when Instance => + Elements : O_Element_List; + Vars : Var_Acc; + end case; + end record; + + type Var_Type (Kind : Var_Kind) is record + case Kind is + when Var_Global + | Var_Local => + E : O_Dnode; + when Var_Scope => + I_Field : O_Fnode; + I_Type : O_Tnode; + I_Link : Var_Acc; + end case; + end record; + end Chap10; + use Chap10; + + package Chap1 is + -- Declare types for block BLK + procedure Start_Block_Decl (Blk : Iir); + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration); + + -- Generate code to initialize generics of instance INSTANCE of ENTITY + -- using the default values. + -- This is used when ENTITY is at the top of a design hierarchy. + procedure Translate_Entity_Init (Entity : Iir); + + procedure Translate_Architecture_Declaration (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_Protected_Subprogram_Declaration +-- (Def : Iir_Protected_Type_Declaration; Spec : Iir; Block : Iir); + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration); + procedure Translate_Package_Body (Decl : Iir_Package_Body); + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir); + + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit); + + -- Subprograms instances. + -- + -- Subprograms declared inside entities, architecture, blocks + -- or processes (but not inside packages) may access to data declared + -- outside the subprogram (and this with a life longer than the + -- subprogram life). These data correspond to constants, variables, + -- files, signals or types. However these data are not shared between + -- instances of the same entity, architecture... Subprograms instances + -- is the way subprograms access to these data. + -- One subprogram instance corresponds to a record. Generally, a + -- subprogram has 0 or 1 instance. Subprograms of protected objects + -- have an additionnal instance for the variable (object). + -- + -- Declare an instance to be added for subprograms. + -- DECL_TYPE is the type of the instance; this should be a record. This + -- is used by PUSH_SCOPE. + -- PTR_TYPE is a pointer to DECL_TYPE. + -- IDENT is an identifier for the interface. + -- DATA is a stabilized O_LNODE whose value will be passed to call to + -- subprograms. + -- 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 (Decl_Type : O_Tnode; + Ptr_Type : O_Tnode; + Ident : O_Ident); + + -- Revert of the previous subprogram. + -- Instances must be removed in opposite order they are added. + procedure Pop_Subprg_Instance (Ident : O_Ident); + + -- Since local subprograms has a direct access to its father interfaces, + -- they do not required instances interfaces. + -- These procedures are provided to temporarly disable the addition of + -- instances interfaces. + type Subprg_Instance_Stack is limited private; + procedure Save_Subprg_Instance (Stack : out Subprg_Instance_Stack); + procedure Restore_Subprg_Instance (Stack : Subprg_Instance_Stack); + + -- Provides/removes an access to an instance. + -- PTR is a pointer to the instance. PTR must be stable if this + -- access is used several times. + -- SET_SUBPRG_INSTANCE must not be called twice on the same instance + -- unless the access to the instance has been cleared with + -- CLEAR_SUBPRG_INSTANCE. + -- At the association, instances without explicit accesses are + -- associated with the access found in the scope. + --procedure Set_Subprg_Instance (Decl_Type : O_Tnode; Ptr : O_Lnode); + --procedure Clear_Subprg_Instance (Decl_Type : O_Tnode); + + -- Add interfaces during the creation of a subprogram. + type Subprg_Instance_El is record + Inter : O_Dnode; + Inter_Type : O_Tnode; + Inst_Type : O_Tnode; + end record; + Null_Subprg_Instance_El : constant Subprg_Instance_El := + (O_Dnode_Null, O_Tnode_Null, O_Tnode_Null); + + type Subprg_Instance_Array is array (Natural range <>) + of Subprg_Instance_El; + + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Array); + -- Associate values to the instance interfaces during invocation of a + -- subprogram. + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Array); + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; + Vars : Subprg_Instance_Array; + Inst1_Type : O_Tnode; + Inst1_Val : O_Enode); + + -- To be called at the beginning and end of a subprogram body creation. + -- Call PUSH_SCOPE for the subprogram intances. + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Array); + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Array); + + subtype Instance_Inters is Subprg_Instance_Array (0 .. 1); + Null_Instance_Inters : constant Instance_Inters := + (others => Null_Subprg_Instance_El); + + + -- Same as above, but for IIR. + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir); + + procedure Start_Subprg_Instance_Use (Subprg : Iir); + procedure Finish_Subprg_Instance_Use (Subprg : Iir); + private + type Subprg_Instance_Type; + type Subprg_Instance_Stack is access Subprg_Instance_Type; + + type Subprg_Instance_Type is record + -- Arguments of push. + Decl_Type : O_Tnode; + Ptr_Type : O_Tnode; + Ident : O_Ident; + + -- Double linked list. + Next : Subprg_Instance_Stack; + Prev : Subprg_Instance_Stack; + end record; + + Subprg_Instance_First : Subprg_Instance_Stack := null; + Subprg_Instance_Last : Subprg_Instance_Stack := null; + Subprg_Instance_Unused : Subprg_Instance_Stack := null; + 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); + + -- 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); + + -- 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); + 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_B2 : 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_Array_Ptr : 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_Unit : O_Cnode; + Ghdl_Rtik_Attribute_Transaction : O_Cnode; + Ghdl_Rtik_Attribute_Quiet : O_Cnode; + Ghdl_Rtik_Attribute_Stable : 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; + + -- Location of an object. + Ghdl_Rti_Loc : O_Tnode; + Ghdl_Rti_Loc_Offset : O_Fnode; + Ghdl_Rti_Loc_Address : O_Fnode; + + -- 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 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. + procedure Generate_Top (Arch : Iir); + + -- Add two associations to ASSOC to add an rti_context for NODE. + procedure Associate_Rti_Context + (Assoc : in out O_Assoc_List; Node : Iir); + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List); + + function Get_Context_Rti (Node : Iir) return O_Cnode; + function Get_Context_Addr (Node : Iir) return O_Enode; + end Rtis; + + type Ortho_Info_Kind is + ( + Kind_Type, + Kind_Incomplete_Type, + Kind_Expr, + Kind_Subprg, + Kind_Object, + Kind_Alias, + Kind_Iterator, + Kind_Interface, + Kind_Disconnect, + Kind_Process, + Kind_Loop, + Kind_Block, + Kind_Component, + Kind_Field, + Kind_Package, + Kind_Config, + Kind_Assoc, + Kind_Design_File, + Kind_Library + ); + + type O_Fnode_Arr is array (Natural range <>) of O_Fnode; + type O_Fnode_Arr_Acc is access O_Fnode_Arr; + type Ortho_Info_Type_Kind is + ( + Kind_Type_Scalar, + Kind_Type_Array, + Kind_Type_Record, + Kind_Type_File, + Kind_Type_Protected + ); + type O_Tnode_Array is array (Object_Kind_Type) of O_Tnode; + type O_Fnode_Array is array (Object_Kind_Type) of O_Fnode; + type O_Dnode_Array is array (Object_Kind_Type) of O_Dnode; + type Var_Acc_Array is array (Object_Kind_Type) of Var_Acc; + type Instance_Inters_Array is array (Object_Kind_Type) + of Chap2.Instance_Inters; + + type Rti_Depth_Type is new Natural range 0 .. 255; + + type Ortho_Info_Type_Type (Kind : Ortho_Info_Type_Kind := Kind_Type_Scalar) + is record + -- For all types: + -- This is the maximum depth of RTI, that is the max of the depth of + -- the type itself and every types it depends on. + Rti_Max_Depth : Rti_Depth_Type; + + case Kind is + when Kind_Type_Scalar => + -- For scalar types: + -- True if no need to check against low/high bound. + Nocheck_Low : Boolean := False; + Nocheck_Hi : Boolean := False; + + -- Ortho type for the range record type. + Range_Type : O_Tnode; + + -- Ortho type for an access to the range record type. + Range_Ptr_Type : O_Tnode; + + -- Tree for the range record declaration. + Range_Var : Var_Acc; + + -- Fields of TYPE_RANGE_TYPE. + Range_Left : O_Fnode; + Range_Right : O_Fnode; + Range_Dir : O_Fnode; + Range_Length : O_Fnode; + + when Kind_Type_Array => + Base_Type : O_Tnode_Array; + Base_Ptr_Type : O_Tnode_Array; + Bounds_Type : O_Tnode; + Bounds_Ptr_Type : O_Tnode; + + Base_Field : O_Fnode_Array; + Bounds_Field : O_Fnode_Array; + + -- Field declaration for each dimension (1 based). + Bounds_Vector : O_Fnode_Arr_Acc; + + -- True if the array bounds are static. + Static_Bounds : Boolean; + + -- Variable containing the bounds for a constrained array. + Array_Bounds : Var_Acc; + + -- Variable containing a 1 length bound for unidimensional + -- unconstrained arrays. + Array_1bound : Var_Acc; + + -- Variable containing the description for each index. + Array_Index_Desc : Var_Acc; + + when Kind_Type_Record => + -- Variable containing the description for each element. + Record_El_Desc : Var_Acc; + + when Kind_Type_File => + -- Constant containing the signature of the file. + File_Signature : O_Dnode; + + when Kind_Type_Protected => + -- Init procedure for the protected type. + Prot_Init_Node : O_Dnode; + Prot_Init_Instance : Chap2.Instance_Inters; + -- Final procedure. + Prot_Final_Node : O_Dnode; + Prot_Final_Instance : Chap2.Instance_Inters; + end case; + end record; + +-- Ortho_Info_Type_Scalar_Init : constant Ortho_Info_Type_Type := +-- (Kind => Kind_Type_Scalar, +-- Range_Type => O_Tnode_Null, +-- Range_Ptr_Type => O_Tnode_Null, +-- Range_Var => null, +-- Range_Left => O_Fnode_Null, +-- Range_Right => O_Fnode_Null, +-- Range_Dir => O_Fnode_Null, +-- Range_Length => O_Fnode_Null); + + Ortho_Info_Type_Array_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Array, + Rti_Max_Depth => 0, + Base_Type => (O_Tnode_Null, O_Tnode_Null), + Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null), + Bounds_Type => O_Tnode_Null, + Bounds_Ptr_Type => O_Tnode_Null, + Base_Field => (O_Fnode_Null, O_Fnode_Null), + Bounds_Field => (O_Fnode_Null, O_Fnode_Null), + Bounds_Vector => null, + Static_Bounds => False, + Array_Bounds => null, + Array_1bound => null, + Array_Index_Desc => null); + + Ortho_Info_Type_Record_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Record, + Rti_Max_Depth => 0, + Record_El_Desc => null); + + Ortho_Info_Type_File_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_File, + Rti_Max_Depth => 0, + File_Signature => O_Dnode_Null); + + Ortho_Info_Type_Prot_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Protected, + Rti_Max_Depth => 0, + Prot_Init_Node => O_Dnode_Null, + Prot_Init_Instance => Chap2.Null_Instance_Inters, + Prot_Final_Node => O_Dnode_Null, + Prot_Final_Instance => Chap2.Null_Instance_Inters); + + -- Mode of the type; roughly speaking, this corresponds to its size + -- (for scalars) or its layout (for composite types). + -- Used to select library subprograms for signals. + type Type_Mode_Type is + ( + -- Unknown mode. + Type_Mode_Unknown, + -- Boolean type, with 2 elements. + Type_Mode_B2, + -- Enumeration with at most 256 elements. + Type_Mode_E8, + -- Enumeration with more than 256 elements. + Type_Mode_E32, + -- Integer types. + Type_Mode_I32, + Type_Mode_I64, + -- Physical types. + Type_Mode_P32, + Type_Mode_P64, + -- Floating point type. + Type_Mode_F64, + -- File type. + Type_Mode_File, + -- Thin access. + Type_Mode_Acc, + + -- Fat access. + Type_Mode_Fat_Acc, + + -- Record. + Type_Mode_Record, + -- Protected type + Type_Mode_Protected, + -- Constrained array type (length is known at compile-time). + Type_Mode_Array, + -- Array pointer type (used for constrained array whose length is + -- known at run-time). + Type_Mode_Ptr_Array, + -- Fat array type (used for unconstrained array). + Type_Mode_Fat_Array); + + subtype Type_Mode_Scalar is Type_Mode_Type + range Type_Mode_B2 .. Type_Mode_F64; + + subtype Type_Mode_Non_Composite is Type_Mode_Type + range Type_Mode_B2 .. Type_Mode_Fat_Acc; + + -- Composite types, with the vhdl meaning: record and arrays. + subtype Type_Mode_Composite is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Array types. + subtype Type_Mode_Arrays is Type_Mode_Type range + Type_Mode_Array .. Type_Mode_Fat_Array; + + -- Thin types, ie types whose length is a scalar. + subtype Type_Mode_Thin is Type_Mode_Type + range Type_Mode_B2 .. Type_Mode_Acc; + + -- Fat types, ie types whose length is longer than a scalar. + subtype Type_Mode_Fat is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Array; + + -- These parameters are passed by value, ie the argument of the subprogram + -- is the value of the object. + subtype Type_Mode_By_Value is Type_Mode_Type + range Type_Mode_B2 .. 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 will not be + -- modified by the subprogram, the object can be passed by reference. + subtype Type_Mode_By_Copy is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Acc; + + -- The parameters are passed by reference, ie the argument of the + -- subprogram is an address to the object. + subtype Type_Mode_By_Ref is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Additional informations for a resolving function. + type Subprg_Resolv_Info is record + Resolv_Func : O_Dnode; + -- Base block which the function was defined in. + Resolv_Block : Iir; + -- Parameter nodes. + Var_Instance : O_Dnode; + Var_Vals : O_Dnode; + Var_Vec : 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; + + -- Additional info for complex types. + type Complex_Type_Info is record + -- Variable containing the size of the type. + -- This is defined only for types whose size is only known at + -- running time (and not a compile-time). + Size_Var : Var_Acc_Array; + + Builder_Need_Func : Boolean; + + -- Parameters for type builders. + -- NOTE: this is only set for types (and *not* for subtypes). + Builder_Instance : Instance_Inters_Array; + Builder_Base_Param : O_Dnode_Array; + Builder_Bound_Param : O_Dnode_Array; + Builder_Func : O_Dnode_Array; + end record; + type Complex_Type_Info_Acc is access Complex_Type_Info; + procedure Free_Complex_Type_Info is new Ada.Unchecked_Deallocation + (Complex_Type_Info, Complex_Type_Info_Acc); + + type Assoc_Conv_Info is record + -- The subprogram created to do the conversion. + Subprg : O_Dnode; + -- The local base block + Instance_Block : Iir; + -- and its address. + Instance_Field : O_Fnode; + -- The instantiated entity (if any). + Instantiated_Entity : Iir; + -- and its address. + Instantiated_Field : O_Fnode; + In_Field : O_Fnode; + Out_Field : O_Fnode; + Record_Type : O_Tnode; + Record_Ptr_Type : O_Tnode; + end record; + + type Ortho_Info_Type; + type Ortho_Info_Acc is access Ortho_Info_Type; + + type Ortho_Info_Type (Kind : Ortho_Info_Kind) is record + case Kind is + when Kind_Type => + -- Mode of the type. + Type_Mode : Type_Mode_Type := Type_Mode_Unknown; + + -- Additionnal info for complex types. + C : Complex_Type_Info_Acc := null; + + -- Ortho node which represents the type. + Ortho_Type : O_Tnode_Array; + -- Ortho pointer to the type. + Ortho_Ptr_Type : O_Tnode_Array; + + -- If true, the type is (still) incomplete. + Type_Incomplete : Boolean := False; + + -- Chain of temporary types to be destroyed at end of scope. + Type_Transient_Chain : Iir := Null_Iir; + + -- More info according to the type. + T : Ortho_Info_Type_Type; + + -- Run-time information. + Type_Rti : O_Dnode := O_Dnode_Null; + + when Kind_Incomplete_Type => + -- The declaration of the incomplete type. + Incomplete_Type : Iir; + Incomplete_Array : Ortho_Info_Acc; + when Kind_Expr => + -- Ortho tree which represents the expression, used for + -- enumeration literals. + Expr_Node : O_Cnode; + when Kind_Subprg => + -- Subprogram declaration node. + Ortho_Func : O_Dnode; + + -- True if the function can return a value stored in the secondary + -- stack. In this case, the caller must deallocate the area + -- allocated by the callee when the value was used. + Use_Stack2 : Boolean := False; + + -- For a function: + -- If the return value is not composite, then this field + -- must be O_LNODE_NULL. + -- If the return value is a composite type, then the caller must + -- give to the callee an area to put the result. This area is + -- given via an (hidden to the user) interface. Furthermore, + -- the function is translated into a procedure. + -- For a procedure: + -- If there are copy-out interfaces, they are gathered in a + -- record and a pointer to the record is passed to the + -- procedure. RES_INTERFACE is the interface for this pointer. + Res_Interface : O_Dnode := O_Dnode_Null; + + -- For a procedure with a result interface: + -- Type definition for the record. + Res_Record_Type : O_Tnode := O_Tnode_Null; + -- Type definition for access to the record. + Res_Record_Ptr : O_Tnode := O_Tnode_Null; + + -- Instances for the subprograms. + Subprg_Instance : Chap2.Instance_Inters := + Chap2.Null_Instance_Inters; + + Subprg_Resolv : Subprg_Resolv_Info_Acc := null; + + -- Local identifier number, set by spec, continued by body. + Subprg_Local_Id : Local_Identifier_Type; + + -- If set, return should be converted into exit out of the + -- SUBPRG_EXIT loop and the value should be assigned to + -- SUBPRG_RESULT, if any. + Subprg_Exit : O_Snode := O_Snode_Null; + Subprg_Result : O_Dnode := O_Dnode_Null; + when Kind_Object => + -- For constants: set when the object is defined as a constant. + Object_Static : Boolean; + -- The object itself. + Object_Var : Var_Acc; + -- RTI constant for the object. + Object_Rti : O_Dnode := O_Dnode_Null; + -- Function to compute the value of object (used for implicit + -- guard signal declaration). + Object_Function : O_Dnode; + when Kind_Alias => + Alias_Var : Var_Acc; + Alias_Kind : Object_Kind_Type; + when Kind_Iterator => + Iterator_Var : Var_Acc; + when Kind_Interface => + -- Ortho node for the interface. + Interface_Node : O_Dnode; + -- Field of the result record for copy-out arguments of procedure. + Interface_Field : O_Fnode; + -- Type of the interface. + Interface_Type : O_Tnode; + -- Ortho node for the interface of the protected subprogram. + Interface_Protected : O_Dnode; + when Kind_Disconnect => + -- Variable which contains the time_expression of the + -- disconnection specification + Disconnect_Var : Var_Acc; + when Kind_Process => + -- Type of process declarations. + Process_Decls_Type : O_Tnode; + + -- Field in the parent block for the declarations in the process. + Process_Parent_Field : O_Fnode; + + -- Subprogram for the process. + Process_Subprg : O_Dnode; + + -- RTI for the process. + Process_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Loop => + -- Labels for the loop. + -- Used for exit/next from while-loop, and to exit from for-loop. + Label_Exit : O_Snode; + -- Used to next from for-loop, with an exit statment. + Label_Next : O_Snode; + when Kind_Block => + -- Instance type (ortho record) for declarations contained in the + -- block/entity/architecture. + Block_Decls_Type : O_Tnode; + Block_Decls_Ptr_Type : O_Tnode; + + -- For Entity: field in the instance type containing link to + -- parent. + Block_Link_Field : O_Fnode; + + -- For an entity: must be o_fnode_null. + -- For an architecture: the entity field. + -- For a block, a component or a generate block: field in the + -- parent instance which contains the declarations for this + -- block. + -- For a direct instantiation: link to the instance. + Block_Parent_Field : O_Fnode; + + -- For a generate block: field in the block providing a chain to + -- the previous block (note: this may not be the parent, but + -- is a parent). + Block_Origin_Field : O_Fnode; + -- For an iterative block: boolean field set when the block + -- is configured. This is used to check if the block was already + -- configured since index and slice are not compelled to be + -- locally static. + Block_Configured_Field : O_Fnode; + + -- For iterative generate block: array of instances. + Block_Decls_Array_Type : O_Tnode; + Block_Decls_Array_Ptr_Type : O_Tnode; + + -- Subprogram which elaborates the block (for entity or arch). + Block_Elab_Subprg : O_Dnode; + -- Size of the block instance. + Block_Instance_Size : O_Dnode; + + -- RTI constant for the block. + Block_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Component => + -- Instance for the component. + Comp_Type : O_Tnode; + Comp_Ptr_Type : O_Tnode; + -- Field containing a pointer to the instance link. + Comp_Link : O_Fnode; + -- RTI for the component. + Comp_Rti_Const : O_Dnode; + when Kind_Config => + Config_Subprg : O_Dnode; + when Kind_Field => + -- Node for a record element declaration. + Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null); + when Kind_Package => + -- Subprogram which elaborate the package spec/body. + -- External units should call the body elaborator. + -- The spec elaborator is called only from the body elaborator. + Package_Elab_Spec_Subprg : O_Dnode; + Package_Elab_Body_Subprg : O_Dnode; + + -- Variable set to true when the package is elaborated. + Package_Elab_Var : O_Dnode; + + -- RTI constant for the package. + Package_Rti_Const : O_Dnode; + + -- Local id, set by package declaration, continued by package + -- body. + Package_Local_Id : Local_Identifier_Type; + when Kind_Assoc => + Assoc_In : Assoc_Conv_Info; + Assoc_Out : Assoc_Conv_Info; + when Kind_Design_File => + Design_Filename : O_Dnode; + when Kind_Library => + Library_Rti_Const : O_Dnode; + end case; + end record; + + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => Ortho_Info_Acc, Object => Ortho_Info_Type); + + subtype Type_Info_Acc is Ortho_Info_Acc (Kind_Type); + subtype Incomplete_Type_Info_Acc is Ortho_Info_Acc (Kind_Incomplete_Type); + subtype Subprg_Info_Acc is Ortho_Info_Acc (Kind_Subprg); + subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object); + subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias); + subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process); + subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop); + subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block); + subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component); + subtype Field_Info_Acc is Ortho_Info_Acc (Kind_Field); + subtype Config_Info_Acc is Ortho_Info_Acc (Kind_Config); + subtype Assoc_Info_Acc is Ortho_Info_Acc (Kind_Assoc); + --subtype Inter_Info_Acc is Ortho_Info_Acc (Kind_Interface); + subtype Design_File_Info_Acc is Ortho_Info_Acc (Kind_Design_File); + subtype Library_Info_Acc is Ortho_Info_Acc (Kind_Library); + + package Node_Infos is new GNAT.Table + (Table_Component_Type => Ortho_Info_Acc, + Table_Index_Type => Iir, + Table_Low_Bound => 0, + Table_Initial => 1024, + Table_Increment => 100); + + procedure Update_Node_Infos + is + use Nodes; + F, L : Iir; + begin + F := Node_Infos.Last; + L := Nodes.Get_Last_Node; + Node_Infos.Set_Last (L); + Node_Infos.Table (F + 1 .. L) := (others => null); + end Update_Node_Infos; + + procedure Set_Info (Target : Iir; Info : Ortho_Info_Acc) is + begin + if Node_Infos.Table (Target) /= null then + raise Internal_Error; + end if; + Node_Infos.Table (Target) := Info; + end Set_Info; + + procedure Clear_Info (Target : Iir) is + begin + Node_Infos.Table (Target) := null; + end Clear_Info; + + function Get_Info (Target : Iir) return Ortho_Info_Acc is + begin + return Node_Infos.Table (Target); + end Get_Info; + + -- Create an ortho_info field of kind KIND for iir node TARGET, and + -- return it. + function Add_Info (Target : Iir; Kind : Ortho_Info_Kind) + return Ortho_Info_Acc + is + Res : Ortho_Info_Acc; + begin + Res := new Ortho_Info_Type (Kind); + Set_Info (Target, Res); + return Res; + end Add_Info; + + procedure Free_Info (Target : Iir) + is + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Target); + if Info /= null then + case Info.Kind is + when Kind_Object => + Free_Var (Info.Object_Var); + when Kind_Alias => + Free_Var (Info.Alias_Var); + when Kind_Iterator => + Free_Var (Info.Iterator_Var); + when others => + null; + end case; + Unchecked_Deallocation (Info); + Clear_Info (Target); + end if; + end Free_Info; + + procedure Free_Type_Info (Info : in out Type_Info_Acc; Full : Boolean) + is + procedure Free is new Ada.Unchecked_Deallocation + (O_Fnode_Arr, O_Fnode_Arr_Acc); + begin + case Info.T.Kind is + when Kind_Type_Scalar => + Free_Var (Info.T.Range_Var); + when Kind_Type_Array => + Free_Var (Info.T.Array_Bounds); + if Full then + Free (Info.T.Bounds_Vector); + Free_Var (Info.T.Array_1bound); + Free_Var (Info.T.Array_Index_Desc); + end if; + when Kind_Type_Record => + if Full then + Free_Var (Info.T.Record_El_Desc); + end if; + when Kind_Type_File => + null; + when Kind_Type_Protected => + null; + end case; + if Info.C /= null then + Free_Var (Info.C.Size_Var (Mode_Value)); + Free_Var (Info.C.Size_Var (Mode_Signal)); + Free_Complex_Type_Info (Info.C); + end if; + Unchecked_Deallocation (Info); + end Free_Type_Info; + + procedure Set_Ortho_Expr (Target : Iir; Expr : O_Cnode) + is + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Target, Kind_Expr); + Info.Expr_Node := Expr; + end Set_Ortho_Expr; + + function Get_Ortho_Expr (Target : Iir) return O_Cnode is + begin + return Get_Info (Target).Expr_Node; + end Get_Ortho_Expr; + + function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type) + return O_Tnode is + begin + return Get_Info (Target).Ortho_Type (Is_Sig); + end Get_Ortho_Type; + + function Get_Ortho_Decl (Subprg : Iir) return O_Dnode + is + begin + return Get_Info (Subprg).Ortho_Func; + end Get_Ortho_Decl; + + function Get_Resolv_Ortho_Decl (Func : Iir) return O_Dnode + is + begin + return Get_Info (Func).Subprg_Resolv.Resolv_Func; + end Get_Resolv_Ortho_Decl; + + -- Return true is INFO is a type info for a composite type, ie: + -- * a record + -- * an array (fat or thin) + -- * a fat pointer. + function Is_Composite (Info : Type_Info_Acc) return Boolean; + pragma Inline (Is_Composite); + + function Is_Composite (Info : Type_Info_Acc) return Boolean is + begin + return Info.Type_Mode in Type_Mode_Fat; + end Is_Composite; + + -- Convert an o_lnode to an o_enode, either by taking value or address. + function L2e_Node (L : O_Lnode; + Type_Info : Type_Info_Acc; + Kind : Object_Kind_Type) + return O_Enode is + begin + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_Ptr_Array + | Type_Mode_File => + return New_Value (L); + when Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return New_Address (L, Type_Info.Ortho_Ptr_Type (Kind)); + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Protected => + return New_Address (L, Type_Info.Ortho_Ptr_Type (Kind)); + end case; + end L2e_Node; + +-- -- Get Lnode from a variable pointer. +-- function Ptr2l_Node (Var_Ptr : O_Lnode; Info : Type_Info_Acc) return O_Lnode +-- is +-- begin +-- case Info.Type_Mode is +-- when Type_Mode_Fat_Array +-- | Type_Mode_Array +-- | Type_Mode_Record +-- | Type_Mode_Fat_Acc => +-- return New_Access_Element (New_Value (Var_Ptr)); +-- when Type_Mode_Ptr_Array => +-- return Var_Ptr; +-- when others => +-- raise Internal_Error; +-- end case; +-- end Ptr2l_Node; + +-- function Get_Bounds_Ptr (Info : Type_Info_Acc) return O_Enode is +-- begin +-- case Info.Type_Mode is +-- when Type_Mode_Array +-- | Type_Mode_Ptr_Array => +-- return New_Address (Get_Var (Info.T.Array_Bounds), +-- Info.T.Bounds_Ptr_Type); +-- when others => +-- raise Internal_Error; +-- end case; +-- end Get_Bounds_Ptr; + + -- In order to simplify the handling of Enode/Lnode, let's introduce + -- Mnode (yes, another node). + -- An Mnode is a typed union, containing either an Lnode or a Enode. + -- See Mstate for a description of the union. + -- The real data is contained insisde a record, so that the discriminant + -- can be changed. + type Mnode; + + -- State of an Mmode. + type Mstate is + ( + -- The Mnode contains an Enode, which can be either a value or a + -- pointer. + -- This Mnode can be used only once. + Mstate_E, + + -- The Mnode contains an Lnode representing a value. + -- This Lnode can be used only once. + Mstate_Lv, + + -- The Mnode contains an Lnode representing a pointer. + -- This Lnode can be used only once. + Mstate_Lp, + + -- The Mnode contains an Dnode for a variable representing a value. + -- This Dnode may be used several times. + Mstate_Dv, + + -- The Mnode contains an Dnode for a variable representing a pointer. + -- This Dnode may be used several times. + Mstate_Dp, + + -- Null Mnode. + Mstate_Null, + + -- The Mnode is invalid (such as already used). + Mstate_Bad); + + type Mnode1 (State : Mstate := Mstate_Bad) is record + -- True if the object is composite (its value cannot be read directly). + Comp : Boolean; + + -- Additionnal informations about the objects: kind and type. + K : Object_Kind_Type; + T : Type_Info_Acc; + + -- Ortho type of the object. + Vtype : O_Tnode; + + -- Type for a pointer to the object. + Ptype : O_Tnode; + + case State is + when Mstate_E => + E : O_Enode; + when Mstate_Lv => + Lv : O_Lnode; + when Mstate_Lp => + Lp : O_Lnode; + when Mstate_Dv => + Dv : O_Dnode; + when Mstate_Dp => + Dp : O_Dnode; + when Mstate_Bad + | Mstate_Null => + null; + end case; + end record; + --pragma Pack (Mnode1); + + type Mnode is record + M1 : Mnode1; + end record; + + -- Null Mnode. + Mnode_Null : constant Mnode := Mnode'(M1 => (State => Mstate_Null, + Comp => False, + K => Mode_Value, + Ptype => O_Tnode_Null, + Vtype => O_Tnode_Null, + T => null)); + + + -- Object kind of a Mnode + function Get_Object_Kind (M : Mnode) return Object_Kind_Type; + + -- Transform VAR to Mnode. + function Get_Var + (Var : Var_Acc; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode; + + -- Return a stabilized node for M. + -- The former M is not usuable anymore. + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode; + + -- Stabilize M. + procedure Stabilize (M : in out Mnode); + + -- If M is not stable, create a variable containing the value of M. + -- M must be scalar (or access). + function Stabilize_Value (M : Mnode) return Mnode; + + -- Create a temporary of type INFO and kind KIND. + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode; + + package Chap3 is + -- Translate the subtype of an object, since an object can define + -- a subtype. + -- This can be done only for a declaration. + -- DECL must have an identifier and a type. + procedure Translate_Object_Subtype + (Decl : Iir; With_Vars : Boolean := True); + procedure Elab_Object_Subtype (Def : Iir); + + -- Translate the subtype of a literal. + -- This can be done not at declaration time, ie no variables are created + -- for this subtype. + --procedure Translate_Literal_Subtype (Def : Iir); + + -- Translation of a type definition: + -- 1. Create corresponding Ortho type. + -- 2. Create bounds type + -- 3. Create bounds declaration + -- 4. Create bounds constructor + -- 5. Create type descriptor declaration + -- 6. Create type descriptor constructor + + procedure Translate_Type_Definition + (Def : Iir; With_Vars : Boolean := True); + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id); + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean); + + -- Some expressions may be evaluated several times in different + -- contexts. Type info created for these expressions may not be + -- shared between these contexts. + procedure Destroy_Type_Info (Atype : Iir); + + -- Translate subprograms for types. + procedure Translate_Type_Subprograms (Decl : Iir); + + procedure Create_Type_Definition_Type_Range (Def : Iir); + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode; + + -- Same as Translate_type_definition only for std.standard.boolean and + -- std.standard.bit. + procedure Translate_Bool_Type_Definition (Def : Iir); + + 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); + + -- Build variable given by GET_FIELD_LNODE: ie set internals + -- fields. + generic + with function Get_Field_Lnode return O_Lnode; + procedure Builder_Update_Field + (Field_Type : Iir; Mem : O_Dnode; Kind : Object_Kind_Type); + + -- 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; + + -- Get the length of the array. + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode; + + 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; + + -- PTR must be a variable pointing to a bounds of type ATYPE. + function Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) + return O_Enode; + + -- Return the a pointer to the array base from variable PTR + -- containing a pointer to array. + function Get_Array_Ptr_Base_Ptr + (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) + return O_Lnode; + + -- Return pointer to range DIM of array pointed by PTR. + function Get_Array_Ptr_Range_Ptr (Ptr : O_Lnode; + Array_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + return O_Enode; + + + function Get_Array_Bounds_Ptr + (Arr : O_Lnode; Arr_Type : Iir; Is_Sig : Object_Kind_Type) + return O_Enode; + + -- Return the bounds field of a fat array from variable PTR containing a + -- pointer to a fat array. + function Get_Array_Ptr_Bounds_Ptr + (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) + return O_Enode; + + -- 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 : O_Enode); + + -- 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 (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); + + -- 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 o_lnode_null). + -- If L_TYPE (resp. T_TYPE) is a fat array, then L_NODE (resp. R_NODE) + -- must be a variable pointing to the array. + procedure Check_Array_Match (L_Type : Iir; + L_Node : O_Lnode; + L_Mode : Object_Kind_Type; + R_Type : Iir; + R_Node : O_Lnode; + R_Mode : Object_Kind_Type; + 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. + procedure Create_Range_From_Length + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode); + + 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. + -- For a global subprograms belonging to an instance (ie, subprograms + -- declared in a block, entity or architecture), BLOCK is the info + -- for the base block to which the subprograms belong; null if none; + -- It is used to add an instance parameter. + procedure Translate_Declaration_Chain_Subprograms + (Parent : Iir; Block : 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). + procedure Translate_Association_Subprograms + (Assoc_Chain : 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: DECL 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 + (Decl : Iir; Parent : Iir; Check_Null : Boolean); + + -- 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; + + -- Get the ortho type for an element of type TINFO. + function Get_Element_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; + + -- 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; + +-- -- Get direction/length/left bound/right bound of dimension DIM of +-- -- array ARR whose type if ARR_TYPE. +-- -- For a thin array, ARR is the array; +-- -- For a fat array, ARR is the fat array (ie the record with base and +-- -- bounds pointer) and not a pointer. +-- function Get_Array_Bound_Dir (Arr : O_Lnode; +-- Arr_Type : Iir; +-- Dim : Natural; +-- Is_Sig : Object_Kind_Type) +-- return O_Enode; + function Get_Array_Bound_Length (Arr : O_Lnode; + Arr_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + + return O_Enode; + function Get_Array_Ptr_Bound_Length (Ptr : O_Lnode; + Arr_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + return O_Enode; +-- function Get_Array_Bound_Left (Arr : O_Lnode; +-- Arr_Type : Iir; +-- Dim : Natural; +-- Is_Sig : Object_Kind_Type) +-- return O_Enode; +-- function Get_Array_Bound_Right (Arr : O_Lnode; +-- Arr_Type : Iir; +-- Dim : Natural; +-- Is_Sig : Object_Kind_Type) +-- return O_Enode; + + -- Extract from fat array FAT_ARRAY the range corresponding to dimension + -- DIM. + function Fat_Array_To_Range (Fat_Array : O_Lnode; + Array_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + return O_Lnode; + + procedure Gen_Bound_Error (Loc : Iir); + + -- Generate code to emit a program error. + procedure Gen_Program_Error (Loc : Iir); + + -- 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 offset in the range pointed by RANGE_PTR of INDEX. + -- This checks INDEX belongs to the range. + function Translate_Index_To_Offset (Range_Ptr : O_Dnode; + Index : O_Enode; + Index_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) + 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. + -- 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); + + -- 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 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; + + -- 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_High_Type_Attribute (Atype : Iir) return O_Enode; + function Translate_Low_Type_Attribute (Atype : Iir) return O_Enode; + + function Translate_Val_Attribute (Attr : Iir) return O_Enode; + function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) + return O_Enode; + + function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode; + + function Translate_Image_Attribute (Attr : Iir) return O_Enode; + function Translate_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Event_Attribute (Attr : Iir) return O_Enode; + function Translate_Active_Attribute (Attr : Iir) return O_Enode; + function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) + return O_Enode; + + function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Driving_Attribute (Attr : Iir) return O_Enode; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode; + end Chap14; + + package Helpers is + -- Return the value of field FIELD of lnode L that is contains + -- a pointer to a record. + -- This is equivalent to: + -- new_value (new_selected_element (new_access_element (new_value (l)), + -- field)) + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode; + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode; + + -- Equivalent to new_access_element (new_value (l)) + function New_Acc_Value (L : O_Lnode) return O_Lnode; + + -- Copy a fat pointer. + -- D and S are stabilized fat pointers. + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); + + -- Copy a fat access. + -- D and S are variable containing address of the fat pointer. + -- PTR_TYPE is the type of the fat access. + procedure Copy_Fat_Access (D : O_Dnode; S : O_Dnode; Ptr_Type : Iir); + + -- Generate code to initialize a ghdl_index_type variable V to 0. + procedure Init_Var (V : O_Dnode); + + -- Generate code to increment/decrement a ghdl_index_type variable V. + procedure Inc_Var (V : O_Dnode); + --procedure Dec_Var (V : O_Lnode); + + -- Generate code to exit from loop LABEL iff COND is true. + procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode); + + -- Create a uniq identifier. + function Create_Uniq_Identifier return O_Ident; + + -- Create a region for temporary variables. + procedure Open_Temp; + -- Create a temporary variable. + function Create_Temp (Atype : O_Tnode) return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with VALUE. + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with the + -- address of NAME. + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode; + -- Create a temporary variable for ATYPE and assign it with address + -- of NAME. + function Create_Temp_Ptr + (Atype : Iir; Name : O_Lnode; Is_Sig : Object_Kind_Type) + return O_Dnode; + -- Create a mark in the temporary region for the stack2. + -- FIXME: maybe a flag must be added to CLOSE_TEMP where it is known + -- stack2 can be released. + procedure Create_Temp_Stack2_Mark; + -- Add ATYPE in the chain of types to be destroyed at the end of the + -- temp scope. + procedure Add_Transient_Type_In_Temp (Atype : Iir); + -- Close the temporary region. + procedure Close_Temp; + + -- Free all old temp. + -- Used only to free memory. + procedure Free_Old_Temp; + + -- Create a constant (of name ID) for string STR. + -- Append a NUL terminator (to make interfaces with C easier). + function Create_String (Str : String; Id : O_Ident) return O_Dnode; + + function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode; + + procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode); + + -- Allocate SIZE bytes aligned on the biggest alignment and return a + -- pointer of type PTYPE. + function Gen_Alloc + (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) + return O_Enode; + + -- Allocate on the heap LENGTH bytes aligned on the biggest alignment, + -- and returns a pointer of type PTYPE. + --function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode; + + -- Handle a composite type TARG/TARG_TYPE and apply DO_NON_COMPOSITE + -- on each non composite type. + -- There is a generic parameter DATA which may be updated + -- before indexing an array by UPDATE_DATA_ARRAY. + generic + type Data_Type is private; + type Composite_Data_Type is private; + with procedure Do_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- This function should extract the base of DATA. + with function Prepare_Data_Array (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should index DATA. + with function Update_Data_Array (Data : Composite_Data_Type; + Targ_Type : Iir; + Index : O_Dnode) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Array (Data : in out Composite_Data_Type); + + -- This function should stabilize DATA. + with function Prepare_Data_Record (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should extract field EL of DATA. + with function Update_Data_Record (Data : Composite_Data_Type; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Record (Data : in out Composite_Data_Type); + + procedure Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- Call a procedure (DATA_TYPE) for each signal of TARG. + procedure Register_Signal + (Targ : Mnode; Targ_Type : Iir; Proc : O_Dnode); + + -- Call PROC for each scalar signal of list LIST. + procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode); + + -- Often used subprograms for Foreach_non_composite + -- when DATA_TYPE is o_enode. + function Gen_Oenode_Prepare_Data_Composite + (Targ: Mnode; Targ_Type : Iir; Val : O_Enode) + return Mnode; + function Gen_Oenode_Update_Data_Array (Val : Mnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Enode; + function Gen_Oenode_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Enode; + procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode); + + type Hexstr_Type is array (Integer range 0 .. 15) of Character; + N2hex : constant Hexstr_Type := "0123456789abcdef"; + + function Get_Line_Number (Target: Iir) return Natural; + private + end Helpers; + use Helpers; + + function Get_Type_Info (M : Mnode) return Type_Info_Acc is + begin + return M.M1.T; + end Get_Type_Info; + + function Get_Object_Kind (M : Mnode) return Object_Kind_Type is + begin + return M.M1.K; + end Get_Object_Kind; + + function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_E, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, E => E, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end E2M; + + function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lv2M; + + function Lv2M (L : O_Lnode; + Comp : Boolean; + Vtype : O_Tnode; + Ptype : O_Tnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => Comp, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lp2M; + + function Lp2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => Vtype, Ptype => Ptype)); + end Lp2M; + + function Lv2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => Vtype, + Ptype => Ptype)); + end Dv2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => Vtype, Ptype => Ptype)); + end Dp2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dp2M; + + function M2Lv (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + case Get_Type_Info (M).Type_Mode is + when Type_Mode_Thin => + -- Scalar to var is not possible. + -- FIXME: This is not coherent with the fact that this + -- conversion is possible when M is stabilized. + raise Internal_Error; + when Type_Mode_Fat => + return New_Access_Element (M.M1.E); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + when Mstate_Lp => + return New_Acc_Value (M.M1.Lp); + when Mstate_Lv => + return M.M1.Lv; + when Mstate_Dp => + return New_Acc_Value (New_Obj (M.M1.Dp)); + when Mstate_Dv => + return New_Obj (M.M1.Dv); + when Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lv; + + function M2Lp (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + raise Internal_Error; + when Mstate_Lp => + return M.M1.Lp; + when Mstate_Dp => + return New_Obj (M.M1.Dp); + when Mstate_Lv => + if Get_Type_Info (M).Type_Mode in Type_Mode_Fat then + return New_Obj + (Create_Temp_Init (M.M1.Ptype, + New_Address (M.M1.Lv, M.M1.Ptype))); + else + raise Internal_Error; + end if; + when Mstate_Dv + | Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lp; + + function M2Dp (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dp => + return M.M1.Dp; + when Mstate_Dv => + return Create_Temp_Init + (M.M1.Ptype, New_Address (New_Obj (M.M1.Dv), M.M1.Ptype)); + + when others => + raise Internal_Error; + end case; + end M2Dp; + + function M2Dv (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dv => + return M.M1.Dv; + when others => + raise Internal_Error; + end case; + end M2Dv; + + function T2M (Atype : Iir; Kind : Object_Kind_Type) return Mnode + is + T : Type_Info_Acc; + begin + T := Get_Info (Atype); + return Mnode'(M1 => (State => Mstate_Null, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end T2M; + + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode + is + D : O_Dnode; + K : Object_Kind_Type; + begin + K := M.M1.K; + case M.M1.State is + when Mstate_E => + if M.M1.Comp then + D := Create_Temp_Init (M.M1.Ptype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + else + D := Create_Temp_Init (M.M1.Vtype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Lp => + D := Create_Temp_Init (M.M1.Ptype, New_Value (M.M1.Lp)); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + when Mstate_Lv => + if M.M1.Ptype = O_Tnode_Null then + if not Can_Copy then + raise Internal_Error; + end if; + D := Create_Temp_Init (M.M1.Vtype, New_Value (M.M1.Lv)); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + + else + D := Create_Temp_Ptr (M.M1.Ptype, M.M1.Lv); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end Stabilize; + + procedure Stabilize (M : in out Mnode) is + begin + M := Stabilize (M); + end Stabilize; + + function Stabilize_Value (M : Mnode) return Mnode + is + D : O_Dnode; + E : O_Enode; + begin + -- M must be scalar or access. + if M.M1.Comp then + raise Internal_Error; + end if; + case M.M1.State is + when Mstate_E => + E := M.M1.E; + when Mstate_Lp => + E := New_Value (New_Acc_Value (M.M1.Lp)); + when Mstate_Lv => + E := New_Value (M.M1.Lv); + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + + D := Create_Temp_Init (M.M1.Vtype, E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => M.M1.K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end Stabilize_Value; + + function M2E (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_E => + return M.M1.E; + when Mstate_Lp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (M.M1.Lp)); + when Type_Mode_Fat => + return New_Value (M.M1.Lp); + end case; + when Mstate_Dp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (New_Obj (M.M1.Dp))); + when Type_Mode_Fat => + return New_Value (New_Obj (M.M1.Dp)); + end case; + when Mstate_Lv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (M.M1.Lv); + when Type_Mode_Fat => + return New_Address (M.M1.Lv, M.M1.Ptype); + end case; + when Mstate_Dv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Obj (M.M1.Dv)); + when Type_Mode_Fat => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + end case; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2E; + + function M2Addr (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_Lp => + return New_Value (M.M1.Lp); + when Mstate_Dp => + return New_Value (New_Obj (M.M1.Dp)); + when Mstate_Lv => + return New_Address (M.M1.Lv, M.M1.Ptype); + when Mstate_Dv => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + when Mstate_E => + if M.M1.Comp then + return M.M1.E; + else + raise Internal_Error; + end if; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2Addr; + +-- function Is_Null (M : Mnode) return Boolean is +-- begin +-- return M.M1.State = Mstate_Null; +-- end Is_Null; + + function Is_Stable (M : Mnode) return Boolean is + begin + case M.M1.State is + when Mstate_Dp + | Mstate_Dv => + return True; + when others => + return False; + end case; + end Is_Stable; + +-- function Varv2M +-- (Var : Var_Acc; 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_Acc; + Var_Type : Type_Info_Acc; + Mode : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype); + end Varv2M; + + -- Convert a Lnode for a sub object) to an MNODE. + function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Lv2M (L, Vtype, Mode); + when Type_Mode_Ptr_Array + | Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Vtype.C = null then + return Lv2M (L, Vtype, Mode); + else + return Lp2M (L, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Dv2M (D, Vtype, Mode); + when Type_Mode_Ptr_Array + | Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Vtype.C = null then + return Dv2M (D, Vtype, Mode); + else + return Dp2M (D, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Get_Var + (Var : Var_Acc; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode + is + L : O_Lnode; + D : O_Dnode; + Stable : Boolean; + begin + -- FIXME: there may be Vv2M and Vp2M. + Stable := Is_Var_Stable (Var); + if Stable then + D := Get_Var_Label (Var); + else + L := Get_Var (Var); + end if; + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + when Type_Mode_Ptr_Array + | Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Vtype.C = null then + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + else + if Stable then + return Dp2M (D, Vtype, Mode); + else + return Lp2M (L, Vtype, Mode); + end if; + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Get_Var; + + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode is + begin + if Info.C /= null and then Info.Type_Mode /= Type_Mode_Fat_Array then + -- For a complex and constrained object, we just allocate + -- a pointer to the object. + return Dp2M (Create_Temp (Info.Ortho_Ptr_Type (Kind)), Info, Kind); + else + return Dv2M (Create_Temp (Info.Ortho_Type (Kind)), Info, Kind); + end if; + end Create_Temp; + + function Translate_Foreign_Id (Decl : Iir; Extract_Name : Boolean) + return Foreign_Info_Type + is + use Name_Table; + Attr : Iir_Attribute_Value; + Spec : Iir_Attribute_Specification; + Attr_Decl : Iir; + Expr : Iir; + P : Natural; + begin + -- Look for 'FOREIGN. + Attr := Get_Attribute_Value_Chain (Decl); + while Attr /= Null_Iir loop + Spec := Get_Attribute_Specification (Attr); + Attr_Decl := Get_Attribute_Designator (Spec); + exit when Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign; + Attr := Get_Chain (Attr); + end loop; + if Attr = Null_Iir then + -- Not found. + raise Internal_Error; + end if; + Spec := Get_Attribute_Specification (Attr); + Expr := Get_Expression (Spec); + case Get_Kind (Expr) is + when Iir_Kind_String_Literal => + declare + Ptr : String_Fat_Acc; + begin + Ptr := Get_String_Fat_Acc (Expr); + Name_Length := Get_String_Length (Expr); + for I in 1 .. Name_Length loop + Name_Buffer (I) := Ptr (I); + end loop; + end; + when Iir_Kind_Simple_Aggregate => + declare + List : Iir_List; + El : Iir; + begin + List := Get_Simple_Aggregate_List (Expr); + Name_Length := 0; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Kind (El) /= Iir_Kind_Enumeration_Literal then + raise Internal_Error; + end if; + Name_Length := Name_Length + 1; + Name_Buffer (Name_Length) := + Character'Val (Get_Enum_Pos (El)); + end loop; + end; + when Iir_Kind_Bit_String_Literal => + Error_Msg_Sem + ("value of FOREIGN attribute cannot be a bit string", Expr); + Name_Length := 0; + when others => + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem + ("value of FOREIGN attribute must be locally static", Expr); + Name_Length := 0; + else + raise Internal_Error; + end if; + end case; + + if Name_Length = 0 then + return Foreign_Bad; + end if; + + -- Only 'VHPIDIRECT' is recognized. + if Name_Length >= 10 + and then Name_Buffer (1 .. 10) = "VHPIDIRECT" + then + P := 11; + + -- Skip spaces. + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + if Extract_Name then + return Foreign_Info_Type' + (Kind => Foreign_Vhpidirect, + Subprg => Get_Identifier (Name_Buffer (P .. Name_Length)), + Lib => Null_Identifier); + else + return Foreign_Info_Type'(Kind => Foreign_Vhpidirect, + Subprg => O_Ident_Nul, + Lib => Null_Identifier); + end if; + elsif Name_Length = 14 + and then Name_Buffer (1 .. 14) = "GHDL intrinsic" + then + return Foreign_Info_Type'(Kind => Foreign_Intrinsic, + Subprg => Create_Identifier); + else + Error_Msg_Sem + ("value of 'FOREIGN attribute does not begin with VHPIDIRECT", + Spec); + return Foreign_Bad; + end if; + end Translate_Foreign_Id; + + package body Helpers is + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode is + begin + return New_Value + (New_Selected_Element (New_Access_Element (New_Value (L)), Field)); + end New_Value_Selected_Acc_Value; + + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode is + begin + return New_Selected_Element + (New_Access_Element (New_Value (L)), Field); + end New_Selected_Acc_Value; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode + is + begin + return New_Indexed_Element (New_Access_Element (New_Value (L)), I); + end New_Indexed_Acc_Value; + + function New_Acc_Value (L : O_Lnode) return O_Lnode is + begin + return New_Access_Element (New_Value (L)); + end New_Acc_Value; + + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) + is + begin + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)), + M2Addr (Chap3.Get_Array_Base (S))); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (D)), + M2Addr (Chap3.Get_Array_Bounds (S))); + end Copy_Fat_Pointer; + + procedure Copy_Fat_Pointer + (D : O_Dnode; S : O_Dnode; Ftype : Iir; Is_Sig : Object_Kind_Type) + is + Info : Type_Info_Acc := Get_Info (Ftype); + begin + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (D), Info.T.Base_Field (Is_Sig)), + New_Value_Selected_Acc_Value (New_Obj (S), + Info.T.Base_Field (Is_Sig))); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (D), Info.T.Bounds_Field (Is_Sig)), + New_Value_Selected_Acc_Value (New_Obj (S), + Info.T.Bounds_Field (Is_Sig))); + end Copy_Fat_Pointer; + + procedure Copy_Fat_Access (D : O_Dnode; S : O_Dnode; Ptr_Type : Iir) + is + begin + Copy_Fat_Pointer (D, S, Get_Designated_Type (Ptr_Type), Mode_Value); + end Copy_Fat_Access; + + procedure Inc_Var (V : O_Dnode) is + begin + New_Assign_Stmt + (New_Obj (V), New_Dyadic_Op + (ON_Add_Ov, + New_Value (New_Obj (V)), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, 1)))); + end Inc_Var; + +-- procedure Dec_Var (V : O_Lnode) is +-- begin +-- New_Assign_Stmt +-- (V, New_Dyadic_Op (ON_Sub_Ov, +-- New_Value (V), +-- New_Unsigned_Literal (Ghdl_Index_Type, 1))); +-- end Dec_Var; + + procedure Init_Var (V : O_Dnode) is + begin + New_Assign_Stmt + (New_Obj (V), New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, 0))); + end Init_Var; + + procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode) + is + If_Blk : O_If_Block; + begin + Start_If_Stmt (If_Blk, Cond); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk); + end Gen_Exit_When; + + Uniq_Id : Natural := 0; + + function Create_Uniq_Identifier return O_Ident + is + Str : String (1 .. 12); + Val : Natural; + begin + Str (1 .. 3) := "_UI"; + Val := Uniq_Id; + Uniq_Id := Uniq_Id + 1; + for I in reverse 4 .. 11 loop + Str (I) := N2hex (Val mod 16); + Val := Val / 16; + end loop; + --Str (12) := Nul; + return Get_Identifier (Str (1 .. 11)); + end Create_Uniq_Identifier; + + -- Create a temporary variable. + type Temp_Level_Type; + type Temp_Level_Acc is access Temp_Level_Type; + type Temp_Level_Type is record + Prev : Temp_Level_Acc; + Level : Natural; + Id : Natural; + Emitted : Boolean; + Stack2_Mark : O_Dnode; + Transient_Types : Iir; + end record; + -- Current level. + Temp_Level : Temp_Level_Acc := null; + + -- List of unused temp_level_type structures. To be faster, they are + -- never deallocated. + Old_Level : Temp_Level_Acc := null; + + procedure Open_Temp + is + L : Temp_Level_Acc; + begin + if Old_Level /= null then + L := Old_Level; + Old_Level := L.Prev; + else + L := new Temp_Level_Type; + end if; + L.all := (Prev => Temp_Level, + Level => 0, + Id => 0, + Emitted => False, + Stack2_Mark => O_Dnode_Null, + Transient_Types => Null_Iir); + if Temp_Level /= null then + L.Level := Temp_Level.Level + 1; + end if; + Temp_Level := L; + end Open_Temp; + + procedure Add_Transient_Type_In_Temp (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Type_Info.Type_Transient_Chain := Temp_Level.Transient_Types; + Temp_Level.Transient_Types := Atype; + end Add_Transient_Type_In_Temp; + + procedure Close_Temp + is + L : Temp_Level_Acc; + Constr : O_Assoc_List; + begin + if Temp_Level = null then + -- OPEN_TEMP was not called. + raise Internal_Error; + end if; + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Stack2_Release); + New_Association (Constr, + New_Value (New_Obj (Temp_Level.Stack2_Mark))); + New_Procedure_Call (Constr); + end if; + if Temp_Level.Emitted then + Finish_Declare_Stmt; + end if; + + -- Destroy transcient types. + if Temp_Level.Transient_Types /= Null_Iir then + declare + Atype : Iir; + N_Atype : Iir; + begin + Atype := Temp_Level.Transient_Types; + while Atype /= Null_Iir loop + N_Atype := Get_Info (Atype).Type_Transient_Chain; + Chap3.Destroy_Type_Info (Atype); + Atype := N_Atype; + end loop; + end; + end if; + + -- Unlink temp_level. + L := Temp_Level; + Temp_Level := L.Prev; + L.Prev := Old_Level; + Old_Level := L; + end Close_Temp; + + procedure Free_Old_Temp + is + procedure Free is new Ada.Unchecked_Deallocation + (Temp_Level_Type, Temp_Level_Acc); + T : Temp_Level_Acc; + begin + if Temp_Level /= null then + raise Internal_Error; + end if; + loop + T := Old_Level; + exit when T = null; + Old_Level := Old_Level.Prev; + Free (T); + end loop; + end Free_Old_Temp; + + procedure Create_Temp_Stack2_Mark + is + Constr : O_Assoc_List; + begin + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + -- Only the first mark in a region is registred. + -- The release operation frees the memory allocated after the + -- first mark. + return; + end if; + Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type); + Start_Association (Constr, Ghdl_Stack2_Mark); + New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark), + New_Function_Call (Constr)); + end Create_Temp_Stack2_Mark; + + function Create_Temp (Atype : O_Tnode) return O_Dnode + is + Str : String (1 .. 12); + Val : Natural; + Res : O_Dnode; + P : Natural; + begin + if Temp_Level = null then + -- OPEN_TEMP was never called. + raise Internal_Error; + -- This is an hack, just to allow array subtype to array type + -- conversion. + --New_Var_Decl + -- (Res, Create_Uniq_Identifier, O_Storage_Private, Atype); + --return Res; + else + if not Temp_Level.Emitted then + Temp_Level.Emitted := True; + Start_Declare_Stmt; + end if; + end if; + Val := Temp_Level.Id; + Temp_Level.Id := Temp_Level.Id + 1; + P := Str'Last; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := '_'; + P := P - 1; + Val := Temp_Level.Level; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := 'T'; + --Str (12) := Nul; + New_Var_Decl + (Res, Get_Identifier (Str (P .. Str'Last)), O_Storage_Local, Atype); + return Res; + end Create_Temp; + + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode + is + Res : O_Dnode; + begin + Res := Create_Temp (Atype); + New_Assign_Stmt (New_Obj (Res), Value); + return Res; + end Create_Temp_Init; + + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode is + begin + return Create_Temp_Init (Atype, New_Address (Name, Atype)); + end Create_Temp_Ptr; + + function Create_Temp_Ptr + (Atype : Iir; Name : O_Lnode; Is_Sig : Object_Kind_Type) + return O_Dnode + is + Temp_Type : O_Tnode; + begin + Temp_Type := Get_Info (Atype).Ortho_Ptr_Type (Is_Sig); + return Create_Temp_Init (Temp_Type, New_Address (Name, Temp_Type)); + end Create_Temp_Ptr; + + -- 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_Array => + declare + Var_I : O_Dnode; + Var_Array : Mnode; + Label : O_Snode; + Composite_Data : Composite_Data_Type; + Sub_Data : Data_Type; + begin + Open_Temp; + Var_Array := Stabilize (Targ); + 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); + Composite_Data := + Prepare_Data_Array (Var_Array, Targ_Type, Data); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Value (New_Obj (Var_I)), + Chap3.Get_Array_Type_Length (Targ_Type), + Ghdl_Bool_Type)); + Sub_Data := Update_Data_Array + (Composite_Data, Targ_Type, Var_I); + Foreach_Non_Composite + (Chap3.Index_Base (Var_Array, 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_Fat_Array + | Type_Mode_Ptr_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; + El : Iir_Element_Declaration; + begin + Open_Temp; + Var_Record := Stabilize (Targ); + Composite_Data := + Prepare_Data_Record (Var_Record, Targ_Type, Data); + El := Get_Element_Declaration_Chain + (Get_Base_Type (Targ_Type)); + while El /= Null_Iir loop + 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); + El := Get_Chain (El); + 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) + is + Proc_1 : O_Dnode := Proc; + begin + Register_Signal_1 (Targ, Targ_Type, Proc_1); + end Register_Signal; + + 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_Ptr_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; + end Helpers; + + package body Chap1 is + procedure Start_Block_Decl (Blk : Iir) + is + Info : Block_Info_Acc; + begin + Info := Get_Info (Blk); + New_Uncomplete_Record_Type (Info.Block_Decls_Type); + New_Type_Decl (Create_Identifier ("INSTTYPE"), Info.Block_Decls_Type); + Info.Block_Decls_Ptr_Type := New_Access_Type (Info.Block_Decls_Type); + New_Type_Decl (Create_Identifier ("INSTPTR"), + Info.Block_Decls_Ptr_Type); + end Start_Block_Decl; + + procedure Translate_Entity_Init (Entity : Iir) + is + Info : Block_Info_Acc; + El : Iir; + El_Type : Iir; + begin + Info := Get_Info (Entity); + + Push_Local_Factory; + + -- Generics. + El := Get_Generic_Chain (Entity); + while El /= Null_Iir loop + Chap4.Elab_Object_Value (El, Get_Default_Value (El)); + El := Get_Chain (El); + end loop; + + -- Ports. + El := Get_Port_Chain (Entity); + while El /= Null_Iir loop + El_Type := Get_Type (El); + if Get_Kind (El_Type) + in Iir_Kinds_Unconstrained_Array_Type_Definition + 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); + + El := Get_Chain (El); + end loop; + + Pop_Local_Factory; + end Translate_Entity_Init; + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration) + is + Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Instance : Chap2.Instance_Inters; + begin + Info := Add_Info (Entity, Kind_Block); + Chap1.Start_Block_Decl (Entity); + Push_Instance_Factory (Info.Block_Decls_Type); + + -- 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_Decls_Type); + + Chap2.Push_Subprg_Instance (Info.Block_Decls_Type, + Info.Block_Decls_Ptr_Type, + Wki_Instance); + + -- Entity elaborator. + Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); + + -- Generate RTI. + if Flag_Rti then + Rtis.Generate_Unit (Entity); + end if; + + if Global_Storage /= O_Storage_External then + -- Entity process subprograms. + Chap9.Translate_Block_Subprograms (Entity, Entity); + + -- Elaborator Body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Instance); + -- Set entity name. + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + Chap2.Elab_Dependence (Get_Design_Unit (Entity)); + Chap9.Elab_Block_Declarations (Entity, Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- Default value if any. + if False then --Is_Entity_Declaration_Top (Entity) then + declare + Init_Subprg : O_Dnode; + begin + Start_Procedure_Decl + (Interface_List, Create_Identifier ("_INIT"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Init_Subprg); + + Start_Subprogram_Body (Init_Subprg); + Chap2.Start_Subprg_Instance_Use (Instance); + Translate_Entity_Init (Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Finish_Subprogram_Body; + end; + end if; + end if; + Chap2.Pop_Subprg_Instance (Wki_Instance); + 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 : Block_Info_Acc; + Entity : Iir; + Entity_Info : Block_Info_Acc; + begin + Arch_Info := Get_Info (Arch); + Entity := Get_Entity (Arch); + Entity_Info := Get_Info (Entity); + + Push_Scope (Arch_Info.Block_Decls_Type, Instance); + Push_Scope (Entity_Info.Block_Decls_Type, + Arch_Info.Block_Parent_Field, Arch_Info.Block_Decls_Type); + end Push_Architecture_Scope; + + -- Pop scopes created by Push_Architecture_Scope. + procedure Pop_Architecture_Scope (Arch : Iir) + is + Arch_Info : Block_Info_Acc; + Entity : Iir; + Entity_Info : Block_Info_Acc; + begin + Arch_Info := Get_Info (Arch); + Entity := Get_Entity (Arch); + Entity_Info := Get_Info (Entity); + + Pop_Scope (Entity_Info.Block_Decls_Type); + Pop_Scope (Arch_Info.Block_Decls_Type); + end Pop_Architecture_Scope; + + procedure Translate_Architecture_Declaration (Arch : Iir) + is + Info : Block_Info_Acc; + Entity : Iir; + Entity_Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + Instance : O_Dnode; + Var_Arch_Instance : O_Dnode; + 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_Decls_Type); + + Entity := Get_Entity (Arch); + Entity_Info := Get_Info (Entity); + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Get_Identifier ("ENTITY"), Entity_Info.Block_Decls_Type); + + Chap9.Translate_Block_Declarations (Arch, Arch); + + Pop_Instance_Factory (Info.Block_Decls_Type); + + -- 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, + New_Sizeof (Info.Block_Decls_Type, Ghdl_Index_Type)); + 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; + + Chap2.Push_Subprg_Instance (Info.Block_Decls_Type, + Info.Block_Decls_Ptr_Type, + Wki_Instance); + + -- Create process subprograms. + Push_Scope (Entity_Info.Block_Decls_Type, + Info.Block_Parent_Field, Info.Block_Decls_Type); + Chap9.Translate_Block_Subprograms (Arch, Arch); + Pop_Scope (Entity_Info.Block_Decls_Type); + + Chap2.Pop_Subprg_Instance (Wki_Instance); + + -- Elaborator body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + + ---- Allocate memory for the instance. + --New_Assign_Stmt + -- (Instance, Gen_Alloc (Alloc_Memory, + -- New_Sizeof (Info.Block_Decls_Type, + -- Ghdl_Index_Type), + -- Info.Block_Decls_Ptr_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 elaborator. + 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_Declaration; + + procedure Translate_Component_Configuration_Decl + (Cfg : Iir; + Arch : Iir_Architecture_Declaration; + 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; + + Arch_Info : Block_Info_Acc; + Arch_Param : 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_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); + + Arch_Info := Get_Info (Arch); + + Chap4.Translate_Association_Subprograms + (Get_Port_Map_Aspect_Chain (Binding), Arch, + 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, Arch_Param, Get_Identifier ("ARCH"), + Arch_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; + + Push_Architecture_Scope (Arch, Arch_Param); + Push_Scope (Comp_Info.Comp_Type, 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; + + Pop_Scope (Comp_Info.Comp_Type); + Pop_Architecture_Scope (Arch); + 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. + -- ARCH is the architecture being configured. + -- NUM is an integer used to generate uniq names. + procedure Translate_Block_Configuration_Decls + (Block_Config : Iir_Block_Configuration; + Arch : Iir_Architecture_Declaration; + Num : in out Iir_Int32) + is + El : Iir; + Mark : Id_Mark_Type; + Blk : 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, Arch, Num); + when Iir_Kind_Block_Configuration => + Blk := Get_Block_From_Block_Specification + (Get_Block_Specification (El)); + Push_Identifier_Prefix (Mark, Get_Identifier (Blk)); + Translate_Block_Configuration_Decls (El, Arch, Num); + Pop_Identifier_Prefix (Mark); + 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; + Arch : Iir_Architecture_Declaration; + Block_Info : Block_Info_Acc) + is + Cfg_Info : Config_Info_Acc; + Arch_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); + Arch_Info := Get_Info (Arch); + + -- 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; + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + declare + Assoc : O_Assoc_List; + Info : Block_Info_Acc; + V : O_Lnode; + begin + Info := Get_Info (El); + Start_Association (Assoc, Cfg_Info.Config_Subprg); + V := Get_Instance_Ref (Block_Info.Block_Decls_Type); + V := New_Selected_Element (V, Info.Block_Parent_Field); + New_Association + (Assoc, New_Address (V, Info.Block_Decls_Ptr_Type)); + V := Get_Instance_Ref (Arch_Info.Block_Decls_Type); + New_Association + (Assoc, + New_Address (V, Arch_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; + Arch : Iir_Architecture_Declaration; + Info : Block_Info_Acc); + + procedure Translate_Generate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Arch : Iir_Architecture_Declaration; + Parent_Info : Block_Info_Acc) + is + Spec : Iir; + Block : Iir_Generate_Statement; + Scheme : Iir; + Info : Block_Info_Acc; + + -- 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_Decls_Type), + 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)); + Push_Scope (Info.Block_Decls_Type, Var_Inst); + Push_Scope_Via_Field_Ptr + (Parent_Info.Block_Decls_Type, + Info.Block_Origin_Field, + Info.Block_Decls_Type); + Translate_Block_Configuration_Calls (Block_Config, Arch, Info); + Pop_Scope (Parent_Info.Block_Decls_Type); + Pop_Scope (Info.Block_Decls_Type); + + if Fails then + New_Else_Stmt (If_Blk); + -- Already configured. + Chap6.Gen_Program_Error (Block_Config); + end if; + + Finish_If_Stmt (If_Blk); + Close_Temp; + end Gen_Subblock_Call; + + Type_Info : Type_Info_Acc; + Iter_Type : Iir; + begin + Spec := Get_Block_Specification (Block_Config); + Block := Get_Block_From_Block_Specification (Spec); + Info := Get_Info (Block); + Scheme := Get_Generation_Scheme (Block); + 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_Selected_Name => + -- Apply for all/remaining blocks. + declare + 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)), + Get_Kind (Spec) /= Iir_Kind_Selected_Name); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + end; + when Iir_Kind_Indexed_Name => + declare + Range_Ptr : O_Dnode; + begin + Open_Temp; + Range_Ptr := Create_Temp_Ptr + (Type_Info.T.Range_Ptr_Type, + Get_Var (Get_Info (Iter_Type).T.Range_Var)); + Gen_Subblock_Call + (Chap6.Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression + (Get_Nth_Element (Get_Index_List (Spec), 0), + Iter_Type), + Iter_Type, + Spec), + True); + Close_Temp; + end; + when Iir_Kind_Slice_Name => + declare + Range_Ptr : O_Dnode; + 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; + Range_Ptr := Create_Temp_Ptr + (Type_Info.T.Range_Ptr_Type, + Get_Var (Get_Info (Iter_Type).T.Range_Var)); + 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 + (Range_Ptr, + New_Value (New_Selected_Element + (New_Obj (Slice), Type_Info.T.Range_Left)), + Iter_Type, + Spec)); + Right := Create_Temp_Init + (Ghdl_Index_Type, + Chap6.Translate_Index_To_Offset + (Range_Ptr, + New_Value (New_Selected_Element + (New_Obj (Slice), + Type_Info.T.Range_Right)), + 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, + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Type_Info.T.Range_Dir), + 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_Decls_Type), + 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)); + Push_Scope (Info.Block_Decls_Type, Var); + Push_Scope_Via_Field_Ptr (Parent_Info.Block_Decls_Type, + Info.Block_Origin_Field, + Info.Block_Decls_Type); + Translate_Block_Configuration_Calls (Block_Config, Arch, Info); + Pop_Scope (Parent_Info.Block_Decls_Type); + Pop_Scope (Info.Block_Decls_Type); + 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; + Arch : Iir_Architecture_Declaration; + 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, Arch, Info); + when Iir_Kind_Block_Configuration => + declare + Block : Iir; + Block_Info : Block_Info_Acc; + begin + Block := Get_Block_Specification (El); + if Get_Kind (Block) = Iir_Kind_Block_Statement then + Block_Info := Get_Info (Block); + Push_Scope (Block_Info.Block_Decls_Type, + Block_Info.Block_Parent_Field, + Info.Block_Decls_Type); + Translate_Block_Configuration_Calls + (El, Arch, Block_Info); + Pop_Scope (Block_Info.Block_Decls_Type); + else + Translate_Generate_Block_Configuration_Calls + (El, Arch, 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 + Interface_List : O_Inter_List; + Block_Config : Iir_Block_Configuration; + Arch : Iir_Architecture_Declaration; + Arch_Info : Block_Info_Acc; + 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); + Block_Config := Get_Block_Configuration (Config); + Arch := Get_Block_Specification (Block_Config); + Arch_Info := Get_Info (Arch); + + -- 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, 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 + Chap4.Elab_Declaration_Chain (Config, Final); + if Final then + raise Internal_Error; + end if; + end if; + + Translate_Block_Configuration_Calls (Block_Config, Arch, Arch_Info); + + Pop_Architecture_Scope (Arch); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Configuration_Declaration; + end Chap1; + + package body Chap2 is + procedure Elab_Package (Spec : Iir_Package_Declaration); + + type Name_String_Xlat_Array is array (Name_Id range <>) of + String (1 .. 4); + Operator_String_Xlat : constant + Name_String_Xlat_Array (Std_Names.Name_Id_Operators) := + (Std_Names.Name_Op_Equality => "OPEq", + Std_Names.Name_Op_Inequality => "OPNe", + Std_Names.Name_Op_Less => "OPLt", + Std_Names.Name_Op_Less_Equal => "OPLe", + Std_Names.Name_Op_Greater => "OPGt", + Std_Names.Name_Op_Greater_Equal => "OPGe", + Std_Names.Name_Op_Plus => "OPPl", + Std_Names.Name_Op_Minus => "OPMi", + Std_Names.Name_Op_Mul => "OPMu", + Std_Names.Name_Op_Div => "OPDi", + Std_Names.Name_Op_Exp => "OPEx", + Std_Names.Name_Op_Concatenation => "OPCc"); + + -- 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 + Info : Ortho_Info_Acc; + Mode : Object_Kind_Type; + Tinfo : Type_Info_Acc; + begin + Info := Get_Info (Inter); + if Info.Interface_Field = O_Fnode_Null then + case Get_Kind (Inter) is + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Mode := Mode_Value; + when Iir_Kind_Signal_Interface_Declaration => + Mode := Mode_Signal; + when others => + Error_Kind ("translate_interface_type", Inter); + end case; + Tinfo := Get_Info (Get_Type (Inter)); + 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; + else + return O_Tnode_Null; + end if; + end Translate_Interface_Type; + + procedure Translate_Subprogram_Declaration (Spec : Iir) + is + Inter : Iir; + Inter_Type : Iir; + Inter_Kind : Iir_Kind; + Info : Subprg_Info_Acc; + 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; + Is_Func : Boolean; + Rtype : Iir; + Id : O_Ident; + Storage : O_Storage; + begin + Info := Get_Info (Spec); + Info.Res_Interface := O_Dnode_Null; + Is_Func := Get_Kind (Spec) = Iir_Kind_Function_Declaration; + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + if Get_Foreign_Flag (Spec) then + declare + Fi : Foreign_Info_Type; + begin + Fi := Translate_Foreign_Id (Spec, True); + case Fi.Kind is + when Foreign_Unknown => + Id := Create_Identifier; + when Foreign_Intrinsic => + Id := Fi.Subprg; + when Foreign_Vhpidirect => + Id := Fi.Subprg; + end case; + Storage := O_Storage_External; + end; + 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 Get_Kind (Rtype) + in Iir_Kinds_Unconstrained_Array_Type_Definition + then + Info.Use_Stack2 := True; + end if; + else + Start_Function_Decl + (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value)); + 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); + Inter_Kind := Get_Kind (Inter_Type); + Tinfo := Get_Info (Inter_Type); + if Get_Kind (Inter) = Iir_Kind_Variable_Interface_Declaration + and then Get_Mode (Inter) in Iir_Out_Modes + and then Tinfo.Type_Mode not in Type_Mode_By_Ref + then + -- This interface is done via the result record. + 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. + Tinfo := Get_Info (Inter_Type); + 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); + end if; + + Start_Procedure_Decl (Interface_List, Id, Storage); + + if Has_Result_Record then + -- Add the record parameter. + New_Interface_Decl (Interface_List, Info.Res_Interface, + Get_Identifier ("RESULT"), + Info.Res_Record_Ptr); + end if; + end if; + + -- Instance parameter if any. + if not Get_Foreign_Flag (Spec) then + Chap2.Create_Subprg_Instance (Interface_List, Spec); + end if; + + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Is_Func then + Arg_Info := Add_Info (Inter, Kind_Interface); + Arg_Info.Interface_Field := O_Fnode_Null; + else + Arg_Info := Get_Info (Inter); + end if; + + Arg_Info.Interface_Type := Translate_Interface_Type (Inter); + if Arg_Info.Interface_Type /= O_Tnode_Null then + New_Interface_Decl + (Interface_List, Arg_Info.Interface_Node, + Create_Identifier_Without_Prefix (Inter), + Arg_Info.Interface_Type); + else + -- Parameter is passed by the result record. + Arg_Info.Interface_Node := Info.Res_Interface; + end if; + Inter := Get_Chain (Inter); + end loop; + Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); + + 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; + + procedure Translate_Subprogram_Body (Subprg : Iir) + is + Spec : Iir; + Func_Decl : O_Dnode; + Info : Ortho_Info_Acc; + Old_Subprogram : Iir; + Mark : Id_Mark_Type; + Final : Boolean; + Is_Func : Boolean; + + -- Set for a public method. In this case, the lock must be acquired + -- and retained. + Is_Prot : Boolean := False; + + Subprg_Instances : Chap2.Subprg_Instance_Stack; + begin + Spec := Get_Subprogram_Specification (Subprg); + Info := Get_Info (Spec); + Func_Decl := Info.Ortho_Func; + + -- Do not translate body for foreign subprograms. + if Get_Foreign_Flag (Spec) then + return; + 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); + + Start_Subprogram_Body (Func_Decl); + + Start_Subprg_Instance_Use (Spec); + + Push_Local_Factory; + Chap2.Save_Subprg_Instance (Subprg_Instances); + + Chap4.Translate_Declaration_Chain (Subprg); + Chap4.Translate_Declaration_Chain_Subprograms (Subprg, Null_Iir); + + 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_Func := Is_Subprogram_Ortho_Function (Spec); + if Is_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; + Chap8.Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Subprg)); + Current_Subprogram := Old_Subprogram; + + if Final or Is_Prot then + -- FIXME: create a barrier to catch missing return statement. + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + New_Exit_Stmt (Info.Subprg_Exit); + 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_Func then + New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); + end if; + end if; + + Chap2.Restore_Subprg_Instance (Subprg_Instances); + Pop_Local_Factory; + + Finish_Subprg_Instance_Use (Spec); + + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Body; + +-- procedure Translate_Protected_Subprogram_Declaration +-- (Def : Iir_Protected_Type_Declaration; Spec : Iir; Block : Iir) +-- is +-- Interface_List : O_Inter_List; +-- Info : Subprg_Info_Acc; +-- Tinfo : Type_Info_Acc; +-- Inter : Iir; +-- Inter_Info : Inter_Info_Acc; +-- Prot_Subprg : O_Dnode; +-- Prot_Obj : O_Lnode; +-- Mark : Id_Mark_Type; +-- Constr : O_Assoc_List; +-- Inst_Data : Instance_Data; +-- Is_Func : Boolean; +-- Var_Res : O_Lnode; +-- begin +-- Chap2.Translate_Subprogram_Declaration (Spec, Block); + +-- -- Create protected subprogram +-- Info := Get_Info (Spec); +-- Push_Subprg_Identifier (Spec, Info, Mark); + +-- Is_Func := Is_Subprogram_Ortho_Function (Spec); + +-- if Is_Func then +-- Tinfo := Get_Info (Get_Return_Type (Spec)); +-- Start_Function_Decl (Interface_List, +-- Create_Identifier ("PROT"), +-- Global_Storage, +-- Tinfo.Ortho_Type (Mode_Value)); +-- else +-- Start_Procedure_Decl (Interface_List, +-- Create_Identifier ("PROT"), +-- Global_Storage); +-- end if; +-- Chap2.Create_Subprg_Instance (Interface_List, Inst_Data, Block); + +-- -- FIXME: RES record interface. + +-- New_Interface_Decl +-- (Interface_List, +-- Prot_Obj, +-- Get_Identifier ("OBJ"), +-- Get_Info (Def).Ortho_Ptr_Type (Mode_Value)); + +-- Inter := Get_Interface_Declaration_Chain (Spec); +-- while Inter /= Null_Iir loop +-- Inter_Info := Get_Info (Inter); +-- if Inter_Info.Interface_Type /= O_Tnode_Null then +-- New_Interface_Decl +-- (Interface_List, Inter_Info.Interface_Protected, +-- Create_Identifier_Without_Prefix (Inter), +-- Inter_Info.Interface_Type); +-- end if; +-- Inter := Get_Chain (Inter); +-- end loop; +-- Finish_Subprogram_Decl (Interface_List, Prot_Subprg); + +-- if Global_Storage /= O_Storage_External then +-- -- Body of the protected subprogram. +-- Start_Subprogram_Body (Prot_Subprg); +-- Start_Subprg_Instance_Use (Inst_Data); + +-- if Is_Func then +-- New_Var_Decl (Var_Res, Wki_Res, O_Storage_Local, +-- Tinfo.Ortho_Type (Mode_Value)); +-- end if; + +-- -- Lock the object. +-- Start_Association (Constr, Ghdl_Protected_Enter); +-- New_Association +-- (Constr, New_Convert_Ov (New_Value (Prot_Obj), Ghdl_Ptr_Type)); +-- New_Procedure_Call (Constr); + +-- -- Call the unprotected method +-- Start_Association (Constr, Info.Ortho_Func); +-- Add_Subprg_Instance_Assoc (Constr, Inst_Data); +-- New_Association (Constr, New_Value (Prot_Obj)); +-- Inter := Get_Interface_Declaration_Chain (Spec); +-- while Inter /= Null_Iir loop +-- Inter_Info := Get_Info (Inter); +-- if Inter_Info.Interface_Type /= O_Tnode_Null then +-- New_Association +-- (Constr, New_Value (Inter_Info.Interface_Protected)); +-- end if; +-- Inter := Get_Chain (Inter); +-- end loop; +-- if Is_Func then +-- New_Assign_Stmt (Var_Res, New_Function_Call (Constr)); +-- else +-- New_Procedure_Call (Constr); +-- end if; + +-- -- Unlock the object. +-- Start_Association (Constr, Ghdl_Protected_Leave); +-- New_Association +-- (Constr, New_Convert_Ov (New_Value (Prot_Obj), Ghdl_Ptr_Type)); +-- New_Procedure_Call (Constr); + +-- if Is_Func then +-- New_Return_Stmt (New_Value (Var_Res)); +-- end if; +-- Finish_Subprg_Instance_Use (Inst_Data); +-- Finish_Subprogram_Body; +-- end if; + +-- Pop_Identifier_Prefix (Mark); +-- end Translate_Protected_Subprogram_Declaration; + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) + is + Info : Ortho_Info_Acc; + I_List : O_Inter_List; + --Storage : O_Storage; + begin + Chap4.Translate_Declaration_Chain (Decl); + Chap4.Translate_Declaration_Chain_Subprograms (Decl, Null_Iir); + +-- if Chap10.Global_Storage = O_Storage_Public +-- and then not Get_Need_Body (Decl) +-- then +-- Storage := O_Storage_Public; +-- else +-- Storage := O_Storage_External; +-- end if; + + Info := Add_Info (Decl, Kind_Package); + + Start_Procedure_Decl + (I_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); + Finish_Subprogram_Decl (I_List, Info.Package_Elab_Spec_Subprg); + + Start_Procedure_Decl + (I_List, Create_Identifier ("ELAB_BODY"), Global_Storage); + Finish_Subprogram_Decl (I_List, Info.Package_Elab_Body_Subprg); + + New_Var_Decl (Info.Package_Elab_Var, Create_Identifier ("ELABORATED"), + Chap10.Global_Storage, Ghdl_Bool_Type); + + if Flag_Rti then + Rtis.Generate_Unit (Decl); + end if; + + if Global_Storage = O_Storage_Public then + -- Generate RTI. + Elab_Package (Decl); + end if; + Save_Local_Identifier (Info.Package_Local_Id); + end Translate_Package_Declaration; + + procedure Translate_Package_Body (Decl : Iir_Package_Body) + is + Pkg : Iir_Package_Declaration; + begin + -- May be called during elaboration to generate RTI. + if Global_Storage = O_Storage_External then + return; + end if; + + if Flag_Rti then + Rtis.Generate_Unit (Decl); + end if; + + Pkg := Get_Package (Decl); + Restore_Local_Identifier (Get_Info (Pkg).Package_Local_Id); + Chap4.Translate_Declaration_Chain (Decl); + Chap4.Translate_Declaration_Chain_Subprograms (Decl, Null_Iir); + Elab_Package_Body (Pkg, Decl); + end Translate_Package_Body; + + procedure Elab_Package (Spec : Iir_Package_Declaration) + is + Info : Ortho_Info_Acc; + Final : Boolean; + begin + Info := Get_Info (Spec); + Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); + Push_Local_Factory; + + Elab_Dependence (Get_Design_Unit (Spec)); + Chap4.Elab_Declaration_Chain (Spec, Final); + + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package; + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) + is + Info : Ortho_Info_Acc; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + Final : Boolean; + begin + Info := Get_Info (Spec); + Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); + Push_Local_Factory; + + -- If the package was already elaborated, return now, + -- else mark the package as elaborated. + Start_If_Stmt (If_Blk, New_Obj_Value (Info.Package_Elab_Var)); + New_Return_Stmt; + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (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); + New_Procedure_Call (Constr); + + if Bod /= Null_Iir then + Elab_Dependence (Get_Design_Unit (Bod)); + Chap4.Elab_Declaration_Chain (Bod, Final); + end if; + + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package_Body; + + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) + is + Depend_List: Iir_Design_Unit_List; + Design: Iir; + Library_Unit: Iir; + Info : Ortho_Info_Acc; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + 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 => + if Library_Unit /= Standard_Package then + Info := Get_Info (Library_Unit); + Start_If_Stmt + (If_Blk, New_Monadic_Op + (ON_Not, New_Obj_Value (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 if; + when Iir_Kind_Entity_Declaration => + -- FIXME: architecture already elaborates its entity. + null; + when Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_Architecture_Declaration => + null; + when others => + Error_Kind ("elab_dependence", Library_Unit); + end case; + end if; + end loop; + end Elab_Dependence; + + procedure Push_Subprg_Instance (Decl_Type : O_Tnode; + Ptr_Type : O_Tnode; + Ident : O_Ident) + is + El : Subprg_Instance_Stack; + begin + if Subprg_Instance_Unused /= null then + El := Subprg_Instance_Unused; + Subprg_Instance_Unused := El.Next; + else + El := new Subprg_Instance_Type; + end if; + El.all := (Decl_Type => Decl_Type, + Ptr_Type => Ptr_Type, + Ident => Ident, + Next => null, + Prev => Subprg_Instance_Last); + if Subprg_Instance_First = null then + Subprg_Instance_First := El; + else + Subprg_Instance_Last.Next := El; + end if; + Subprg_Instance_Last := El; + end Push_Subprg_Instance; + + procedure Pop_Subprg_Instance (Ident : O_Ident) + is + El : Subprg_Instance_Stack; + begin + El := Subprg_Instance_Last; + if El = null or else not Is_Equal (El.Ident, Ident) then + -- POP does not match with a push. + raise Internal_Error; + end if; + Subprg_Instance_Last := El.Prev; + if El.Prev = null then + Subprg_Instance_First := null; + else + El.Prev.Next := null; + end if; + El.Next := Subprg_Instance_Unused; + Subprg_Instance_Unused := El; + end Pop_Subprg_Instance; + + procedure Save_Subprg_Instance (Stack : out Subprg_Instance_Stack) + is + begin + Stack := Subprg_Instance_First; + if Stack /= null then + if Stack.Prev /= null then + raise Internal_Error; + end if; + Stack.Prev := Subprg_Instance_Last; + end if; + Subprg_Instance_First := null; + Subprg_Instance_Last := null; + end Save_Subprg_Instance; + + procedure Restore_Subprg_Instance (Stack : Subprg_Instance_Stack) + is + begin + if Subprg_Instance_First /= null then + -- Not matching with a save. + raise Internal_Error; + end if; + Subprg_Instance_First := Stack; + if Stack /= null then + Subprg_Instance_Last := Stack.Prev; + Stack.Prev := null; + end if; + end Restore_Subprg_Instance; + + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Array) + is + El : Subprg_Instance_Stack; + I : Natural; + begin + El := Subprg_Instance_First; + I := Vars'First; + while El /= null loop + Vars (I).Inst_Type := El.Decl_Type; + Vars (I).Inter_Type := El.Ptr_Type; + New_Interface_Decl + (Interfaces, Vars (I).Inter, El.Ident, El.Ptr_Type); + I := I + 1; + El := El.Next; + end loop; + Vars (I .. Vars'Last) := (others => Null_Subprg_Instance_El); + end Add_Subprg_Instance_Interfaces; + + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Array) + is + Val : O_Enode; + begin + for I in Vars'Range loop + exit when Vars (I).Inter = O_Dnode_Null; + Val := New_Address (Get_Instance_Ref (Vars (I).Inst_Type), + Vars (I).Inter_Type); + New_Association (Assocs, Val); + end loop; + end Add_Subprg_Instance_Assoc; + + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; + Vars : Subprg_Instance_Array; + Inst1_Type : O_Tnode; + Inst1_Val : O_Enode) + is + Val : O_Enode; + begin + for I in Vars'Range loop + exit when Vars (I).Inter = O_Dnode_Null; + if Vars (I).Inst_Type = Inst1_Type then + Val := Inst1_Val; + else + Val := New_Address (Get_Instance_Ref (Vars (I).Inst_Type), + Vars (I).Inter_Type); + end if; + New_Association (Assocs, Val); + end loop; + end Add_Subprg_Instance_Assoc; + + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Array) + is + begin + for I in Vars'Range loop + exit when Vars (I).Inter = O_Dnode_Null; + Push_Scope (Vars (I).Inst_Type, Vars (I).Inter); + end loop; + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Array) + is + begin + for I in reverse Vars'Range loop + if Vars (I).Inter /= O_Dnode_Null then + Pop_Scope (Vars (I).Inst_Type); + end if; + end loop; + end Finish_Subprg_Instance_Use; + + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir) + is + begin + Add_Subprg_Instance_Interfaces + (Interfaces, Get_Info (Subprg).Subprg_Instance); + end Create_Subprg_Instance; + + procedure Start_Subprg_Instance_Use (Subprg : Iir) is + begin + Start_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Subprg : Iir) is + begin + Finish_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Finish_Subprg_Instance_Use; + 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); + + -- 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 : Type_Info_Acc; + begin + Info := Get_Info (Def); + Info.C := new Complex_Type_Info; + Info.C.Size_Var (Mode_Value) := Create_Var + (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); + if Get_Signal_Type_Flag (Def) then + Info.C.Size_Var (Mode_Signal) := 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; + Start_Function_Decl + (Interface_List, Ident, Global_Storage, Char_Ptr_Type); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.C.Builder_Instance (Kind)); + 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.Builder_Base_Param (Kind), + Get_Identifier ("base_ptr"), Ptype); + -- Add parameter for array bounds. + if Info.Type_Mode in Type_Mode_Arrays then + New_Interface_Decl + (Interface_List, Info.C.Builder_Bound_Param (Kind), + Get_Identifier ("bound"), Info.T.Bounds_Ptr_Type); + end if; + Finish_Subprogram_Decl (Interface_List, Info.C.Builder_Func (Kind)); + 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 : Type_Info_Acc; + Binfo : Type_Info_Acc; + Assoc : O_Assoc_List; + begin + Tinfo := Get_Info (Var_Type); + -- Build the field + Binfo := Get_Info (Get_Base_Type (Var_Type)); + Start_Association (Assoc, Binfo.C.Builder_Func (Kind)); + Chap2.Add_Subprg_Instance_Assoc + (Assoc, Binfo.C.Builder_Instance (Kind)); + case Tinfo.Type_Mode is + when Type_Mode_Record + | Type_Mode_Array => + New_Association (Assoc, New_Obj_Value (Var_Ptr)); + when Type_Mode_Ptr_Array => + --New_Association (Assoc, New_Value (New_Acc_Value (Var_Ptr))); + 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; + case Tinfo.Type_Mode is + when Type_Mode_Array + | Type_Mode_Ptr_Array => + New_Association + (Assoc, + Get_Array_Bounds_Ptr (O_Lnode_Null, Var_Type, Kind)); + when Type_Mode_Fat_Array => + New_Association + (Assoc, Get_Array_Ptr_Bounds_Ptr (New_Obj (Var_Ptr), + Var_Type, Kind)); + when Type_Mode_Record => + null; + when others => + raise Internal_Error; + end case; + 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 (Char_Ptr_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; + + procedure Builder_Update_Field + (Field_Type : Iir; Mem : O_Dnode; Kind : Object_Kind_Type) + is + Tinfo : Type_Info_Acc; + Var_Ptr : O_Dnode; + begin + Tinfo := Get_Info (Field_Type); + if Tinfo.C /= null then + if Tinfo.C.Builder_Need_Func then + -- This is a complex type. + Start_Declare_Stmt; + New_Var_Decl (Var_Ptr, Get_Identifier ("var_ptr"), + O_Storage_Local, Tinfo.Ortho_Ptr_Type (Kind)); + + -- Allocate memory. + -- Set the field with mem. + -- FIXME: alignment ??? + New_Assign_Stmt + (New_Obj (Var_Ptr), + New_Convert_Ov (New_Obj_Value (Mem), + Tinfo.Ortho_Ptr_Type (Kind))); + New_Assign_Stmt (Get_Field_Lnode, New_Obj_Value (Var_Ptr)); + + -- Build second/third-order complex type. + New_Assign_Stmt + (New_Obj (Mem), + Gen_Call_Type_Builder (Var_Ptr, Field_Type, Kind)); + + Finish_Declare_Stmt; + else + -- Allocate memory. + New_Assign_Stmt (Get_Field_Lnode, + New_Convert_Ov (New_Obj_Value (Mem), + Tinfo.Ortho_Ptr_Type (Kind))); + -- Allocate memory for first order complex type. + New_Assign_Stmt + (New_Obj (Mem), + New_Address + (New_Slice (New_Acc_Value (New_Obj (Mem)), + Chararray_Type, + New_Value (Get_Var (Tinfo.C.Size_Var (Kind)))), + Char_Ptr_Type)); + end if; + end if; + end Builder_Update_Field; + + ------------------ + -- 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_B2; + 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 + Unit : Iir; + Info : Object_Info_Acc; + Phy_Type : O_Tnode; + begin + Phy_Type := Get_Ortho_Type (Def, Mode_Value); + 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 + | Iir_Kind_Unconstrained_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; + begin + Res := 2; + El := Get_Element_Declaration_Chain (Get_Base_Type (Def)); + while El /= Null_Iir loop + Res := Res + Get_File_Signature_Length (Get_Type (El)); + El := Get_Chain (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 + | Iir_Kind_Unconstrained_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; + begin + Res (Off) := '<'; + Off := Off + 1; + El := Get_Element_Declaration_Chain (Get_Base_Type (Def)); + while El /= Null_Iir loop + Get_File_Signature (Get_Type (El), Res, Off); + El := Get_Chain (El); + 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 : Iir; + Info : Type_Info_Acc; + begin + Type_Name := Get_Type_Mark (Def); + if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition then + return; + end if; + declare + Len : Natural := Get_File_Signature_Length (Type_Name); + Sig : String (1 .. Len + 2); + Off : Natural := 1; + 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_Signal_Type_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; + + procedure Translate_Array_Type_Bounds + (Def : Iir_Array_Type_Definition; + Info : Type_Info_Acc; + Complete : Boolean) + is + Constr : O_Element_List; + Dim : String (1 .. 8); + N : Natural; + P : Natural; + Index_List : Iir_List; + Index : Iir; + Mark : Id_Mark_Type; + begin + Start_Record_Type (Constr); + Index_List := Get_Index_Subtype_List (Def); + Info.T.Bounds_Vector := + new O_Fnode_Arr (1 .. Get_Nbr_Elements (Index_List)); + for I in Natural loop + Index := Get_Nth_Element (Index_List, I); + exit when Index = Null_Iir; + if Get_Info (Index) = null then + Push_Identifier_Prefix (Mark, "DIM", Iir_Int32 (I + 1)); + Translate_Type_Definition (Index, True); + Pop_Identifier_Prefix (Mark); + end if; + 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, Info.T.Bounds_Vector (I + 1), + 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); + 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 (Chap4.Get_Element_Type (El_Tinfo, 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 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 : Iir_List; + 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 + Indexes := Get_Index_Subtype_List (Def); + if Get_Nbr_Elements (Indexes) /= 1 then + return; + end if; + Index_Type := Get_First_Element (Indexes); + 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, New_Unsigned_Literal (Ghdl_Index_Type, 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_Array_Type (Def : Iir_Array_Type_Definition) + is + Info : Type_Info_Acc; + El_Tinfo : Type_Info_Acc; + -- If true, INFO was already partially filled, by a previous access + -- type definition to this incomplete array type. + Completion : Boolean; + begin + Info := Get_Info (Def); + Completion := Info.Type_Mode = Type_Mode_Fat_Array; + 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_Signal_Type_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 El_Tinfo.C /= null then + -- This is a complex type. + Info.C := new Complex_Type_Info; + -- No size variable for unconstrained array type. + Info.C.Size_Var (Mode_Value) := null; + Info.C.Size_Var (Mode_Signal) := null; + Info.C.Builder_Need_Func := True; + end if; + Info.Type_Incomplete := False; + end Translate_Array_Type; + + -- 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 + Index_List : Iir_List; + Index : Iir; + Len : Iir_Int64; + begin + Index_List := Get_Index_Subtype_List (Def); + -- Check if the bounds of the array are locally static. + Len := 1; + for I in Natural loop + Index := Get_Nth_Element (Index_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 (Def : Iir_Array_Subtype_Definition) + is + Info : Type_Info_Acc; + Binfo : Type_Info_Acc; + Len : Iir_Int64; + Ptr : O_Tnode; + Id : O_Ident; + begin + Info := Get_Info (Def); + Binfo := Get_Info (Get_Base_Type (Def)); + Len := Get_Array_Subtype_Length (Def); + if Len < 0 then + -- Length of the array is not known at compile time. + Info.Type_Mode := Type_Mode_Ptr_Array; + Info.Ortho_Type := Binfo.T.Base_Ptr_Type; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + else + -- Length is known. Create a constrained array. + Info.Type_Mode := Type_Mode_Array; + 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)); + --Ptr := New_Access_Type (Info.Ortho_Type); + --New_Type_Decl (Create_Identifier (Name, "_ARGT"), Ptr); + Ptr := Binfo.T.Base_Ptr_Type (I); + Info.Ortho_Ptr_Type (I) := Ptr; + end loop; + end if; + + -- Create a size variable if the length is not known or if + -- the element size is not known at compile-time. + if Binfo.C /= null then + -- The base type is a complex type, so is the type. + Create_Size_Var (Def); + Info.C.Builder_Need_Func := True; + elsif Len < 0 then + -- This may creates complex types. + Create_Size_Var (Def); + Info.C.Builder_Need_Func := False; + end if; + end Translate_Array_Subtype; + + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode + is + Index_List : Iir_List; + Index : Iir; + List : O_Record_Aggr_List; + Res : O_Cnode; + Baseinfo : Type_Info_Acc; + begin + Index_List := Get_Index_Subtype_List (Def); + Baseinfo := Get_Info (Get_Base_Type (Def)); + Start_Record_Aggr (List, Baseinfo.T.Bounds_Type); + for I in Natural loop + Index := Get_Nth_Element (Index_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 + Index_List : Iir_List; + Index : Iir; + Baseinfo : Type_Info_Acc; + Targ : Mnode; + begin + Baseinfo := Get_Info (Get_Base_Type (Def)); + Targ := Lv2M (Target, True, + Baseinfo.T.Bounds_Type, + Baseinfo.T.Bounds_Ptr_Type, + null, Mode_Value); + Index_List := Get_Index_Subtype_List (Def); + Open_Temp; + if Get_Nbr_Elements (Index_List) > 1 then + Targ := Stabilize (Targ); + end if; + for I in Natural loop + Index := Get_Nth_Element (Index_List, I); + exit when Index = Null_Iir; + declare + Index_Type : Iir; + Index_Info : Type_Info_Acc; + D : O_Dnode; + begin + Index_Type := Get_Base_Type (Index); + Index_Info := Get_Info (Index_Type); + Open_Temp; + D := Create_Temp_Ptr + (Index_Info.T.Range_Ptr_Type, + New_Selected_Element (M2Lv (Targ), + Baseinfo.T.Bounds_Vector (I + 1))); + 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 : Iir_List; + El : Iir; + begin + List := Get_Index_Subtype_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Type_Staticness (El) /= 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 : Type_Info_Acc; + Base_Info : Type_Info_Acc; + Val : O_Cnode; + begin + Info := Get_Info (Def); + if Info.T.Array_Bounds /= null 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 + Base : O_Dnode; + Var_I : O_Dnode; + + function Get_Field_Lnode return O_Lnode is + begin + return New_Indexed_Element (New_Acc_Value (New_Obj (Base)), + New_Obj_Value (Var_I)); + end Get_Field_Lnode; + + procedure Update_Field is new Builder_Update_Field (Get_Field_Lnode); + + Mem : O_Dnode; + Info : Type_Info_Acc; + El_Info : Type_Info_Acc; + Var_Length : O_Dnode; + Label : O_Snode; + begin + Info := Get_Info (Def); + Start_Subprogram_Body (Info.C.Builder_Func (Kind)); + Chap2.Start_Subprg_Instance_Use (Info.C.Builder_Instance (Kind)); + + -- Aliased + Base := Info.C.Builder_Base_Param (Kind); + + -- Compute length of the array. + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Mem, Get_Identifier ("mem"), O_Storage_Local, + Char_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Length), + Chap3.Get_Bounds_Ptr_Length (Info.C.Builder_Bound_Param (Kind), + Def)); + + -- Reserve the size of the array vector. + El_Info := Get_Info (Get_Element_Subtype (Def)); + New_Assign_Stmt + (New_Obj (Mem), + New_Address + (New_Slice + (New_Access_Element + (New_Convert_Ov (New_Obj_Value (Base), Char_Ptr_Type)), + Chararray_Type, + New_Dyadic_Op (ON_Mul_Ov, + New_Obj_Value (Var_Length), + New_Lit (New_Sizeof + (El_Info.Ortho_Ptr_Type (Kind), + Ghdl_Index_Type)))), + Char_Ptr_Type)); + + -- Set each index of the array. + 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_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Update_Field (Get_Element_Subtype (Def), Mem, Kind); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + + New_Return_Stmt (New_Obj_Value (Mem)); + + Chap2.Finish_Subprg_Instance_Use (Info.C.Builder_Instance (Kind)); + Finish_Subprogram_Body; + end Create_Array_Type_Builder; + + -------------- + -- record -- + -------------- + procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) + is + El_List : O_Element_List; + El : Iir_Element_Declaration; + Info : Type_Info_Acc; + Field_Info : Ortho_Info_Acc; + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + + -- 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; + El := Get_Element_Declaration_Chain (Def); + while El /= Null_Iir loop + 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 Get_Info (El_Type).C /= null then + Need_Size := True; + end if; + Field_Info := Add_Info (El, Kind_Field); + El := Get_Chain (El); + end loop; + + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Start_Record_Type (El_List); + El := Get_Element_Declaration_Chain (Def); + while El /= Null_Iir loop + Field_Info := Get_Info (El); + El_Tinfo := Get_Info (Get_Type (El)); + New_Record_Field (El_List, Field_Info.Field_Node (Kind), + Create_Identifier_Without_Prefix (El), + Chap4.Get_Element_Type (El_Tinfo, Kind)); + El := Get_Chain (El); + end loop; + Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); + end loop; + if Get_Signal_Type_Flag (Def) = False then + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + end if; + Info.Type_Mode := Type_Mode_Record; + Finish_Type_Definition (Info); + + if Need_Size then + Create_Size_Var (Def); + Info.C.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 + Base : O_Dnode; + El : Iir_Element_Declaration; + + function Get_Field_Lnode + return O_Lnode + is + begin + return New_Selected_Element (New_Acc_Value (New_Obj (Base)), + Get_Info (El).Field_Node (Kind)); + end Get_Field_Lnode; + + procedure Update_Field is new + Builder_Update_Field (Get_Field_Lnode); + + Info : Type_Info_Acc; + Mem : O_Dnode; + El_Type : Iir; + begin + Info := Get_Info (Def); + Start_Subprogram_Body (Info.C.Builder_Func (Kind)); + Chap2.Start_Subprg_Instance_Use (Info.C.Builder_Instance (Kind)); + + -- Aliases. + Base := Info.C.Builder_Base_Param (Kind); + + New_Var_Decl (Mem, Get_Identifier ("mem"), O_Storage_Local, + Char_Ptr_Type); + + -- Reserve memory for the record, ie: + -- MEM = BASE + SIZEOF (record). + New_Assign_Stmt + (New_Obj (Mem), + New_Address + (New_Slice (New_Access_Element + (New_Convert_Ov (New_Obj_Value (Base), Char_Ptr_Type)), + Chararray_Type, + New_Lit (New_Sizeof (Info.Ortho_Type (Kind), + Ghdl_Index_Type))), + Char_Ptr_Type)); + + -- Set memory for each complex element. + El := Get_Element_Declaration_Chain (Def); + while El /= Null_Iir loop + El_Type := Get_Type (El); + if Get_Info (El_Type).C /= null then + -- Complex type. + Update_Field (El_Type, Mem, Kind); + end if; + El := Get_Chain (El); + end loop; + Chap2.Finish_Subprg_Instance_Use (Info.C.Builder_Instance (Kind)); + New_Return_Stmt (New_Obj_Value (Mem)); + Finish_Subprogram_Body; + end Create_Record_Type_Builder; + + -------------- + -- Access -- + -------------- + procedure Translate_Access_Type (Def : Iir_Access_Type_Definition) + is + D_Type : Iir; + D_Info : Ortho_Info_Acc; + Dtype : O_Tnode; + Def_Info : Type_Info_Acc; + Arr_Info : Type_Info_Acc; + begin + D_Type := Get_Designated_Type (Def); + D_Info := Get_Info (D_Type); + Def_Info := Get_Info (Def); + + if Get_Kind (D_Type) in Iir_Kinds_Unconstrained_Array_Type_Definition + 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; + if D_Info.Kind = Kind_Incomplete_Type then + Dtype := O_Tnode_Null; + elsif D_Info.Type_Mode in Type_Mode_Arrays then + -- The designated type cannot be a sub array inside ortho. + 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); + Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + 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; + return; +-- Info := Get_Info (Def); +-- Ftype := Get_Type (Get_Type_Declarator (Def)); +-- case Get_Kind (Ftype) is +-- when Iir_Kind_Record_Type_Definition => +-- Info.Type_Mode := Type_Mode_Unknown; +-- for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop +-- New_Uncomplete_Record_Type (Info.Ortho_Type (I)); +-- end loop; +-- when others => +-- Error_Kind ("translate_incomplete_type", Ftype); +-- end case; +-- Set_Info (Ftype, Info); +-- Finish_Type_Definition (Info, Incomplete_Type); + 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 : Type_Info_Acc; + begin + Info := Get_Info (Def); + + 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; + + Info.C := new Complex_Type_Info; + Info.C.Size_Var (Mode_Value) := Create_Global_Const + (Create_Identifier ("SIZE"), Ghdl_Index_Type, + O_Storage_External, O_Cnode_Null); + Info.C.Builder_Need_Func := False; + + -- This is just use to set overload number on subprograms, and to + -- translate interfaces. + Chap4.Translate_Declaration_Chain (Def); + end Translate_Protected_Type; + + procedure Translate_Protected_Type_Subprograms + (Def : Iir_Protected_Type_Declaration) + is + El : Iir; + Info : Type_Info_Acc; + Inter_List : O_Inter_List; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix + (Mark, Get_Identifier (Get_Type_Declarator (Def))); + + Info := Get_Info (Def); + + Chap2.Push_Subprg_Instance (Info.Ortho_Type (Mode_Value), + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj); + + -- Init. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("INIT"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Init_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Node); + + -- Final. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("FINI"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Final_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Final_Node); + + -- 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 => + Chap2.Translate_Subprogram_Declaration (El); + when others => + Error_Kind ("translate_protected_type_subprograms", El); + end case; + El := Get_Chain (El); + end loop; + + Chap2.Pop_Subprg_Instance (Wki_Obj); + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Subprograms; + + procedure Translate_Protected_Type_Body (Bod : Iir) + is + Decl : Iir_Protected_Type_Declaration; + Mark : Id_Mark_Type; + Info : Type_Info_Acc; + Lock_Field : O_Fnode; + begin + Decl := Get_Protected_Type_Declaration (Bod); + Info := Get_Info (Decl); + + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + Push_Instance_Factory (Info.Ortho_Type (Mode_Value)); + Lock_Field := Add_Instance_Factory_Field + (Get_Identifier ("LOCK"), Ghdl_Ptr_Type); + + -- Translate declarations. + Chap4.Translate_Declaration_Chain (Bod); + + Pop_Instance_Factory (Info.Ortho_Type (Mode_Value)); + if Global_Storage /= O_Storage_External then + Info.C.Size_Var (Mode_Value) := Create_Global_Const + (Create_Identifier ("SIZE"), Ghdl_Index_Type, + Global_Storage, New_Sizeof (Info.Ortho_Type (Mode_Value), + Ghdl_Index_Type)); + end if; + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Body; + + procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode) + is + Assoc : O_Assoc_List; + Info : Type_Info_Acc; + begin + Info := Get_Info (Type_Def); + Start_Association (Assoc, Proc); + New_Association + (Assoc, + New_Unchecked_Address + (Get_Instance_Ref (Info.Ortho_Type (Mode_Value)), Ghdl_Ptr_Type)); + New_Procedure_Call (Assoc); + end Call_Ghdl_Protected_Procedure; + + procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir) + is + Decl : Iir; + Info : Type_Info_Acc; + Final : Boolean; + begin + Decl := Get_Protected_Type_Declaration (Bod); + Info := Get_Info (Decl); + + -- Subprograms of BOD. + Chap2.Push_Subprg_Instance (Info.Ortho_Type (Mode_Value), + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj); + + Chap4.Translate_Declaration_Chain_Subprograms (Bod, Null_Iir); + + Chap2.Pop_Subprg_Instance (Wki_Obj); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Init + Start_Subprogram_Body (Info.T.Prot_Init_Node); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + + -- Create lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init); + + -- Elaborate fields. + Chap4.Elab_Declaration_Chain (Bod, Final); + + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + Finish_Subprogram_Body; + + + -- Fini + Start_Subprogram_Body (Info.T.Prot_Final_Node); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + + -- Deallocate fields. + if Final or True then + Chap4.Final_Declaration_Chain (Bod, True); + end if; + + -- Destroy lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini); + + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + Finish_Subprogram_Body; + + end 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_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_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_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Target := Get_Var (Get_Info (Def).T.Range_Var); + Create_Scalar_Type_Range (Def, Target); + + when Iir_Kind_Array_Subtype_Definition => + 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; + + when Iir_Kind_Array_Type_Definition => + -- FIXME: create unidimensional array bound of length 1 + return; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Unconstrained_Array_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; + + function Get_Additionnal_Size (Def : Iir; Kind : Object_Kind_Type) + return O_Enode + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + + if Info.C = null then + -- Short-cut. + return O_Enode_Null; + else + return New_Value (Get_Var (Info.C.Size_Var (Kind))); + end if; + end Get_Additionnal_Size; + + procedure Create_Type_Definition_Size_Var (Def : Iir) + is + Info : Type_Info_Acc; + Res : O_Enode; + V : O_Cnode; + Add : O_Enode; + begin + Info := Get_Info (Def); + if Info.C = null then + return; + end if; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + if Info.C.Size_Var (Kind) /= null then + Open_Temp; + 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_Array => + V := New_Sizeof (Info.Ortho_Type (Kind), + Ghdl_Index_Type); + Add := Get_Additionnal_Size + (Get_Element_Subtype (Def), Kind); + if Add /= O_Enode_Null then + Add := New_Dyadic_Op + (ON_Mul_Ov, Get_Array_Type_Length (Def), Add); + Res := New_Dyadic_Op (ON_Add_Ov, New_Lit (V), Add); + else + Res := New_Lit (V); + end if; + when Type_Mode_Record => + declare + El : Iir_Element_Declaration; + N_Res : O_Enode; + begin + V := New_Sizeof (Info.Ortho_Type (Kind), + Ghdl_Index_Type); + El := Get_Element_Declaration_Chain + (Get_Base_Type (Def)); + Res := New_Lit (V); + while El /= Null_Iir loop + N_Res := Get_Additionnal_Size (Get_Type (El), Kind); + if N_Res /= O_Enode_Null then + Res := New_Dyadic_Op + (ON_Add_Ov, Res, N_Res); + end if; + El := Get_Chain (El); + end loop; + end; + when Type_Mode_Ptr_Array => + -- If element is a composite type then + -- Return length * (sizeof (element) + -- + sizeof (element_ptr)) + -- else + -- Return length * sizeof (element) + -- end if + declare + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + begin + El_Type := Get_Element_Subtype (Def); + El_Tinfo := Get_Info (El_Type); + Res := Chap3.Get_Object_Size + (T2M (El_Type, Kind), El_Type); + if El_Tinfo.C /= null then + Res := New_Dyadic_Op + (ON_Add_Ov, + Res, + New_Lit + (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind), + Ghdl_Index_Type))); + end if; + Res := New_Dyadic_Op + (ON_Mul_Ov, + Chap3.Get_Array_Type_Length (Def), + Res); + end; + end case; + New_Assign_Stmt (Get_Var (Info.C.Size_Var (Kind)), Res); + Close_Temp; + end if; + end loop; + end Create_Type_Definition_Size_Var; + + procedure Create_Type_Range_Var (Def : Iir) + is + Info : Type_Info_Acc; + Base_Info : Type_Info_Acc; + Val : O_Cnode; + Suffix : String (1 .. 3) := "xTR"; + begin + Info := Get_Info (Def); + 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; + begin + El := Get_Element_Declaration_Chain (Def); + while El /= Null_Iir loop + Asub := Get_Type (El); + if Is_Anonymous_Type_Definition (Asub) then + Handle_A_Subtype (Asub); + end if; + El := Get_Chain (El); + end loop; + end; + when others => + null; + end case; + end Handle_Anonymous_Subtypes; + + -- 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_B2 => + declare + V : Iir_Int32; + begin + V := Get_Enum_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 := Get_Enum_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_Literal_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_Literal_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; + + procedure Create_Subtype_Info_From_Type (Def : Iir; + Subtype_Info : Type_Info_Acc; + Base_Info : Type_Info_Acc) + is + Base_Type : Iir; + 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. + Base_Type := Get_Base_Type (Def); + 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; + + -- 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 + return; + end if; + if Info.Kind = Kind_Incomplete_Type then + 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; + end if; + + when Iir_Kind_Floating_Type_Definition => + Translate_Floating_Type (Def); + Create_Scalar_Type_Range_Type (Def, False); + + when Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_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; + 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 (Def); + -- Info.Type_Range_Type := Create_Array_Type_Bounds_Type (Def, Id); + + when Iir_Kind_Array_Subtype_Definition => + 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 (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; + + 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 + | Iir_Kind_Unconstrained_Array_Subtype_Definition => + Free_Info (Def); + Set_Info (Def, Base_Info); + + when Iir_Kind_Access_Type_Definition => + declare + Dtype : 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 + Decl : Iir; + Id : Name_Id; + Info : Type_Info_Acc; + Base_Type : Iir; + 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); + Base_Type := Get_Base_Type (Def); + Decl := Get_Type_Declarator (Def); + + Id := Get_Identifier (Decl); + + 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 (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 Tinfo.C = null or else Tinfo.C.Builder_Need_Func = False then + return; + end if; + + -- Declare subprograms. + Id := Get_Identifier (Decl); + Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); + if Get_Signal_Type_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_Signal_Type_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_Signal_Type_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 + Info : Type_Info_Acc; + 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; + + Info := Get_Info (Def); + + Elab_Type_Definition_Depend (Def); + + Create_Type_Definition_Type_Range (Def); + Create_Type_Definition_Size_Var (Def); + end Elab_Type_Definition; + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Id); + Chap3.Translate_Type_Definition (Def); + Pop_Identifier_Prefix (Mark); + end Translate_Named_Type_Definition; + + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean) + is + Mark : Id_Mark_Type; + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Def); + if Type_Info /= null then + return; + end if; + Push_Identifier_Prefix_Uniq (Mark); + Chap3.Translate_Type_Definition (Def, False); + if Transient then + Add_Transient_Type_In_Temp (Def); + end if; + Pop_Identifier_Prefix (Mark); + end Translate_Anonymous_Type_Definition; + + procedure Destroy_Type_Info (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Free_Type_Info (Type_Info, False); + Clear_Info (Atype); + end Destroy_Type_Info; + + procedure Translate_Object_Subtype (Decl : Iir; + With_Vars : Boolean := True) + is + Mark : Id_Mark_Type; + Mark2 : Id_Mark_Type; + Def : Iir; + begin + Def := Get_Type (Decl); + if Is_Anonymous_Type_Definition (Def) then + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark2, "OT"); + Chap3.Translate_Type_Definition (Def, With_Vars); + Pop_Identifier_Prefix (Mark2); + Pop_Identifier_Prefix (Mark); + end if; + end Translate_Object_Subtype; + + procedure Elab_Object_Subtype (Def : Iir) is + begin + if Is_Anonymous_Type_Definition (Def) then + Elab_Type_Definition (Def); + end if; + end Elab_Object_Subtype; + + procedure Elab_Type_Declaration (Decl : Iir) + is + begin + Elab_Type_Definition (Get_Type (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 + Index_List : Iir_List; + Nbr_Dim : Natural; + Val : Iir_Int64; + Rng : Iir; + begin + Index_List := Get_Index_Subtype_List (Atype); + Nbr_Dim := Get_Nbr_Elements (Index_List); + Val := 1; + for I in 0 .. Nbr_Dim - 1 loop + Rng := Get_Range_Constraint + (Get_Nth_Element (Index_List, I)); + 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 Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) + return O_Enode + is + Index_List : Iir_List; + Index_Type : Iir; + Nbr_Dim : Natural; + Dim_Length : O_Enode; + Res : O_Enode; + Type_Info : Type_Info_Acc; + Index_Info : Type_Info_Acc; + begin + Index_List := Get_Index_Subtype_List (Atype); + Nbr_Dim := Get_Nbr_Elements (Index_List); + + Type_Info := Get_Info (Get_Base_Type (Atype)); + for Dim in 1 .. Nbr_Dim loop + Index_Type := Get_Nth_Element (Index_List, Dim - 1); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + Dim_Length := New_Value + (New_Selected_Element + (New_Selected_Element (New_Acc_Value (New_Obj (Ptr)), + Type_Info.T.Bounds_Vector (Dim)), + Index_Info.T.Range_Length)); + 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_Ptr_Length; + + function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) + return Mnode + is + Tinfo : Type_Info_Acc; + Index_Type : Iir; + Iinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (B); + Index_Type := Get_Nth_Element + (Get_Index_Subtype_List (Get_Base_Type (Atype)), Dim - 1); + Iinfo := Get_Info (Get_Base_Type (Index_Type)); + return Lv2M (New_Selected_Element (M2Lv (B), + Tinfo.T.Bounds_Vector (Dim)), + 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 : Type_Info_Acc; + begin + Info := Get_Info (Atype); + 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 : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + 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 + | Type_Mode_Ptr_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 : 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.Bounds_Field (Kind)), + Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type); + end; + when Type_Mode_Array + | Type_Mode_Ptr_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_Array_Type_Length (Atype : Iir) return O_Enode + is + Index_List : Iir_List; + Index_Type : Iir; + Nbr_Dim : Natural; + Dim_Length : O_Enode; + Res : O_Enode; + Type_Info : Type_Info_Acc; + Binfo : Type_Info_Acc; + Index_Info : Type_Info_Acc; + Bounds : Mnode; + begin + Index_List := Get_Index_Subtype_List (Atype); + Nbr_Dim := Get_Nbr_Elements (Index_List); + + -- Handle thin array case. + Type_Info := Get_Info (Atype); + case Type_Info.Type_Mode is + when Type_Mode_Ptr_Array => + Bounds := Get_Array_Type_Bounds (Atype); + if Nbr_Dim > 1 then + Bounds := Stabilize (Bounds); + end if; + when Type_Mode_Array => + return New_Lit (Get_Thin_Array_Length (Atype)); + when others => + raise Internal_Error; + end case; + + Binfo := Get_Info (Get_Base_Type (Atype)); + for Dim in 1 .. Nbr_Dim loop + Index_Type := Get_Nth_Element (Index_List, Dim - 1); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + Dim_Length := + M2E (Range_To_Length (Bounds_To_Range (Bounds, 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_Array_Type_Length; + + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode + is + Index_List : Iir_List; + Index_Type : Iir; + Nbr_Dim : Natural; + Dim_Length : O_Enode; + Res : O_Enode; + Type_Info : Type_Info_Acc; + Binfo : Type_Info_Acc; + Index_Info : Type_Info_Acc; + B : Mnode; + begin + Index_List := Get_Index_Subtype_List (Atype); + Nbr_Dim := Get_Nbr_Elements (Index_List); + + -- Handle thin array case. + Type_Info := Get_Info (Atype); + case Type_Info.Type_Mode is + when Type_Mode_Ptr_Array + | Type_Mode_Array => + return Get_Array_Type_Length (Atype); + when Type_Mode_Fat_Array => + null; + when others => + raise Internal_Error; + end case; + + Binfo := Get_Info (Get_Base_Type (Atype)); + for Dim in 1 .. Nbr_Dim loop + Index_Type := Get_Nth_Element (Index_List, Dim - 1); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + B := Get_Array_Bounds (Arr); + Dim_Length := + M2E (Range_To_Length (Bounds_To_Range (B, 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_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 + F : O_Fnode; + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Arr); + F := Info.T.Base_Field (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 + | Type_Mode_Ptr_Array => + return Arr; + when others => + raise Internal_Error; + end case; + end Get_Array_Base; + + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + El_Type : Iir; + begin + El_Type := Get_Element_Subtype (Atype); + return Lo2M (New_Indexed_Element (M2Lv (Base), Index), + Get_Info (El_Type), Get_Object_Kind (Base)); + end Index_Base; + + function Get_Array_Ptr_Base_Ptr + (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) + return O_Lnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Info (Atype); + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + return New_Selected_Element + (New_Access_Element (New_Value (Ptr)), + Tinfo.T.Base_Field (Is_Sig)); + when Type_Mode_Array + | Type_Mode_Ptr_Array => + return Ptr; + when others => + raise Internal_Error; + end case; + end Get_Array_Ptr_Base_Ptr; + + function Get_Array_Ptr_Range_Ptr (Ptr : O_Lnode; + Array_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + return O_Enode + is + Array_Info : Type_Info_Acc; + Res : O_Lnode; + Index_Type : Iir; + Index_Info : Type_Info_Acc; + begin + Array_Info := Get_Info (Array_Type); + Index_Type := Get_Nth_Element (Get_Index_Subtype_List (Array_Type), + Dim - 1); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + case Array_Info.Type_Mode is + when Type_Mode_Array + | Type_Mode_Ptr_Array => + -- Extract bound variable. + Res := Get_Var (Array_Info.T.Array_Bounds); + when Type_Mode_Fat_Array => + -- From fat record, extract bounds field. + Res := New_Acc_Value + (New_Selected_Acc_Value + (Ptr, Array_Info.T.Bounds_Field (Is_Sig))); + when others => + raise Internal_Error; + end case; + -- Extract the range for the dimension. + Res := New_Selected_Element (Res, Array_Info.T.Bounds_Vector (Dim)); + return New_Address (Res, Index_Info.T.Range_Ptr_Type); + end Get_Array_Ptr_Range_Ptr; + + function Get_Array_Ptr_Bounds_Ptr + (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) + return O_Enode + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Atype); + case Info.Type_Mode is + when Type_Mode_Fat_Array => + return New_Value + (New_Selected_Element (New_Acc_Value (Ptr), + Info.T.Bounds_Field (Is_Sig))); + when Type_Mode_Array + | Type_Mode_Ptr_Array => + return New_Address (Get_Var (Info.T.Array_Bounds), + Info.T.Bounds_Ptr_Type); + when others => + raise Internal_Error; + end case; + end Get_Array_Ptr_Bounds_Ptr; + + function Get_Array_Bounds_Ptr + (Arr : O_Lnode; Arr_Type : Iir; Is_Sig : Object_Kind_Type) + return O_Enode + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Arr_Type); + case Type_Info.Type_Mode is + when Type_Mode_Fat_Array => + return New_Value (New_Selected_Element + (Arr, Type_Info.T.Bounds_Field (Is_Sig))); + when Type_Mode_Array + | Type_Mode_Ptr_Array => + return New_Address (Get_Var (Type_Info.T.Array_Bounds), + Type_Info.T.Bounds_Ptr_Type); + when others => + -- Not an array! + raise Internal_Error; + end case; + end Get_Array_Bounds_Ptr; + + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; + Res : Mnode; + Arr_Type : Iir) + is + Dinfo : Type_Info_Acc; + Length : O_Enode; + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Res); + Dinfo := Get_Info (Get_Base_Type (Arr_Type)); + -- 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 Dinfo.C /= null and then Dinfo.C.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; + + function Get_Memory_Complex_1 + (Ptr : O_Lnode; Obj_Type : Iir; Kind : Object_Kind_Type) + return O_Enode + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Obj_Type); + case Info.Type_Mode is + when Type_Mode_Ptr_Array => + return New_Value (Ptr); + when Type_Mode_Array => + return Get_Memory_Complex_1 + (New_Indexed_Element + (Ptr, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, 0))), + Get_Element_Subtype (Obj_Type), + Kind); + when Type_Mode_Record => + declare + El : Iir_Element_Declaration; + El_Type : Iir; + El_Info : Type_Info_Acc; + begin + El := Get_Element_Declaration_Chain + (Get_Base_Type (Obj_Type)); + while El /= Null_Iir loop + El_Type := Get_Type (El); + El_Info := Get_Info (El_Type); + if El_Info.C /= null then + return Get_Memory_Complex_1 + (New_Selected_Element + (Ptr, Get_Info (El).Field_Node (Kind)), + El_Type, + Kind); + end if; + El := Get_Chain (El); + end loop; + -- Record is known to be complex but has no complex + -- element. + raise Internal_Error; + end; + when Type_Mode_Scalar + | 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 Get_Memory_Complex_1; + +-- -- VAR_PTR is a pointer to an object of type OBJ_TYPE (and kind KIND). +-- -- This object is known to be of a complex type. +-- -- Return the value of the first internal pointer of the object. +-- function Get_Memory_Complex +-- (Var_Ptr : O_Lnode; Obj_Type : Iir; Kind : Object_Kind_Type) +-- return O_Enode +-- is +-- Info : Type_Info_Acc; +-- Res : O_Enode; +-- begin +-- Info := Get_Info (Obj_Type); +-- case Info.Type_Mode is +-- when Type_Mode_Fat_Array +-- | Type_Mode_Array +-- | Type_Mode_Ptr_Array => +-- Res := Get_Memory_Complex_1 +-- (New_Indexed_Element +-- (New_Acc_Value (Get_Array_Ptr_Base_Ptr +-- (Var_Ptr, Obj_Type, Kind)), +-- New_Unsigned_Literal (Ghdl_Index_Type, 0)), +-- Get_Element_Subtype (Obj_Type), +-- Kind); +-- when Type_Mode_Record => +-- Res := Get_Memory_Complex_1 +-- (New_Acc_Value (Var_Ptr), Obj_Type, Kind); +-- when Type_Mode_Non_Composite +-- | Type_Mode_Unknown => +-- -- Cannot be a complex type. +-- raise Internal_Error; +-- end case; +-- return New_Convert_Ov (Res, Char_Ptr_Type_Node); +-- end Get_Memory_Complex; + + -- Copy SRC to DEST. + -- Both have the same type, OTYPE. + procedure Translate_Object_Copy (Dest : Mnode; + Src : O_Enode; + Obj_Type : Iir) + is + Info : Type_Info_Acc; + D : Mnode; + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Dest); + Info := Get_Info (Obj_Type); + if Info.C /= null and then Info.C.Builder_Need_Func then + D := Stabilize (Dest); + -- A complex type that must be rebuilt. + -- Save destinaton. + -- Do the copy. + case Info.Type_Mode is + when Type_Mode_Fat_Array => + -- a fat array. + Gen_Memcpy + (M2Addr (Chap3.Get_Array_Base (D)), + New_Value + (New_Selected_Element (New_Access_Element (Src), + Info.T.Base_Field (Kind))), + Get_Object_Size (Dest, Obj_Type)); + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Ptr_Array => + Gen_Memcpy (M2Addr (D), + Src, + Get_Object_Size (Dest, Obj_Type)); + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + -- Rebuilt the type. + Gen_Call_Type_Builder (D, Obj_Type); + else + 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. + declare + Var_S : O_Dnode; + Var_D : O_Dnode; + begin + Var_S := Create_Temp_Init (Info.Ortho_Ptr_Type (Kind), + Src); + Var_D := Create_Temp_Init (Info.Ortho_Ptr_Type (Kind), + M2Addr (Dest)); + Copy_Fat_Access (Var_D, Var_S, Get_Base_Type (Obj_Type)); + end; + when Type_Mode_Fat_Array => + -- a fat array. + Gen_Memcpy + (M2Addr (Get_Array_Base (Dest)), + M2Addr (Get_Array_Base (E2M (Src, Info, Kind))), + Get_Object_Size (Dest, Obj_Type)); + when Type_Mode_Record + | Type_Mode_Ptr_Array => + Gen_Memcpy + (M2Addr (Dest), Src, Get_Object_Size (Dest, Obj_Type)); + when Type_Mode_Array => + 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 if; + end Translate_Object_Copy; + + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) + return O_Enode + is + Type_Info : Type_Info_Acc; + Kind : Object_Kind_Type; + begin + Type_Info := Get_Type_Info (Obj); + Kind := Get_Object_Kind (Obj); + if Type_Info.C /= null + and then Type_Info.C.Size_Var (Kind) /= null + then + return New_Value (Get_Var (Type_Info.C.Size_Var (Kind))); + 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 El_Tinfo.C /= null 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 : O_Enode) + is + Dinfo : Type_Info_Acc; + Kind : Object_Kind_Type; + begin + Dinfo := Get_Info (Obj_Type); + Kind := Get_Object_Kind (Res); + 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)), + 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 Dinfo.C /= null and then Dinfo.C.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 (Atype : Iir) return Boolean + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Atype); + if Info.T.Nocheck_Low and Info.T.Nocheck_Hi then + return False; + else + return True; + end if; + end Need_Range_Check; + + procedure Check_Range (Value : O_Dnode; Expr : Iir; Atype : Iir) + is + If_Blk : O_If_Block; + begin + if not Need_Range_Check (Atype) + or else Get_Type (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 (Expr, Atype) then + Chap6.Gen_Bound_Error (Expr); + end if; + else + Open_Temp; + Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype)); + Chap6.Gen_Bound_Error (Null_Iir); + Finish_If_Stmt (If_Blk); + Close_Temp; + end if; + end Check_Range; + + procedure Check_Array_Match (L_Type : Iir; + L_Node : O_Lnode; + L_Mode : Object_Kind_Type; + R_Type : Iir; + R_Node : O_Lnode; + R_Mode : Object_Kind_Type; + Loc : Iir) + is + L_Tinfo, R_Tinfo : Type_Info_Acc; + begin + L_Tinfo := Get_Info (L_Type); + R_Tinfo := Get_Info (R_Type); + if L_Tinfo.Type_Mode = Type_Mode_Array + and R_Tinfo.Type_Mode = Type_Mode_Array + then + -- Both left and right are thin array. + -- Check here the length are the same. + declare + L_Indexes : Iir_List; + R_Indexes : Iir_List; + L_El : Iir; + R_El : Iir; + Err : Boolean; + begin + L_Indexes := Get_Index_Subtype_List (L_Type); + R_Indexes := Get_Index_Subtype_List (R_Type); + Err := False; + for I in Natural loop + L_El := Get_Nth_Element (L_Indexes, I); + R_El := Get_Nth_Element (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 + if not Err then + Chap6.Gen_Bound_Error (Loc); + Err := True; + end if; + end if; + end loop; + end; + else + -- Check length match. + declare + Index_List : Iir_List; + Index : Iir; + Cond : O_Enode; + Sub_Cond : O_Enode; + begin + Index_List := Get_Index_Subtype_List (L_Type); + for I in Natural loop + Index := Get_Nth_Element (Index_List, I); + exit when Index = Null_Iir; + Sub_Cond := New_Compare_Op + (ON_Neq, + Chap6.Get_Array_Ptr_Bound_Length (L_Node, L_Type, + I + 1, L_Mode), + Chap6.Get_Array_Ptr_Bound_Length (R_Node, R_Type, + I + 1, R_Mode), + 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 (New_Unsigned_Literal (Ghdl_Index_Type, + 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 (New_Unsigned_Literal (Ghdl_Index_Type, + 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) + is + Iinfo : Type_Info_Acc; + Op : ON_Op_Kind; + Diff : O_Enode; + Left_Bound : O_Enode; + Var_Right : O_Dnode; + If_Blk : O_If_Block; + Range_Constr : Iir; + Range_Expr : Iir; + begin + Iinfo := Get_Info (Index_Type); + Range_Constr := Get_Range_Constraint (Index_Type); + Range_Expr := Eval_Range (Range_Constr); + if Range_Expr = Null_Iir 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 (New_Unsigned_Literal (Ghdl_Index_Type, + 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 (New_Unsigned_Literal (Ghdl_Index_Type, + 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); + 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 Tinfo.C /= null 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_Ptr_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; + + -- Get the ortho type for an object of mode MODE. + function Get_Element_Type (Tinfo : Type_Info_Acc; + Kind : Object_Kind_Type) + return O_Tnode is + begin + if Tinfo.C /= null then + -- Always use a pointer for a complex type. + return Tinfo.Ortho_Ptr_Type (Kind); + else + return Tinfo.Ortho_Type (Kind); + end if; + end Get_Element_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_Constant_Interface_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 then + -- Not a full constant declaration (ie a value for an + -- already declared constant). + -- Must create the declaration. + if Get_Expr_Staticness (El) = Locally + or else 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 ? + + -- Only required for transient types. + -- FIXME: check this (why open/close_temp ?) + 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 : O_Tnode; + Type_Info : Type_Info_Acc; + Info : Ortho_Info_Acc; + Sig_Type_Def : Iir; + begin + Sig_Type_Def := Get_Type (Decl); + Chap3.Translate_Object_Subtype (Decl); + Type_Info := Get_Info (Sig_Type_Def); + Sig_Type := Get_Object_Type (Type_Info, 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_Var_Identifier (Decl), Sig_Type); + + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_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 Allocate_Complex_Object (Obj_Type : Iir; + Alloc_Kind : Allocation_Kind; + Var : in out Mnode) + is + Type_Info : Type_Info_Acc; + Kind : Object_Kind_Type; + Targ : Mnode; + begin + Type_Info := Get_Type_Info (Var); + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Cannot allocate unconstrained object (since size is unknown). + raise Internal_Error; + end if; + Kind := Get_Object_Kind (Var); + + if Type_Info.C = null then + -- Object is not complex. + return; + end if; + + if Type_Info.C.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.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); + + -- The object has already been allocated. + -- Call the initializator. + Start_Association (Assoc, Info.T.Prot_Init_Node); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance, + Info.Ortho_Type (Mode_Value), + M2E (Obj)); + New_Procedure_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_Node); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Final_Instance, + Info.Ortho_Type (Mode_Value), + 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; + begin + Open_Temp; + Sobj := Stabilize (Obj); + El := Get_Element_Declaration_Chain + (Get_Base_Type (Obj_Type)); + while El /= Null_Iir loop + Init_Object (Chap6.Translate_Selected_Element (Sobj, El), + Get_Type (El)); + El := Get_Chain (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_Info : Object_Info_Acc; + + Name_Node : Mnode; + Obj_Type : Iir; + + Type_Info : Type_Info_Acc; + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Obj_Type := Get_Type (Obj); + Chap3.Elab_Object_Subtype (Obj_Type); + + Type_Info := Get_Info (Obj_Type); + Obj_Info := Get_Info (Obj); + + -- FIXME: the object type may be a fat array! + -- FIXME: fat array + aggregate ? + + if Type_Info.C /= null + 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_Info : Object_Info_Acc; + + Name_Node : Mnode; + Value_Node : O_Enode; + Obj_Type : Iir; + + Type_Info : Type_Info_Acc; + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Obj_Type := Get_Type (Obj); + Type_Info := Get_Info (Obj_Type); + Obj_Info := Get_Info (Obj); + + Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); + + Open_Temp; + if Value = Null_Iir then + -- Performs default initialization. + Init_Object (Name, Obj_Type); + 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 + (New_Selected_Element + (M2Lv (Name_Node), Type_Info.T.Bounds_Field (Mode_Value)), + Chap3.Get_Array_Ptr_Bounds_Ptr (O_Lnode_Null, Aggr_Type, + Mode_Value)); + 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 : O_Dnode; + begin + Name_Node := Stabilize (Name); + S := Create_Temp_Init + (Type_Info.Ortho_Ptr_Type (Mode_Value), Value_Node); + + 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, + Dp2M (S, Type_Info, Mode_Value)); + else + Chap3.Translate_Object_Allocation + (Name_Node, Alloc_Kind, Obj_Type, + Chap3.Get_Array_Ptr_Bounds_Ptr (New_Obj (S), + Get_Type (Value), + Mode_Value)); + Chap3.Translate_Object_Copy + (Name_Node, New_Obj_Value (S), Obj_Type); + end if; + end; + else + Chap3.Translate_Object_Copy (Name, Value_Node, Obj_Type); + end if; + end if; + + Close_Temp; + 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) = True 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 Type_Info.C /= null 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 : Type_Info_Acc; + begin + Info := Get_Info (Sig_Type); + case Info.Type_Mode is + when Type_Mode_Scalar => + return New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, 1)); + when Type_Mode_Arrays => + return New_Dyadic_Op + (ON_Mul_Ov, + Chap3.Get_Array_Length (Sig, Sig_Type), + Get_Nbr_Signals (Mnode_Null, + Get_Element_Subtype (Sig_Type))); + when Type_Mode_Record => + declare + El : Iir; + Res : O_Enode; + E : O_Enode; + begin + El := + Get_Element_Declaration_Chain (Get_Base_Type (Sig_Type)); + Res := O_Enode_Null; + while El /= Null_Iir loop + E := Get_Nbr_Signals (Mnode_Null, Get_Type (El)); + if Res /= O_Enode_Null then + Res := New_Dyadic_Op (ON_Add_Ov, Res, E); + else + Res := E; + end if; + El := Get_Chain (El); + end loop; + if Res = O_Enode_Null then + return New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, 0)); + else + return Res; + end if; + 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 (New_Unsigned_Literal (Ghdl_Index_Type, 0))); + Res_Type := Get_Element_Subtype (Res_Type); + when Type_Mode_Record => + declare + Element : Iir; + begin + Element := Get_Element_Declaration_Chain + (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 : Iir) + is + Func_Info : Subprg_Info_Acc; + Resolv_Info : Subprg_Resolv_Info_Acc; + begin + Func_Info := Get_Info (Get_Named_Entity (Func)); + Resolv_Info := Func_Info.Subprg_Resolv; + New_Association + (Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func, + Ghdl_Ptr_Type))); + if Resolv_Info.Resolv_Block /= Null_Iir then + New_Association + (Assoc, + New_Convert_Ov (Get_Instance_Access (Resolv_Info.Resolv_Block), + Ghdl_Ptr_Type)); + else + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end if; + 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 : Type_Info_Acc; + 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 + Type_Info := Get_Info (Targ_Type); + + 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_B2 => + Create_Subprg := Ghdl_Create_Signal_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Create_Subprg := Ghdl_Create_Signal_E8; + 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 := Get_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 := Get_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 Type_Info.C /= null 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; + + -- Create signal object. + -- Note: DECL 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 + (Decl : Iir; Parent : Iir; Check_Null : Boolean) + is + Sig_Type : Iir; + Type_Info : Type_Info_Acc; + Name_Node : Mnode; + Val : Iir; + Data : Elab_Signal_Data; + Base_Decl : Iir; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Open_Temp; + + Sig_Type := Get_Type (Decl); + Type_Info := Get_Info (Sig_Type); + Base_Decl := Get_Base_Name (Decl); + + -- 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_Type, 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_Type, 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 Type_Info.C /= null 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 (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 (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 (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); + if Decl_Type = Null_Iir then + -- FIXME : todo. + raise Internal_Error; + end if; + + Chap3.Translate_Named_Type_Definition + (Decl_Type, Get_Identifier (Decl)); + + Info := Add_Info (Decl, Kind_Alias); + case Get_Kind (Get_Base_Name (Decl)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_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_Ptr_Array => + -- 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 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; + N_Info : Type_Info_Acc; + Alias_Info : Alias_Info_Acc; + Name_Type : Iir; + Tinfo : Type_Info_Acc; + Kind : Object_Kind_Type; + begin + 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); + -- Evaluate names. + Name_Node := Chap6.Translate_Name (Name); + Kind := Get_Object_Kind (Name_Node); + N_Info := Get_Info (Name_Type); + --Chap6.Translate_Name (Decl, Decl_Node, Sig); + + 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 + | Type_Mode_Ptr_Array => + Open_Temp; + Stabilize (Name_Node); + New_Assign_Stmt + (Get_Var (Alias_Info.Alias_Var), + New_Value (M2Lp (Chap3.Get_Array_Base (Name_Node)))); + Chap3.Check_Array_Match (Decl_Type, O_Lnode_Null, Kind, + Name_Type, M2Lp (Name_Node), Kind, + Decl); + Close_Temp; + 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 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 + Create_Object (Decl); + 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 (O_Tnode_Null); + + 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_Type); + New_Type_Decl (Create_Identifier ("_COMPTYPE"), Info.Comp_Type); + Info.Comp_Ptr_Type := New_Access_Type (Info.Comp_Type); + 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 => + Chap3.Translate_Protected_Type_Body (Decl); + + --when Iir_Kind_Implicit_Function_Declaration => + --when Iir_Kind_Signal_Declaration + -- | Iir_Kind_Signal_Interface_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 => + 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; + + -- Mark FUNC (by adding the subprg_resolv info) iif it can be a + -- resolution function. + procedure Check_Resolution_Function (Func : Iir) + is + Param : Iir; + Param_Type : Iir; + Res_Type : Iir; + Info : Subprg_Info_Acc; + begin + Param := Get_Interface_Declaration_Chain (Func); + + -- Return now if the number of parameters is not 1. + if Param = Null_Iir or else Get_Chain (Param) /= Null_Iir then + return; + end if; + Param_Type := Get_Type (Param); + case Get_Kind (Param_Type) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Unconstrained_Array_Subtype_Definition => + null; + when others => + return; + end case; + Res_Type := Get_Return_Type (Func); + if Get_Base_Type (Get_Element_Subtype (Param_Type)) + /= Get_Base_Type (Res_Type) + then + return; + end if; + -- FUNC can be a resolution function. + Info := Get_Info (Func); + Info.Subprg_Resolv := new Subprg_Resolv_Info; + end Check_Resolution_Function; + + procedure Translate_Resolution_Function (Func : Iir; Block : Iir) + is + -- Type of the resolution function parameter. + El_Type : Iir; + El_Info : Type_Info_Acc; + Finfo : Subprg_Info_Acc; + Interface_List : O_Inter_List; + Rinfo : Subprg_Resolv_Info_Acc; + Block_Info : Block_Info_Acc; + Id : O_Ident; + Itype : O_Tnode; + begin + Finfo := Get_Info (Func); + Rinfo := Finfo.Subprg_Resolv; + if Rinfo = null then + 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 Block /= Null_Iir then --and then Get_Pure_Flag (Func) = False then + Block_Info := Get_Info (Block); + Rinfo.Resolv_Block := Block; + Itype := Block_Info.Block_Decls_Ptr_Type; + else + Rinfo.Resolv_Block := Null_Iir; + Itype := Ghdl_Ptr_Type; + end if; + New_Interface_Decl + (Interface_List, Rinfo.Var_Instance, Wki_Instance, Itype); + + -- The signal. + El_Type := Get_Return_Type (Func); + El_Info := Get_Info (El_Type); + 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; Block : Iir) + is + -- Type of the resolution function parameter. + Arr_Type : Iir; + Base_Type, El_Type : Iir; + El_Info : Type_Info_Acc; + Base_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 : Subprg_Info_Acc; + Assoc : O_Assoc_List; + Rinfo : Subprg_Resolv_Info_Acc; + Block_Info : Block_Info_Acc; + + Data : Read_Source_Data; + begin + Finfo := Get_Info (Func); + Rinfo := Finfo.Subprg_Resolv; + if Rinfo = null then + return; + end if; + + El_Type := Get_Return_Type (Func); + El_Info := Get_Info (El_Type); + + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + Base_Type := Get_Base_Type (Arr_Type); + Base_Info := Get_Info (Base_Type); + + Index_Type := Get_First_Element (Get_Index_Subtype_List (Arr_Type)); + Index_Tinfo := Get_Info (Index_Type); + + Start_Subprogram_Body (Rinfo.Resolv_Func); + if Rinfo.Resolv_Block /= Null_Iir then + Block_Info := Get_Info (Block); + Push_Scope (Block_Info.Block_Decls_Type, Rinfo.Var_Instance); + end if; + Push_Local_Factory; + + -- A signal. + + New_Var_Decl (Var_Res, Get_Identifier ("res"), + O_Storage_Local, El_Info.Ortho_Type (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), + Base_Info.T.Bounds_Vector (1)), + Index_Tinfo.T.Range_Ptr_Type)); + + -- Create range from length + Chap3.Create_Range_From_Length + (Index_Type, Var_Length, Var_Range_Ptr); + 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, El_Info, Mode_Value); + Allocate_Complex_Object (El_Type, Alloc_Stack, Res); + end if; + + -- Call the resolution function. + Start_Association (Assoc, Finfo.Ortho_Func); + if Finfo.Res_Interface /= O_Dnode_Null then + New_Association (Assoc, M2E (Res)); + end if; + Chap2.Add_Subprg_Instance_Assoc (Assoc, Finfo.Subprg_Instance); + New_Association + (Assoc, New_Address (New_Obj (Var_Array), + Base_Info.Ortho_Ptr_Type (Mode_Value))); + + if Finfo.Res_Interface = O_Dnode_Null then + Res := E2M (New_Function_Call (Assoc), El_Info, Mode_Value); + else + New_Procedure_Call (Assoc); + end if; + + Chap7.Set_Driving_Value (Vals, El_Type, Res); + + Close_Temp; + Pop_Local_Factory; + if Rinfo.Resolv_Block /= Null_Iir then + Pop_Scope (Block_Info.Block_Decls_Type); + 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 Flag_Discard_Unused + and then not Get_Use_Flag (El) + then + null; + else + Info := Add_Info (El, Kind_Subprg); + Chap2.Translate_Subprogram_Interfaces (El); + if Get_Kind (El) = Iir_Kind_Function_Declaration then + Check_Resolution_Function (El); + 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; Block : 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 => + if Get_Info (El) /= null then + Chap2.Translate_Subprogram_Declaration (El); + Translate_Resolution_Function (El, Block); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + if Flag_Discard_Unused + and then + not Get_Use_Flag (Get_Subprogram_Specification (El)) + then + null; + else + Chap2.Translate_Subprogram_Body (El); + Translate_Resolution_Function_Body + (Get_Subprogram_Specification (El), Block); + 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_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_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 + Open_Temp; + + 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; + + Close_Temp; + + 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); + + procedure Translate_Association_Subprogram + (Assoc : Iir; + Mode : Conv_Mode; + Conv_Info : in out Assoc_Conv_Info; + Base_Block : Iir; + Entity : Iir) + is + Mark2, Mark3 : Id_Mark_Type; + Inter_List : O_Inter_List; + Formal, Actual : Iir; + In_Type, Out_Type : Iir; + In_Info, Out_Info : Type_Info_Acc; + Itype : O_Tnode; + El_List : O_Element_List; + Block_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; + Res_Info : Type_Info_Acc; + Imp : Iir; + begin + Formal := Get_Formal (Assoc); + Actual := Get_Actual (Assoc); + + 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_Base_Name (Formal))); + + 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; + Block_Info := Get_Info (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); + + 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)); + Push_Scope (Block_Info.Block_Decls_Type, 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; + Decl_Type : O_Tnode; + begin + if Entity_Info.Kind = Kind_Component then + Ptr_Type := Entity_Info.Comp_Ptr_Type; + Decl_Type := Entity_Info.Comp_Type; + else + Ptr_Type := Entity_Info.Block_Decls_Ptr_Type; + Decl_Type := Entity_Info.Block_Decls_Type; + end if; + V := Create_Temp_Init + (Ptr_Type, + New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Instantiated_Field)); + Push_Scope (Decl_Type, V); + end; + 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 => + Imp := Get_Implementation (Imp); + R := Chap7.Translate_Implicit_Conv + (R, In_Type, Get_Type (Get_Interface_Declaration_Chain (Imp)), + Mode_Value); + + -- Create result value. + Subprg_Info := Get_Info (Imp); + + 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 : 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; + + -- Call conversion function. + Start_Association (Constr, Subprg_Info.Ortho_Func); + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Association (Constr, M2E (Res)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Subprg_Info.Subprg_Instance); + + New_Association (Constr, R); + + Res_Info := Get_Info (Get_Return_Type (Imp)); + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + else + Res := E2M (New_Function_Call (Constr), + Res_Info, Mode_Value); + end if; + + when Iir_Kind_Type_Conversion => + declare + Conv_Type : Iir; + begin + Conv_Type := Get_Type (Imp); + Res := E2M (Chap7.Translate_Type_Conversion + (R, In_Type, Conv_Type, Assoc), + Get_Info (Conv_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 Conv_Info.Instantiated_Entity /= Null_Iir then + if Entity_Info.Kind = Kind_Component then + Pop_Scope (Entity_Info.Comp_Type); + else + Pop_Scope (Entity_Info.Block_Decls_Type); + end if; + end if; + Pop_Scope (Block_Info.Block_Decls_Type); + Pop_Local_Factory; + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark3); + Pop_Identifier_Prefix (Mark2); + end Translate_Association_Subprogram; + + procedure Translate_Association_Subprograms + (Assoc_Chain : Iir; Base_Block : Iir; Entity : Iir) + is + Assoc : Iir; + Info : Assoc_Info_Acc; + begin + Assoc := Assoc_Chain; + 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 + (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 + (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_Type), + 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 : Iir_Attribute_Declaration; + Mark : Id_Mark_Type; + Info : Object_Info_Acc; + Atinfo : Type_Info_Acc; + begin + Attr := Get_Attribute_Designator (Spec); + Atinfo := Get_Info (Get_Type (Attr)); + Push_Identifier_Prefix_Uniq (Mark); + Info := Add_Info (Spec, Kind_Object); + Info.Object_Var := Create_Var + (Create_Var_Identifier (Attr), + Atinfo.Ortho_Type (Mode_Value), + Global_Storage); + Pop_Identifier_Prefix (Mark); + end Translate_Attribute_Specification; + + procedure Elab_Attribute_Specification + (Spec : Iir_Attribute_Specification) + is + Attr : Iir_Attribute_Declaration; + begin + Attr := Get_Attribute_Designator (Spec); + -- 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 : Iir_List; + El : Iir; + begin + Val := Create_Temp_Init + (Std_Time_Type, Chap7.Translate_Expression (Get_Expression (Spec))); + List := Get_Signal_List (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_B2 => + Subprg := Ghdl_Signal_Associate_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Associate_E8; + 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 Get_Kind (Actual_Type) + not in Iir_Kinds_Unconstrained_Array_Type_Definition + 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 + case Get_Kind (Get_Base_Name (Obj)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kinds_Signal_Attribute => + return True; + when others => + return False; + end case; + else + return False; + end if; + end Is_Signal; + + procedure Elab_Port_Map_Aspect_Assoc (Assoc : Iir; By_Copy : Boolean) + is + Formal, Actual : Iir; + Formal_Type, Actual_Type : Iir; + Formal_Node, Actual_Node : Mnode; + Data : Connect_Data; + Mode : Connect_Mode; + begin + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression + and then Get_Collapse_Signal_Flag (Assoc) = By_Copy + then + Open_Temp; + Formal := Get_Formal (Assoc); + Actual := Get_Actual (Assoc); + Formal_Type := Get_Type (Formal); + Actual_Type := Get_Type (Actual); + 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 signal + -- is 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 (Get_Base_Name (Formal)) 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; + + 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 if; + 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 Inherit_Collapse_Flag (Get_Associated (Assoc)) = False + 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_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; + Targ : Mnode; + begin + -- Elab generics, and associate. + -- The generic map must be done before the elaboration of + -- the ports, since a port subtype may depend on a generic. + Assoc := Get_Generic_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + 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 + Open_Temp; + Targ := Chap6.Translate_Name (Formal); + Chap7.Translate_Assign + (Targ, Get_Actual (Assoc), Get_Type (Formal)); + Close_Temp; + end if; + 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. + Open_Temp; + declare + Formal_Node : Mnode; + Formal_Type : Iir; + Obj_Info : Object_Info_Acc; + Obj_Type : Iir; + Type_Info : Type_Info_Acc; + Bounds : O_Enode; + begin + Formal_Type := Get_Type (Formal); + Chap3.Elab_Object_Subtype (Formal_Type); + Type_Info := Get_Info (Formal_Type); + Obj_Info := Get_Info (Formal); + Formal_Node := Get_Var + (Obj_Info.Object_Var, Type_Info, Mode_Value); + Stabilize (Formal_Node); + Obj_Type := Get_Actual_Type (Assoc); + 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 := M2E (Chap3.Get_Array_Type_Bounds (Obj_Type)); + Chap3.Translate_Object_Allocation + (Formal_Node, Alloc_System, Formal_Type, Bounds); + end if; + end; + Close_Temp; + when others => + Error_Kind ("elab_map_aspect(1)", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + + -- Ports. + Assoc := Get_Port_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + Formal_Base := Get_Base_Name (Formal); + Fb_Type := Get_Type (Formal_Base); + + -- 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_By_Individual => + Open_Temp; + declare + Actual_Type : Iir; + Tinfo : Type_Info_Acc; + Bounds : Mnode; + Formal_Node : Mnode; + begin + Actual_Type := Get_Actual_Type (Assoc); + Chap3.Create_Array_Subtype (Actual_Type, False); + Tinfo := Get_Info (Actual_Type); + 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; + Close_Temp; + when others => + Error_Kind ("elab_map_aspect(2)", Assoc); + end case; + end if; + + -- Allocate storage of ports. + 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; + + -- Create or copy signals. + 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; + + Assoc := Get_Chain (Assoc); + end loop; + end Elab_Map_Aspect; + + end Chap5; + + package body Chap6 is + -- Extract from fat array FAT_ARRAY the range corresponding to dimension + -- DIM. + function Fat_Array_To_Range (Fat_Array : O_Lnode; + Array_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + return O_Lnode + is + Lval : O_Lnode; + Array_Info : Type_Info_Acc; + begin + Array_Info := Get_Info (Array_Type); + case Array_Info.Type_Mode is + when Type_Mode_Fat_Array => + -- From fat record, extract bounds field. + Lval := New_Selected_Element + (Fat_Array, Array_Info.T.Bounds_Field (Is_Sig)); + -- Dereference it. + Lval := New_Access_Element (New_Value (Lval)); + when Type_Mode_Ptr_Array => + Lval := Get_Var (Array_Info.T.Array_Bounds); + when others => + raise Internal_Error; + end case; + -- Extract the range for the dimension. + return New_Selected_Element (Lval, Array_Info.T.Bounds_Vector (Dim)); + end Fat_Array_To_Range; + + function Get_Array_Bound_Length (Arr : O_Lnode; + Arr_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + return O_Enode + is + Tinfo : Type_Info_Acc; + Index_Type : Iir; + Rinfo : Type_Info_Acc; + Constraint : Iir; + begin + Index_Type := Get_Nth_Element (Get_Index_Subtype_List (Arr_Type), + Dim - 1); + + Tinfo := Get_Info (Arr_Type); + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Ptr_Array => + Rinfo := Get_Info (Get_Base_Type (Index_Type)); + return New_Value + (New_Selected_Element + (Fat_Array_To_Range (Arr, Arr_Type, Dim, Is_Sig), + Rinfo.T.Range_Length)); + when Type_Mode_Array => + Constraint := Get_Range_Constraint (Index_Type); + return New_Lit + (Chap7.Translate_Static_Range_Length (Constraint)); + when others => + raise Internal_Error; + end case; + end Get_Array_Bound_Length; + + function Get_Array_Ptr_Bound_Length (Ptr : O_Lnode; + Arr_Type : Iir; + Dim : Natural; + Is_Sig : Object_Kind_Type) + return O_Enode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Info (Arr_Type); + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + return Get_Array_Bound_Length + (New_Acc_Value (Ptr), Arr_Type, Dim, Is_Sig); + when Type_Mode_Array + | Type_Mode_Ptr_Array => + return Get_Array_Bound_Length + (O_Lnode_Null, Arr_Type, Dim, Is_Sig); + when others => + raise Internal_Error; + end case; + end Get_Array_Ptr_Bound_Length; + + -- There is a uniq number associated which each error. + Bound_Error_Number : Unsigned_64 := 0; + + procedure Gen_Bound_Error (Loc : Iir) + is + Constr : O_Assoc_List; + Name : Name_Id; + Line, Col : Natural; + begin + if Loc /= Null_Iir then + Files_Map.Location_To_Position + (Get_Location (Loc), Name, Line, Col); + + Start_Association (Constr, Ghdl_Bound_Check_Failed_L1); + New_Association + (Constr, New_Lit (New_Global_Address (Current_Filename_Node, + Char_Ptr_Type))); + New_Association + (Constr, New_Lit (New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Line)))); + New_Procedure_Call (Constr); + else + Start_Association (Constr, Ghdl_Bound_Check_Failed_L0); + New_Association + (Constr, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Bound_Error_Number))); + New_Procedure_Call (Constr); + Bound_Error_Number := Bound_Error_Number + 1; + end if; + end Gen_Bound_Error; + + procedure Gen_Program_Error (Loc : Iir) + is + pragma Unreferenced (Loc); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Program_Error); + New_Procedure_Call (Constr); + 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; + + function Translate_Index_To_Offset (Range_Ptr : O_Dnode; + Index : O_Enode; + Index_Type : Iir; + Loc : Iir) + return O_Enode + is + Dir : O_Enode; + If_Blk : O_If_Block; + Res : O_Dnode; + Off : O_Dnode; + Cond1, Cond2: O_Enode; + Index_Node : O_Dnode; + Bound_Node : O_Dnode; + Index_Info : Type_Info_Acc; + begin + Index_Info := Get_Info (Index_Type); + + Res := Create_Temp (Ghdl_Index_Type); + + Open_Temp; + + Index_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), Index); + Bound_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), + New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), + Index_Info.T.Range_Left)); + Off := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + Dir := New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), + Index_Info.T.Range_Dir); + + 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); + + -- Get the offset. + New_Assign_Stmt + (New_Obj (Res), New_Convert_Ov (New_Obj_Value (Off), + Ghdl_Index_Type)); + + -- Check bounds. + 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), + New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), + Index_Info.T.Range_Length), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + + 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; + Index_Range : Iir; + Dim : Natural; + Expr : Iir) + return O_Enode + is + Obound : O_Cnode; + Res : O_Dnode; + Off : O_Dnode; + Cond2: O_Enode; + Index : O_Enode; + Index_Info : Type_Info_Acc; + V : Iir_Int64; + B : Iir_Int64; + begin + if Get_Expr_Staticness (Expr) = Locally then + V := Eval_Pos (Expr); + B := Eval_Pos (Get_Left_Limit (Index_Range)); + 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_Info := Get_Info (Get_Base_Type (Index_Type)); + Res := Create_Temp (Ghdl_Index_Type); + Off := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + Index := Chap7.Translate_Expression (Expr, Index_Type); + + Obound := Chap7.Translate_Static_Range_Left + (Index_Range, Index_Type); + + if Get_Direction (Index_Range) = Iir_To then + -- Direction TO: INDEX - LEFT. + Index := New_Dyadic_Op (ON_Sub_Ov, Index, New_Lit (Obound)); + else + -- Direction DOWNTO: LEFT - INDEX. + Index := New_Dyadic_Op (ON_Sub_Ov, New_Lit (Obound), Index); + end if; + + New_Assign_Stmt (New_Obj (Off), Index); + + -- Get the offset. + New_Assign_Stmt + (New_Obj (Res), + New_Convert_Ov (New_Obj_Value (Off), Ghdl_Index_Type)); + + -- Since the value is unsigned, both left and right bounds are + -- checked in the same time. + 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); + + return New_Obj_Value (Res); + end if; + end Translate_Thin_Index_Offset; + + -- Translate an indexed name. + function Translate_Indexed_Name (Prefix_Orig : Mnode; Expr : Iir) + return Mnode + is + Prefix : Mnode; + Prefix_Type : Iir; + Index : Iir; + Index_List : Iir_List; + Type_List : Iir_List; + Offset : O_Dnode; + R : O_Enode; + Length : O_Enode; + Itype : Iir; + Ibasetype : Iir; + Prefix_Info : Type_Info_Acc; + Nbr_Dim : Natural; + Fat_Ptr : O_Lnode; + Range_Ptr : Mnode; + begin + Prefix_Type := Get_Type (Get_Prefix (Expr)); + Prefix_Info := Get_Info (Prefix_Type); + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array => + Prefix := Stabilize (Prefix_Orig); + when Type_Mode_Array => + Prefix := Prefix_Orig; + when Type_Mode_Ptr_Array => + -- FIXME: should save the bounds address ? + Fat_Ptr := O_Lnode_Null; + Prefix := Prefix_Orig; + when others => + raise Internal_Error; + end case; + Index_List := Get_Index_List (Expr); + Type_List := Get_Index_Subtype_List (Prefix_Type); + Nbr_Dim := Get_Nbr_Elements (Index_List); + Offset := Create_Temp (Ghdl_Index_Type); + for Dim in 1 .. Nbr_Dim loop + Index := Get_Nth_Element (Index_List, Dim - 1); + Itype := Get_Nth_Element (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 := Chap3.Get_Array_Range + (Prefix, Prefix_Type, Dim); + when Type_Mode_Ptr_Array => + Range_Ptr := Chap3.Bounds_To_Range + (Chap3.Get_Array_Type_Bounds (Prefix_Type), + Prefix_Type, Dim); + when Type_Mode_Array => + null; + when others => + raise Internal_Error; + end case; + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Ptr_Array => + Range_Ptr := Stabilize (Range_Ptr); + R := Translate_Index_To_Offset + (M2Dp (Range_Ptr), + Chap7.Translate_Expression (Index, Ibasetype), + Ibasetype, + Index); + when Type_Mode_Array => + -- BASE is a thin array. + R := Translate_Thin_Index_Offset + (Ibasetype, Get_Range_Constraint (Itype), Dim, Index); + 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. + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Ptr_Array => + Length := M2E (Chap3.Range_To_Length (Range_Ptr)); + when Type_Mode_Array => + Length := New_Lit (Chap7.Translate_Static_Range_Length + (Get_Range_Constraint (Itype))); + when others => + raise Internal_Error; + end case; + 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 Chap3.Index_Base (Chap3.Get_Array_Base (Prefix), Prefix_Type, + New_Obj_Value (Offset)); + end Translate_Indexed_Name; + + function Translate_Slice_Name (Prefix : Mnode; Expr : Iir_Slice_Name) + return Mnode + is + -- Type of the prefix. + Prefix_Type : Iir; + + -- Type info of the prefix. + Prefix_Info : Type_Info_Acc; + + -- Type of the slice. + Slice_Type : Iir; + Slice_Info : Type_Info_Acc; + Slice_Binfo : Type_Info_Acc; + + -- Type of the first (and only) index of the prefix array type. + Index_Type : Iir; + + -- True iff the direction of the slice is known at compile time. + Static_Range : Boolean; + + -- Suffix of the slice (discrete range). + Expr_Range : Iir; + + -- Object kind of the prefix. + Kind : Object_Kind_Type; + + -- 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; + + Res_L : O_Lnode; + Res_D : O_Dnode; + + Diff : O_Dnode; + Unsigned_Diff : O_Dnode; + If_Blk1 : O_If_Block; + begin + -- Evaluate the prefix. + Slice_Type := Get_Type (Expr); + Expr_Range := Get_Suffix (Expr); + Prefix_Type := Get_Type (Get_Prefix (Expr)); + Index_Type := Get_Nth_Element + (Get_Index_Subtype_List (Prefix_Type), 0); + + -- Evaluate slice bounds. + Chap3.Create_Array_Subtype (Slice_Type, True); + + Kind := Get_Object_Kind (Prefix); + + Prefix_Info := Get_Info (Prefix_Type); + Slice_Info := Get_Info (Slice_Type); + + if Slice_Info.Type_Mode = Type_Mode_Array + and then Prefix_Info.Type_Mode = Type_Mode_Array + then + -- 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_First_Element + (Get_Index_Subtype_List (Slice_Type)); + 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. + return Prefix; + 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; + return Lv2M + (New_Slice (M2Lv (Prefix), + Slice_Info.Ortho_Type (Kind), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Off)))), + Slice_Info, + Kind); + end; + end if; + + Slice_Binfo := Get_Info (Get_Base_Type (Slice_Type)); + + -- 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; + + -- Check if not a null slice. + -- FIXME: why ? + --Start_If_Stmt + -- (If_Blk, + -- New_Compare_Op + -- (ON_Neq, + -- Get_Array_Bound_Length (Res, Prefix_Type, 1, Sig), + -- New_Unsigned_Literal (Ghdl_Index_Type, 0), + -- Ghdl_Bool_Type_Node)); + + 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. + Unsigned_Diff := Create_Temp (Ghdl_Index_Type); + 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; + + -- 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 (Slice_Range))); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res_D), + Slice_Info.T.Base_Field (Kind)), + New_Address + (New_Slice (M2Lv (Chap3.Get_Array_Base (Prefix_Var)), + Slice_Info.T.Base_Type (Kind), + New_Obj_Value (Unsigned_Diff)), + Slice_Info.T.Base_Ptr_Type (Kind))); + return Dv2M (Res_D, Slice_Info, Kind); + when Type_Mode_Array + | Type_Mode_Ptr_Array => + Res_L := New_Slice + (M2Lv (Chap3.Get_Array_Base (Prefix_Var)), + Slice_Info.T.Base_Type (Kind), + New_Obj_Value (Unsigned_Diff)); + return Lv2M (Res_L, + True, + Slice_Info.T.Base_Type (Kind), + Slice_Info.T.Base_Ptr_Type (Kind), + Slice_Info, Kind); + when others => + raise Internal_Error; + end case; + + --Finish_If_Stmt (If_Blk); + + end Translate_Slice_Name; + + function Translate_Interface_Name + (Inter : Iir; Info : Ortho_Info_Acc; Kind : Object_Kind_Type) + return Mnode + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Get_Type (Inter)); + 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. + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + -- Parameter is passed by value. + if Info.Interface_Field /= O_Fnode_Null then + -- And by copy. + return Lv2M (New_Selected_Acc_Value + (New_Obj (Info.Interface_Node), + Info.Interface_Field), + Type_Info, Kind); + else + return Dv2M (Info.Interface_Node, Type_Info, Kind); + end if; + when Type_Mode_By_Ref + | Type_Mode_By_Copy => + -- Parameter is passed by reference, dereference it. + return Dp2M (Info.Interface_Node, Type_Info, Kind); + end case; + 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 : Field_Info_Acc; + Kind : Object_Kind_Type; + begin + El_Info := Get_Info (El); + Kind := Get_Object_Kind (Prefix); + return Lo2M (New_Selected_Element (M2Lv (Prefix), + El_Info.Field_Node (Kind)), + Get_Info (Get_Type (El)), Kind); + 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); +-- Pop_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_Constant_Interface_Declaration => +-- return Translate_Formal_Interface_Name +-- (Scope_Type, Scope_Param, Name, Mode_Value); + +-- when Iir_Kind_Signal_Interface_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 : Iir; + Name_Info : Ortho_Info_Acc; + Type_Info : Type_Info_Acc; + begin + Name_Type := Get_Type (Name); + Name_Info := Get_Info (Name); + Type_Info := Get_Info (Name_Type); + 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_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_Ptr_Array + | Type_Mode_Array => + 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_Constant_Interface_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_File_Interface_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Variable_Interface_Declaration => + if Name_Info.Interface_Field /= O_Fnode_Null then + -- Passed via the result record. + return Lv2M + (New_Selected_Element + (New_Acc_Value (New_Obj (Name_Info.Interface_Node)), + Name_Info.Interface_Field), + Type_Info, Mode_Value); + else + return Translate_Interface_Name + (Name, Name_Info, Mode_Value); + end if; + + when Iir_Kind_Signal_Interface_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. + declare + Imp : Iir; + Obj : Iir; + Assoc_Chain : Iir; + begin + Imp := Get_Implementation (Name); + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration + then + -- FIXME : to be done + raise Internal_Error; + else + Assoc_Chain := Canon.Canon_Subprogram_Call (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; + end Chap6; + + package body Chap7 is + function Is_Static_Constant (Decl : Iir_Constant_Declaration) + return Boolean + is + Expr : Iir; + Atype : Iir; + Info : Iir; + begin + if Get_Expr_Staticness (Decl) = Locally then + -- Should be not necessary. + return True; + end if; + + Expr := Get_Default_Value (Decl); + if Expr = Null_Iir then + -- Deferred constant. + return False; + 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 : Natural; + 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 : Natural; + 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 (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 : 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); + 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; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Lit_Type := Get_Type (Str); + Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + + Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); + + 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; + + -- 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 + Var : Var_Acc; + Info : Type_Info_Acc; + Str_Type : Iir; + Res : O_Cnode; + R : O_Enode; + begin + 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; + Str_Type := Get_Type (Str); + 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)); + Free_Var (Var); + return R; + 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_Acc; + Res : O_Cnode; + List : O_Record_Aggr_List; + Bound : Var_Acc; + 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 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 => + return New_Signed_Literal + (Res_Type, Integer_64 (Get_Physical_Value (Expr))); + when Iir_Kind_Unit_Declaration => + return New_Signed_Literal + (Res_Type, + Integer_64 (Get_Value (Get_Physical_Unit_Value (Expr)))); + when Iir_Kind_Physical_Fp_Literal => + return New_Signed_Literal + (Res_Type, + Integer_64 + (Get_Fp_Value (Expr) + * Iir_Fp64 (Get_Value (Get_Physical_Unit_Value + (Get_Unit_Name (Expr)))))); + when others => + Error_Kind ("tranlate_numeric_literal", Expr); + end case; + 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 : Iir; + begin + Expr_Type := Get_Type (Expr); + 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 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 (New_Unsigned_Literal (Ghdl_Index_Type, 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 + Actual, Formal : Iir; + Formal_Base : Iir; + begin + Formal := Get_Formal (Assoc); + 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; + + Formal_Base := Get_Base_Name (Formal); + case Get_Kind (Formal_Base) is + when Iir_Kind_Constant_Interface_Declaration => + return Translate_Expression (Actual, Get_Type (Formal_Base)); + when Iir_Kind_Signal_Interface_Declaration => + return Translate_Implicit_Conv + (M2E (Chap6.Translate_Name (Actual)), + Get_Type (Actual), + Get_Type (Formal_Base), + Mode_Signal); + 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 + Constr : O_Assoc_List; + Assoc : Iir; + Info : Subprg_Info_Acc; + Res : Mnode; + begin + Info := Get_Info (Imp); + + 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 + declare + Prot_Info : Type_Info_Acc; + begin + Prot_Info := Get_Info (Get_Method_Type (Imp)); + Chap2.Add_Subprg_Instance_Assoc + (Constr, Info.Subprg_Instance, + Prot_Info.Ortho_Type (Mode_Value), + M2E (Chap6.Translate_Name (Obj))); + end; + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + -- FIXME: evaluate expression before, because we + -- may allocate objects. + New_Association (Constr, Translate_Association (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + return M2E (Res); + else + return New_Function_Call (Constr); + end if; + end Translate_Function_Call; + + function Translate_Operator_Function_Call + (Imp : Iir; Left : Iir; Right : Iir; Res_Type : Iir) + return O_Enode + is + function Create_Assoc (Actual : Iir; Formal : Iir) + return Iir + is + R : Iir; + begin + R := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Location_Copy (R, Actual); + Set_Actual (R, Actual); + Set_Formal (R, Formal); + return R; + end Create_Assoc; + + Inter : Iir; + El_L : Iir; + El_R : Iir; + Res : O_Enode; + begin + Inter := Get_Interface_Declaration_Chain (Imp); + + El_L := Create_Assoc (Left, Inter); + + if Right /= Null_Iir then + Inter := Get_Chain (Inter); + El_R := Create_Assoc (Right, Inter); + Set_Chain (El_L, El_R); + end if; + + Res := Translate_Function_Call (Imp, El_L, Null_Iir); + + Free_Iir (El_L); + if Right /= Null_Iir then + Free_Iir (El_R); + end if; + + return Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value); + end Translate_Operator_Function_Call; + + function Convert_Constrained_To_Unconstrained + (Expr : O_Enode; Expr_Type : Iir; Atype : Iir; Kind : Object_Kind_Type) + return O_Enode + is + Res : O_Dnode; + Type_Info : Type_Info_Acc; + Expr_Type_Info : Type_Info_Acc; + begin + -- FIXME: to do. + -- Be sure the bounds variable was created. + -- This may be necessary for on-the-fly types, such as strings. + Chap3.Create_Array_Subtype (Expr_Type, True); + + Expr_Type_Info := Get_Info (Expr_Type); + Type_Info := Get_Info (Atype); + Res := Create_Temp (Type_Info.Ortho_Type (Kind)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Type_Info.T.Base_Field (Kind)), + New_Convert_Ov (Expr, Type_Info.T.Base_Ptr_Type (Kind))); + + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Type_Info.T.Bounds_Field (Kind)), + Chap3.Get_Array_Ptr_Bounds_Ptr (O_Lnode_Null, Expr_Type, Kind)); + return L2e_Node (New_Obj (Res), Type_Info, Kind); + end Convert_Constrained_To_Unconstrained; + + function Convert_Array_To_Thin_Array + (Expr : O_Enode; + Expr_Type : Iir; + Atype : Iir; + Is_Sig : Object_Kind_Type) + return O_Enode + is + Ptr : O_Dnode; + Expr_Type_Info : Type_Info_Acc; + Expr_Indexes: Iir_List; + Success_Label, Failure_Label : O_Snode; + begin + Expr_Type_Info := Get_Info (Expr_Type); + Ptr := Create_Temp_Init + (Expr_Type_Info.Ortho_Ptr_Type (Is_Sig), Expr); + + Open_Temp; + -- Check each dimension. + Expr_Indexes := Get_Index_Subtype_List (Expr_Type); + 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_Ptr_Bound_Length (New_Obj (Ptr), + Expr_Type, I, Is_Sig), + Chap6.Get_Array_Bound_Length (O_Lnode_Null, Atype, I, Is_Sig), + Ghdl_Bool_Type)); + end loop; + New_Exit_Stmt (Success_Label); + Finish_Loop_Stmt (Failure_Label); + Chap6.Gen_Bound_Error (Expr_Type); -- FIXME: location. + Finish_Loop_Stmt (Success_Label); + Close_Temp; + + return New_Value + (Chap3.Get_Array_Ptr_Base_Ptr (New_Obj (Ptr), Expr_Type, Is_Sig)); + end Convert_Array_To_Thin_Array; + + -- 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) + return O_Enode + is + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + begin + 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 + Ainfo := Get_Info (Atype); + 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 + | Type_Mode_Ptr_Array => + -- constrained to unconstrained. + return Convert_Constrained_To_Unconstrained + (Expr, Expr_Type, Atype, Is_Sig); + when others => + raise Internal_Error; + end case; + when Type_Mode_Array => + -- X to constrained. + case Einfo.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Ptr_Array => + -- unconstrained to constrained. + return Convert_Array_To_Thin_Array (Expr, Expr_Type, + Atype, Is_Sig); + when Type_Mode_Array => + -- constrained to constrained. + declare + E_List, A_List : Iir_List; + E_El, A_El : Iir; + begin + E_List := Get_Index_Subtype_List (Expr_Type); + A_List := Get_Index_Subtype_List (Atype); + for I in Natural loop + E_El := Get_Nth_Element (E_List, I); + A_El := Get_Nth_Element (A_List, I); + exit when E_El = Null_Iir + and then A_El = Null_Iir; + if Eval_Discrete_Type_Length (E_El) + /= Eval_Discrete_Type_Length (A_El) + then + -- FIXME: generate a bound error ? + -- Even if this is caught at compile-time, + -- the code is not required to run. + raise Internal_Error; + end if; + end loop; + end; + return Expr; + when others => + raise Internal_Error; + end case; + when Type_Mode_Ptr_Array => + case Einfo.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Array + | Type_Mode_Ptr_Array => + return Convert_Array_To_Thin_Array + (Expr, Expr_Type, Atype, Is_Sig); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + 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; + Op : ON_Op_Kind; + 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 => + Op := ON_And; + Invert := False; + Val := 1; + when Iir_Predefined_Bit_Nand + | Iir_Predefined_Boolean_Nand => + Op := ON_And; + Invert := True; + Val := 1; + when Iir_Predefined_Bit_Or + | Iir_Predefined_Boolean_Or => + Op := ON_Or; + Invert := False; + Val := 0; + when Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_Nor => + Op := ON_Or; + 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 : Subprg_Info_Acc; + Constr : O_Assoc_List; + begin + Info := Get_Info (Func); + Start_Association (Constr, Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + return New_Function_Call (Constr); + end Translate_Predefined_Lib_Operator; + + function Translate_Predefined_Array_Operator + (Left, Right : O_Enode; Func : Iir) + return O_Enode + is + Res : O_Dnode; + Constr : O_Assoc_List; + Info : Type_Info_Acc; + Func_Info : Subprg_Info_Acc; + begin + Create_Temp_Stack2_Mark; + Info := Get_Info (Get_Return_Type (Func)); + Res := Create_Temp (Info.Ortho_Type (Mode_Value)); + Func_Info := Get_Info (Func); + Start_Association (Constr, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Func_Info.Subprg_Instance); + New_Association (Constr, + New_Address (New_Obj (Res), + Info.Ortho_Ptr_Type (Mode_Value))); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), Info.Ortho_Ptr_Type (Mode_Value)); + end Translate_Predefined_Array_Operator; + + function Translate_Predefined_Array_Operator_Convert + (Left, Right : O_Enode; Func : Iir; Res_Type : Iir) + return O_Enode + is + Res : O_Enode; + Ret_Type : Iir; + begin + Ret_Type := Get_Return_Type (Func); + Res := Translate_Predefined_Array_Operator (Left, Right, Func); + return Translate_Implicit_Conv (Res, Ret_Type, Res_Type, Mode_Value); + 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) + return O_Enode + is + Arr_El1 : O_Enode; + Arr_El2 : O_Enode; + Ret_Type : Iir; + Res : O_Enode; + Kind : Iir_Predefined_Functions; + begin + Ret_Type := Get_Return_Type (Imp); + Kind := Get_Implicit_Definition (Imp); + 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); + end Translate_Concat_Operator; + + function Translate_Predefined_Operator + (Imp : Iir_Implicit_Function_Declaration; + Left, Right : Iir; + Res_Type : Iir) + return O_Enode + is + Left_Tree : O_Enode; + Right_Tree : O_Enode; + Kind : Iir_Predefined_Functions; + Left_Type : Iir; + Right_Type : Iir; + Res_Otype : O_Tnode; + Op : ON_Op_Kind; + Interface : Iir; + Res : O_Enode; + begin + Kind := Get_Implicit_Definition (Imp); + if Iir_Predefined_Shortcut_P (Kind) then + return Translate_Shortcut_Operator (Imp, Left, Right); + end if; + + Res_Otype := Get_Ortho_Type (Res_Type, Mode_Value); + Interface := Get_Interface_Declaration_Chain (Imp); + if Left = Null_Iir then + Left_Tree := O_Enode_Null; + else + Left_Type := Get_Type (Interface); + 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 (Interface)); + 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); + return Res; + end if; + + case Kind is + when Iir_Predefined_Bit_Xnor + | Iir_Predefined_Boolean_Xnor => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_Xor, Left_Tree, Right_Tree)); + + 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); + + 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_Type_Node), + 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_Type_Node), + 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_Bit_Array_And + | Iir_Predefined_Bit_Array_Or + | Iir_Predefined_Bit_Array_Nand + | Iir_Predefined_Bit_Array_Nor + | Iir_Predefined_Bit_Array_Xor + | Iir_Predefined_Bit_Array_Xnor + | Iir_Predefined_Bit_Array_Not + | Iir_Predefined_Boolean_Array_And + | Iir_Predefined_Boolean_Array_Or + | Iir_Predefined_Boolean_Array_Nand + | Iir_Predefined_Boolean_Array_Nor + | Iir_Predefined_Boolean_Array_Xor + | Iir_Predefined_Boolean_Array_Xnor + | Iir_Predefined_Boolean_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); + + 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 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) + is + T_Info : Type_Info_Acc; + begin + T_Info := Get_Info (Target_Type); + case T_Info.Type_Mode is + when Type_Mode_Scalar => + if not Chap3.Need_Range_Check (Target_Type) then + New_Assign_Stmt (M2Lv (Target), Val); + else + declare + V : O_Dnode; + begin + Open_Temp; + V := Create_Temp_Init (T_Info.Ortho_Type (Mode_Value), + Val); + Chap3.Check_Range (V, Expr, Target_Type); + New_Assign_Stmt (M2Lv (Target), New_Obj_Value (V)); + Close_Temp; + end; + end if; + when Type_Mode_Acc + | Type_Mode_File => + New_Assign_Stmt (M2Lv (Target), Val); + when Type_Mode_Fat_Acc => + declare + T, E : O_Dnode; + begin + T := Create_Temp_Ptr + (Target_Type, M2Lv (Target), Mode_Value); + E := Create_Temp_Init + (T_Info.Ortho_Ptr_Type (Mode_Value), Val); + Copy_Fat_Access (T, E, Target_Type); + end; + 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, M2Lp (T), Mode_Value, + Get_Type (Expr), New_Obj (E), Mode_Value, + Null_Iir); + Chap3.Translate_Object_Copy + (T, New_Obj_Value (E), Target_Type); + end; + when Type_Mode_Array + | Type_Mode_Ptr_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); + 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 (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_Ptr_Array + | 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 + 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; + + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + -- Continue below. + null; + when Iir_Kind_String_Literal => + declare + Literal_List : Iir_List; + Lit : Iir; + Pos : O_Enode; + Ptr : String_Fat_Acc; + Len : Natural; + begin + Ptr := Get_String_Fat_Acc (Aggr); + Len := Get_String_Length (Aggr); + Literal_List := Get_Enumeration_Literal_List + (Get_Base_Type (Expr_Type)); + for I in 1 .. Len loop + Lit := Find_Name_In_List + (Literal_List, Name_Table.Get_Identifier (Ptr (I))); + if I = 1 then + Pos := New_Obj_Value (Var_Index); + else + Pos := New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Var_Index), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Natural'Pos (I - 1)))); + end if; + New_Assign_Stmt + (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, Pos)), + New_Lit (Get_Ortho_Expr (Lit))); + end loop; + New_Assign_Stmt + (New_Obj (Var_Index), + New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Var_Index), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Natural'Pos (Len))))); + end; + return; + when Iir_Kind_Bit_String_Literal => + raise Internal_Error; + when others => + raise Internal_Error; + end case; + + 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 (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 (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_Expression (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 (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 (New_Unsigned_Literal (Ghdl_Index_Type, + 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 (El) /= Null_Iir then + El_Assoc := Get_Associated (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 (New_Unsigned_Literal (Ghdl_Index_Type, + 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 : Iir := Get_Type (Aggr); + Aggr_Base_Type : Iir_Record_Type_Definition := + Get_Base_Type (Aggr_Type); + Nbr_El : Iir_Index32 := + Get_Number_Element_Declaration (Aggr_Base_Type); + + -- 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 (Get_Element_Position (El)) := True; + end Set_El; + + Assoc : Iir; + El : Iir; + N_El_Expr : Iir; + begin + Open_Temp; + Targ := Stabilize (Target); + El := Get_Element_Declaration_Chain (Aggr_Base_Type); + Assoc := Get_Association_Choices_Chain (Aggr); + while Assoc /= Null_Iir loop + N_El_Expr := Get_Associated (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 (El); + El := Get_Chain (El); + when Iir_Kind_Choice_By_Name => + Set_El (Get_Name (Assoc)); + El := Null_Iir; + when Iir_Kind_Choice_By_Others => + El := Get_Element_Declaration_Chain (Aggr_Base_Type); + for J in Set_Array'Range loop + if not Set_Array (J) then + Set_El (El); + end if; + El := Get_Chain (El); + end loop; + pragma Assert (El = Null_Iir); + 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 : Iir; + Base : Mnode; + Bounds : Mnode; + Var_Index : O_Dnode; + Targ : Mnode; + Tinfo : Type_Info_Acc; + + Range_Ptr : Mnode; + Rinfo : Type_Info_Acc; + Bt : Iir; + + function Check_Value + (Lval : Iir; Lop : ON_Op_Kind; Rval : Iir; Rop : ON_Op_Kind) + 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 (Range_Ptr)), + Ghdl_Bool_Type); + R := New_Compare_Op + (Rop, + New_Lit (Translate_Static_Expression (Rval, Bt)), + M2E (Chap3.Range_To_Right (Range_Ptr)), + Ghdl_Bool_Type); + return New_Dyadic_Op (ON_Or, L, R); + end Check_Value; + + Index_List : Iir_List; + Targ_Index_List : Iir_List; + Subtarg_Type : Iir; + Subaggr_Type : Iir; + L, H : Iir; + Max : Iir_Int32; + Has_Others : Boolean; + + Aggr_Info : Iir_Aggregate_Info; + + Var_Err : O_Dnode; + E : O_Enode; + If_Blk : O_If_Block; + Op : ON_Op_Kind; + begin + Tinfo := Get_Info (Target_Type); + Open_Temp; + -- FIXME: to be removed ? + --Chap3.Translate_Type_Definition (Aggr_Type); + Targ := Stabilize (Target); + Base := Stabilize (Chap3.Get_Array_Base (Targ)); + Bounds := Stabilize (Chap3.Get_Array_Bounds (Targ)); + + -- Check type + Aggr_Type := Get_Type (Aggr); + Index_List := Get_Index_Subtype_List (Aggr_Type); + Targ_Index_List := Get_Index_Subtype_List (Target_Type); + Aggr_Info := Get_Aggregate_Info (Aggr); + for I in Natural loop + Subaggr_Type := Get_Nth_Element (Index_List, I); + exit when Subaggr_Type = Null_Iir; + Subtarg_Type := Get_Nth_Element (Targ_Index_List, I); + + Bt := Get_Base_Type (Subaggr_Type); + Rinfo := Get_Info (Bt); + + if Get_Type_Staticness (Subaggr_Type) /= Locally then + -- Aggregate has dynamic bounds. + if Subaggr_Type /= Subtarg_Type then + -- And it is not the same as the target. + -- Must be checked. + + 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; + end if; + else + -- 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); + Max := Get_Aggr_Max_Length (Aggr_Info); + L := Get_Aggr_Low_Limit (Aggr_Info); + + if Max > 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 + 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); + else + E := Check_Value (L, ON_Neq, H, ON_Neq); + 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); + else + E := Check_Value (H, ON_Neq, L, ON_Neq); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + Finish_If_Stmt (If_Blk); + -- If L and H are greather than the maximum length, + -- then there is no need to check with max. + if Iir_Int32 (Eval_Pos (H) - Eval_Pos (L) + 1) >= Max then + Max := 0; + end if; + end if; + if Max > 0 then + 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 (Max))), + 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 (New_Unsigned_Literal (Ghdl_Index_Type, 0))); + Translate_Array_Aggregate_Gen + (Base, Bounds, Aggr, Aggr_Type, 1, Var_Index); + Close_Temp; + end Translate_Array_Aggregate; + + procedure Translate_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir) + is + Aggr_Type : Iir; + El : Iir; + begin + Aggr_Type := Get_Type (Aggr); + 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; + P_Type : Iir; + P_Info : Type_Info_Acc; + D_Type : Iir; + D_Info : Type_Info_Acc; + R : Mnode; + Rtype : O_Tnode; + begin + P_Type := Get_Type (Expr); + P_Info := Get_Info (P_Type); + D_Type := Get_Designated_Type (P_Type); + D_Info := Get_Info (D_Type); + -- Compute the expression. + Val := Translate_Expression (Get_Expression (Expr), D_Type); + -- Allocate memory for the object. + case P_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, + M2Addr (Chap3.Get_Array_Bounds (Val_M))); + Val := M2E (Val_M); + Rtype := P_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, O_Enode_Null); + Rtype := P_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 + Sub_Type : Iir; + Bounds : O_Enode; + Res : Mnode; + Rtype : O_Tnode; + P_Type : Iir; + P_Info : Type_Info_Acc; + D_Type : Iir; + D_Info : Type_Info_Acc; + begin + P_Type := Get_Type (Expr); + P_Info := Get_Info (P_Type); + D_Type := Get_Designated_Type (P_Type); + D_Info := Get_Info (D_Type); + 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_Expression (Expr); + Chap3.Create_Array_Subtype (Sub_Type, True); + Bounds := M2E (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 := O_Enode_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 : Type_Info_Acc; + Expr_Info : Type_Info_Acc; + begin + Res_Info := Get_Info (Res_Type); + Expr_Info := Get_Info (Expr_Type); + case Res_Info.Type_Mode is + when Type_Mode_Array => + declare + E : O_Dnode; + begin + E := Create_Temp_Init (Expr_Info.Ortho_Ptr_Type (Mode_Value), + Expr); + Chap3.Check_Array_Match (Res_Type, O_Lnode_Null, Mode_Value, + Expr_Type, New_Obj (E), Mode_Value, + Loc); + return New_Convert_Ov + (New_Value (Chap3.Get_Array_Ptr_Base_Ptr + (New_Obj (E), Expr_Type, Mode_Value)), + Res_Info.Ortho_Ptr_Type (Mode_Value)); + end; + when Type_Mode_Fat_Array => + declare + Res : O_Dnode; + E : O_Dnode; + begin + Res := Create_Temp (Res_Info.Ortho_Type (Mode_Value)); + Open_Temp; + E := Create_Temp_Init (Expr_Info.Ortho_Ptr_Type (Mode_Value), + Expr); + -- Convert base. + New_Assign_Stmt + (New_Selected_Element + (New_Obj (Res), Res_Info.T.Base_Field (Mode_Value)), + New_Value (Chap3.Get_Array_Ptr_Base_Ptr + (New_Obj (E), Expr_Type, Mode_Value))); + -- Copy subtype bounds. + New_Assign_Stmt + (New_Selected_Element + (New_Obj (Res), Res_Info.T.Bounds_Field (Mode_Value)), + Chap3.Get_Array_Bounds_Ptr (O_Lnode_Null, Expr_Type, + Mode_Value)); + -- Check array match. + Chap3.Check_Array_Match (Res_Type, New_Obj (Res), Mode_Value, + Expr_Type, New_Obj (E), Mode_Value, + Loc); + Close_Temp; + return New_Address + (New_Obj (Res), Res_Info.Ortho_Ptr_Type (Mode_Value)); + 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 : Type_Info_Acc; + begin + Res_Info := Get_Info (Res_Type); + case Get_Kind (Res_Type) is + when Iir_Kinds_Scalar_Type_Definition => + -- If res_type = expr_type, do not convert. + -- FIXME: range check ? + return New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); + when Iir_Kind_Array_Subtype_Definition => + return Translate_Array_Subtype_Conversion + (Expr, Expr_Type, Res_Type, Loc); + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Unconstrained_Array_Subtype_Definition => + return Translate_Fat_Array_Type_Conversion + (Expr, Expr_Type, Res_Type, Loc); + 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 : O_Dnode; + Res_Ptr : O_Dnode; + E : O_Dnode; + Bounds : O_Dnode; + Res_Indexes : Iir_List; + Expr_Indexes : Iir_List; + R_El : Iir; + E_El : Iir; + Res_Info : Type_Info_Acc; + Expr_Info : Type_Info_Acc; + begin + Res_Info := Get_Info (Res_Type); + Expr_Info := Get_Info (Expr_Type); + Res := Create_Temp (Res_Info.Ortho_Type (Mode_Value)); + Bounds := Create_Temp (Res_Info.T.Bounds_Type); + Open_Temp; + Res_Ptr := Create_Temp_Ptr + (Res_Info.Ortho_Ptr_Type (Mode_Value), New_Obj (Res)); + E := Create_Temp_Init (Expr_Info.Ortho_Ptr_Type (Mode_Value), Expr); + -- Set base. + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Res_Info.T.Base_Field (Mode_Value)), + New_Convert_Ov (New_Value (Chap3.Get_Array_Ptr_Base_Ptr + (New_Obj (E), Expr_Type, Mode_Value)), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + -- Set bounds. + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Res_Info.T.Bounds_Field (Mode_Value)), + New_Address (New_Obj (Bounds), Res_Info.T.Bounds_Ptr_Type)); + -- Convert bounds. + Res_Indexes := Get_Index_Subtype_List (Res_Type); + Expr_Indexes := Get_Index_Subtype_List (Expr_Type); + for I in Natural loop + R_El := Get_Nth_Element (Res_Indexes, I); + E_El := Get_Nth_Element (Expr_Indexes, I); + exit when R_El = Null_Iir; + declare + Rb_Ptr : O_Dnode; + Eb_Ptr : O_Dnode; + Rr_Info : Type_Info_Acc; + Er_Info : Type_Info_Acc; + begin + Open_Temp; + Rr_Info := Get_Info (R_El); + Rb_Ptr := Create_Temp_Init + (Rr_Info.T.Range_Ptr_Type, + Chap3.Get_Array_Ptr_Range_Ptr (New_Obj (Res_Ptr), + Res_Type, I + 1, + Mode_Value)); + Er_Info := Get_Info (Get_Base_Type (E_El)); + Eb_Ptr := Create_Temp_Init + (Er_Info.T.Range_Ptr_Type, + Chap3.Get_Array_Ptr_Range_Ptr (New_Obj (E), Expr_Type, I + 1, + Mode_Value)); + -- Convert left and right. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Rb_Ptr), + Rr_Info.T.Range_Left), + Translate_Type_Conversion + (New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), + Er_Info.T.Range_Left), + E_El, R_El, Loc)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Rb_Ptr), + Rr_Info.T.Range_Right), + Translate_Type_Conversion + (New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), + Er_Info.T.Range_Right), + E_El, R_El, Loc)); + -- Copy Dir and Length. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Rb_Ptr), + Rr_Info.T.Range_Dir), + New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), + Er_Info.T.Range_Dir)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Rb_Ptr), + Rr_Info.T.Range_Length), + New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), + Er_Info.T.Range_Length)); + Close_Temp; + end; + end loop; + Close_Temp; + return New_Address (New_Obj (Res), + Res_Info.Ortho_Ptr_Type (Mode_Value)); + 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_Node), + 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 Tinfo.C /= null 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_Node)); + 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; + Unit_Type : Type_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. + Unit_Type := Get_Info (Expr_Type); + 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; + Unit_Type : Type_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. + Unit_Type := Get_Info (Expr_Type); + 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); + Res := Translate_Implicit_Conv + (Res, Expr_Type, Res_Type, Mode_Value); + return Res; + + when Iir_Kind_Aggregate => + declare + Aggr_Type : Iir; + Tinfo : Type_Info_Acc; + Mres : Mnode; + begin + if Rtype = Null_Iir then + raise Internal_Error; + end if; + + -- Extract the type of the aggregate. + if Get_Kind (Rtype) /= Iir_Kind_Array_Type_Definition then + Aggr_Type := Rtype; + else + Aggr_Type := Expr_Type; + if Get_Kind (Expr_Type) + = Iir_Kind_Array_Subtype_Definition + then + Chap3.Create_Array_Subtype (Expr_Type, True); + end if; + end if; + + -- FIXME: this may be not necessary + Tinfo := Get_Info (Aggr_Type); + + -- The result area has to be created + if Tinfo.C /= null 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); + end if; + return Res; + end; + + when Iir_Kind_Null_Literal => + declare + L : O_Dnode; + Otype : O_Tnode; + B : Type_Info_Acc; + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Info (Expr_Type); + Otype := Tinfo.Ortho_Type (Mode_Value); + 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_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); + return Translate_Implicit_Conv + (Res, Expr_Type, Rtype, Mode_Value); + + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_File_Interface_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 => + declare + L : Mnode; + Expr_Type_Info : Type_Info_Acc; + begin + L := Chap6.Translate_Name (Expr); + + Expr_Type_Info := Get_Info (Expr_Type); + Res := M2E (L); + if Get_Object_Kind (L) = Mode_Signal then + Res := Translate_Signal (Res, Expr_Type); + end if; + end; + if Rtype /= Null_Iir then + Res := Translate_Implicit_Conv + (Res, Expr_Type, Rtype, Mode_Value); + end if; + return Res; + + 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); + 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); + 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); + end; + else + Assoc_Chain := Canon.Canon_Subprogram_Call (Expr); + Res := Translate_Function_Call + (Imp, Assoc_Chain, Get_Method_Object (Expr)); + return Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value); + 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); + return Translate_Implicit_Conv + (Res, Expr_Type, Res_Type, Mode_Value); + 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 => + return Translate_Implicit_Conv + (Chap14.Translate_Image_Attribute (Expr), + String_Type_Definition, Res_Type, Mode_Value); + 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 => + return Chap14.Translate_Last_Value_Attribute (Expr); + + when Iir_Kind_High_Type_Attribute => + return Chap14.Translate_High_Type_Attribute (Get_Type (Expr)); + when Iir_Kind_Low_Type_Attribute => + return Chap14.Translate_Low_Type_Attribute (Get_Type (Expr)); + when Iir_Kind_Left_Type_Attribute => + return Chap14.Translate_Left_Type_Attribute (Get_Type (Expr)); + when Iir_Kind_Right_Type_Attribute => + return Chap14.Translate_Right_Type_Attribute (Get_Type (Expr)); + + when Iir_Kind_Last_Event_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Event_Node); + when Iir_Kind_Last_Active_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Active_Node); + + when Iir_Kind_Driving_Value_Attribute => + return Chap14.Translate_Driving_Value_Attribute (Expr); + when Iir_Kind_Driving_Attribute => + return Chap14.Translate_Driving_Attribute (Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + return Chap14.Translate_Path_Instance_Name_Attribute (Expr); + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Translate_Expression (Get_Named_Entity (Expr), Rtype); + + when others => + Error_Kind ("translate_expression", Expr); + end case; + end Translate_Expression; + +-- procedure Translate_Range_Expression +-- (Res : O_Lnode; Expr : Iir; Range_Type : Iir) +-- is +-- T_Info : Type_Info_Acc; +-- begin +-- T_Info := Get_Info (Range_Type); +-- Open_Temp; +-- New_Assign_Stmt +-- (New_Selected_Element (Res, T_Info.T.Range_Left), +-- Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); +-- New_Assign_Stmt +-- (New_Selected_Element (Res, T_Info.T.Range_Right), +-- Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); +-- New_Assign_Stmt (New_Selected_Element (Res, T_Info.T.Range_Dir), +-- Chap7.Translate_Static_Range_Dir (Expr)); +-- if T_Info.T.Range_Length /= O_Fnode_Null then +-- Open_Temp; +-- New_Assign_Stmt (New_Selected_Element (Res, T_Info.T.Range_Length), +-- Chap7.Translate_Range_Expression_Length (Expr)); +-- Close_Temp; +-- end if; +-- Close_Temp; +-- end Translate_Range_Expression; + + procedure Translate_Range_Expression_Ptr + (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir) + is + T_Info : Type_Info_Acc; + 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 + 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; + 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_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; + + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + 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 + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (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); + --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, Get_Identifier ("l_len"), + O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Get_Identifier ("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_Ptr_Bound_Length + (New_Obj (L), Arr_Type, 1, Mode_Value)); + New_Assign_Stmt + (New_Obj (Var_R_Len), + Chap6.Get_Array_Ptr_Bound_Length + (New_Obj (R), Arr_Type, 1, Mode_Value)); + -- 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), + New_Value + (New_Indexed_Element + (New_Acc_Value (Chap3.Get_Array_Ptr_Base_Ptr + (New_Obj (L), Arr_Type, Mode_Value)), + New_Obj_Value (Var_I)))); + New_Assign_Stmt + (New_Obj (Var_R_El), + New_Value + (New_Indexed_Element + (New_Acc_Value (Chap3.Get_Array_Ptr_Base_Ptr + (New_Obj (R), Arr_Type, Mode_Value)), + 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 + | Type_Mode_Ptr_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); + Rc := Translate_Implicit_Conv + (M2E (R), Etype, Base_Type, Mode_Value); + Func := Find_Predefined_Function + (Base_Type, Iir_Predefined_Array_Equality); + return Translate_Predefined_Lib_Operator (Lc, Rc, Func); + end; + + when Type_Mode_Record => + declare + Func : Iir; + begin + Func := Find_Predefined_Function + (Get_Base_Type (Etype), Iir_Predefined_Record_Equality); + return Translate_Predefined_Lib_Operator + (M2E (L), M2E (R), Func); + end; + + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Equality; + + procedure Translate_Predefined_Array_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + Indexes : Iir_List; + Nbr_Indexes : Natural; + If_Blk : O_If_Block; + Var_I : O_Dnode; + Var_Len : O_Dnode; + Label : O_Snode; + Le, Re : Mnode; + El_Type : Iir; + begin + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + El_Type := Get_Element_Subtype (Arr_Type); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + Indexes := Get_Index_Subtype_List (Arr_Type); + Nbr_Indexes := Get_Nbr_Elements (Indexes); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + -- for each dimension: if length mismatch: return false + for I in 1 .. Nbr_Indexes loop + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Neq, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, Arr_Type, I))), + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, Arr_Type, I))), + Std_Boolean_Type_Node)); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + end loop; + + -- for each element: if element is not equal, return false + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Obj (Var_Len), + Chap3.Get_Array_Length (L, Arr_Type)); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + -- If the end of the array is reached, return TRUE. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Len), + Ghdl_Bool_Type)); + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (If_Blk); + Open_Temp; + Le := Chap3.Index_Base (Chap3.Get_Array_Base (L), Arr_Type, + New_Obj_Value (Var_I)); + Re := Chap3.Index_Base (Chap3.Get_Array_Base (R), Arr_Type, + New_Obj_Value (Var_I)); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, Translate_Equality (Le, Re, El_Type))); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Equality; + + procedure Translate_Predefined_Record_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Rec_Type : Iir_Record_Type_Definition; + Rec_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + If_Blk : O_If_Block; + Le, Re : Mnode; + + El : Iir_Element_Declaration; + begin + Rec_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info := Get_Info (Rec_Type); + Id := Get_Identifier (Get_Type_Declarator (Rec_Type)); + Rec_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Rec_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Rec_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + -- Compare each element. + El := Get_Element_Declaration_Chain (Rec_Type); + while El /= Null_Iir loop + 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; + El := Get_Chain (El); + end loop; + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Record_Equality; + + procedure Translate_Predefined_Array_Array_Concat (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + + -- Info for the array type. + Info : Type_Info_Acc; + + -- Info for the index type. + Iinfo : Type_Info_Acc; + Index_Type : Iir; + + Index_Otype : O_Tnode; + Id : Name_Id; + Interface_List : O_Inter_List; + Var_Res, Var_L, Var_R : O_Dnode; + Res, L, R : Mnode; + Var_Length, Var_L_Len, Var_R_Len : O_Dnode; + Var_Bounds, Var_Right : O_Dnode; + V_Bounds : Mnode; + If_Blk : O_If_Block; + begin + Arr_Type := Get_Return_Type (Subprg); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + F_Info.Use_Stack2 := True; + + -- Create function. + Start_Procedure_Decl + (Interface_List, Create_Identifier (Id, "_CONCAT"), Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a concatenation returns its value without + -- the use of the record. + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Index_Type := Get_First_Element (Get_Index_Subtype_List (Arr_Type)); + Iinfo := Get_Info (Index_Type); + Index_Otype := Iinfo.Ortho_Type (Mode_Value); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_L_Len, Get_Identifier ("l_len"), O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Get_Identifier ("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 (New_Unsigned_Literal (Ghdl_Index_Type, + 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 (New_Unsigned_Literal + (Ghdl_Index_Type, 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); + 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); + 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)), + New_Address (New_Slice (M2Lv (Chap3.Get_Array_Base (Res)), + Info.T.Base_Type (Mode_Value), + New_Obj_Value (Var_L_Len)), + Info.T.Base_Ptr_Type (Mode_Value))); + Chap3.Translate_Object_Copy + (Var_Arr, New_Obj_Value (Var_R), Arr_Type); + Close_Temp; + end; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Array_Concat; + + procedure Translate_Predefined_Array_Logical (Subprg : Iir) + is + 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; + Id : Name_Id; + 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 + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (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); + --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_Bit_Array_And + | Iir_Predefined_Boolean_Array_And => + Name := Create_Identifier (Id, "_AND"); + Op := ON_And; + Do_Invert := False; + when Iir_Predefined_Bit_Array_Or + | Iir_Predefined_Boolean_Array_Or => + Name := Create_Identifier (Id, "_OR"); + Op := ON_Or; + Do_Invert := False; + when Iir_Predefined_Bit_Array_Nand + | Iir_Predefined_Boolean_Array_Nand => + Name := Create_Identifier (Id, "_NAND"); + Op := ON_And; + Do_Invert := True; + when Iir_Predefined_Bit_Array_Nor + | Iir_Predefined_Boolean_Array_Nor => + Name := Create_Identifier (Id, "_NOR"); + Op := ON_Or; + Do_Invert := True; + when Iir_Predefined_Bit_Array_Xor + | Iir_Predefined_Boolean_Array_Xor => + Name := Create_Identifier (Id, "_XOR"); + Op := ON_Xor; + Do_Invert := False; + when Iir_Predefined_Bit_Array_Xnor + | Iir_Predefined_Boolean_Array_Xnor => + Name := Create_Identifier (Id, "_XNOR"); + Op := ON_Xor; + Do_Invert := True; + when Iir_Predefined_Bit_Array_Not + | Iir_Predefined_Boolean_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_Ptr_Bound_Length + (New_Obj (L), Arr_Type, 1, Mode_Value)); + -- 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_Ptr_Bound_Length + (New_Obj (R), Arr_Type, 1, Mode_Value), + 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_Ptr_Bounds_Ptr + (New_Obj (L), Arr_Type, Mode_Value)); + New_Assign_Stmt + (New_Obj (Var_Base), M2Addr (Chap3.Get_Array_Base (Res))); + New_Assign_Stmt + (New_Obj (Var_L_Base), + New_Value (Chap3.Get_Array_Ptr_Base_Ptr + (New_Obj (L), Arr_Type, Mode_Value))); + if not Is_Monadic then + New_Assign_Stmt + (New_Obj (Var_R_Base), + New_Value (Chap3.Get_Array_Ptr_Base_Ptr + (New_Obj (R), Arr_Type, 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 + -- * 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)); + -- 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 + Init_Var (Var_I); + 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); + New_Else_Stmt (If_Blk1); + -- * else + -- * R := LENGTH + New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); + Finish_If_Stmt (If_Blk1); + + -- 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 (New_Unsigned_Literal (Ghdl_Index_Type, 0)); + else + Tmp := New_Dyadic_Op + (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, 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 (New_Unsigned_Literal + (Ghdl_Index_Type, 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 + -- * 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 : Iir; + Val1 : Mnode; + begin + Open_Temp; + Val1 := Stabilize (Val); + El := Get_Element_Declaration_Chain + (Get_Base_Type (Val_Type)); + while El /= Null_Iir loop + Translate_Rw + (Chap6.Translate_Selected_Element (Val1, El), + Get_Type (El), Proc); + El := Get_Chain (El); + end loop; + Close_Temp; + end; + when Type_Mode_Array + | Type_Mode_Ptr_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_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_Type_Node); + else + Start_Procedure_Decl (Inter_List, Name, Global_Storage); + end if; + Chap2.Create_Subprg_Instance (Inter_List, Subprg); + + New_Interface_Decl + (Inter_List, Var_File, Get_Identifier ("FILE"), + Ghdl_File_Index_Type); + New_Interface_Decl + (Inter_List, Var_Val, Get_Identifier ("VAL"), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + Finish_Subprogram_Decl (Inter_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + Push_Local_Factory; + + Var := Dp2M (Var_Val, Tinfo, Mode_Value); + + case Kind is + when Iir_Predefined_Write => + if Tinfo.Type_Mode = Type_Mode_Fat_Array then + declare + Var_Max : O_Dnode; + begin + Open_Temp; + Var_Max := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Array_Length (Var, Etype)); + Translate_Rw_Length (Var_Max, Ghdl_Write_Scalar); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Max, Ghdl_Write_Scalar); + Close_Temp; + end; + else + Translate_Rw (Var, Etype, Ghdl_Write_Scalar); + end if; + when Iir_Predefined_Read => + Translate_Rw (Var, Etype, Ghdl_Read_Scalar); + + when Iir_Predefined_Read_Length => + declare + Var_Len : O_Dnode; + begin + Open_Temp; + Var_Len := Create_Temp (Ghdl_Index_Type); + Translate_Rw_Length (Var_Len, Ghdl_Read_Scalar); + + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Gt, + New_Obj_Value (Var_Len), + Chap3.Get_Array_Length (Var, Etype), + Ghdl_Bool_Type), + Subprg, 1); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Len, Ghdl_Read_Scalar); + New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_Len), + Std_Integer_Type_Node)); + Close_Temp; + end; + when others => + raise Internal_Error; + end case; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_File_Subprogram; + + procedure Init_Implicit_Subprogram_Infos + (Infos : out Implicit_Subprogram_Infos) is + begin + -- Be independant of declaration order since the same subprogram + -- may be used for several implicit operators (eg. array comparaison) + Infos.Arr_Eq_Info := null; + Infos.Arr_Cmp_Info := null; + Infos.Arr_Concat_Info := null; + Infos.Rec_Eq_Info := null; + Infos.Arr_Shl_Info := null; + Infos.Arr_Sha_Info := null; + Infos.Arr_Rot_Info := null; + end Init_Implicit_Subprogram_Infos; + + procedure Translate_Implicit_Subprogram + (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos) + is + Kind : Iir_Predefined_Functions; + begin + Kind := Get_Implicit_Definition (Subprg); + if Predefined_To_Onop (Kind) /= ON_Nil then + -- Intrinsic. + return; + end if; + + case Kind is + when Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality => + -- Intrinsic. + null; + when Iir_Predefined_Deallocate => + -- Intrinsic. + null; + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Integer_Exp => + -- Intrinsic. + 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 => + 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 => + 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_Bit_Array_And + | Iir_Predefined_Bit_Array_Or + | Iir_Predefined_Bit_Array_Nand + | Iir_Predefined_Bit_Array_Nor + | Iir_Predefined_Bit_Array_Xor + | Iir_Predefined_Bit_Array_Xnor + | Iir_Predefined_Bit_Array_Not + | Iir_Predefined_Boolean_Array_And + | Iir_Predefined_Boolean_Array_Or + | Iir_Predefined_Boolean_Array_Nand + | Iir_Predefined_Boolean_Array_Nor + | Iir_Predefined_Boolean_Array_Xor + | Iir_Predefined_Boolean_Array_Xnor + | Iir_Predefined_Boolean_Array_Not => + Translate_Predefined_Array_Logical (Subprg); + + 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_Physical_Identity => + 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 => + null; + + when Iir_Predefined_File_Open + | Iir_Predefined_File_Open_Status + | Iir_Predefined_File_Close + | 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_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 + Expr : Iir; + Ret_Type : Iir; + Ret_Info : Type_Info_Acc; + Val : O_Dnode; + Area : Mnode; + Subprg_Info : Ortho_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 + Subprg_Info := Get_Info (Chap2.Current_Subprogram); + + Expr := Get_Expression (Stmt); + 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; + begin + V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); + Open_Temp; + New_Assign_Stmt + (New_Obj (V), Chap7.Translate_Expression (Expr, Ret_Type)); + Close_Temp; + Chap3.Check_Range (V, Expr, Ret_Type); + Gen_Return_Value (New_Obj_Value (V)); + 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. + Area := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); + Val := Create_Temp_Init + (Ret_Info.Ortho_Ptr_Type (Mode_Value), + Chap7.Translate_Expression (Expr, Ret_Type)); + Chap3.Translate_Object_Allocation + (Area, Alloc_Return, Ret_Type, + Chap3.Get_Array_Ptr_Bounds_Ptr + (New_Obj (Val), Ret_Type, Mode_Value)); + Chap3.Translate_Object_Copy + (Area, New_Obj_Value (Val), Ret_Type); + Gen_Return; + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Ptr_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_Acc; + Constraint : Iir; + Cond_To, Cond_Downto : O_Enode; + Cond_Dir : O_Enode; + 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; + 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); + Open_Temp; + 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)); + Close_Temp; + -- Before starting the loop, check wether there will be at least + -- one iteration. + Cond_To := New_Compare_Op + (ON_Le, New_Value (Get_Var (Var_Iter)), + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Right), + Ghdl_Bool_Type); + Cond_Dir := 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); + Cond_To := New_Dyadic_Op (ON_And, Cond_Dir, Cond_To); + Cond_Downto := New_Compare_Op + (ON_Ge, New_Value (Get_Var (Var_Iter)), + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Right), + Ghdl_Bool_Type); + Cond_Dir := 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_Downto_Node), + Ghdl_Bool_Type); + Cond_Downto := New_Dyadic_Op (ON_And, Cond_Dir, Cond_Downto); + Cond := New_Dyadic_Op (ON_Or, Cond_To, Cond_Downto); + 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_Acc; + Constraint : Iir; + 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. + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Get_Direction (Constraint), + 1, Iter_Base_Type); + 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; + + pragma Unreferenced (Start_For_Loop, Finish_For_Loop); + + Current_Loop : Iir := Null_Iir; + + procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) + is + Iterator : Iir; + Iter_Type : Iir; + Iter_Base_Type : Iir; + Iter_Type_Info : Type_Info_Acc; + Loop_Info : Loop_Info_Acc; + It_Info : Ortho_Info_Acc; + O_Range : O_Dnode; + O_Right : O_Dnode; + Cond_To, Cond_Downto : O_Enode; + Cond_Dir : O_Enode; + Cond : O_Enode; + Dir : Iir_Direction; + Op : ON_Op_Kind; + If_Blk, If_Blk1 : O_If_Block; + Var_Iter : Var_Acc; + Constraint : Iir; + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + Start_Declare_Stmt; + Iterator := Get_Iterator_Scheme (Stmt); + Iter_Type := Get_Type (Iterator); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + + 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; + + 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); + O_Right := Create_Temp (Iter_Type_Info.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Obj (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; + Cond := New_Compare_Op + (Op, New_Value (Get_Var (Var_Iter)), New_Obj_Value (O_Right), + Ghdl_Bool_Type); + else + O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type); + New_Assign_Stmt (New_Obj (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 (O_Range), Iter_Type_Info.T.Range_Left)); + -- Before starting the loop, check wether there will be at least + -- one iteration. + Cond_To := New_Compare_Op + (ON_Le, New_Value (Get_Var (Var_Iter)), + Get_Range_Ptr_Field_Value (New_Obj (O_Range), + Iter_Type_Info.T.Range_Right), + Ghdl_Bool_Type); + Cond_Dir := New_Compare_Op + (ON_Eq, + Get_Range_Ptr_Field_Value (New_Obj (O_Range), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type); + Cond_To := New_Dyadic_Op (ON_And, Cond_Dir, Cond_To); + Cond_Downto := New_Compare_Op + (ON_Ge, New_Value (Get_Var (Var_Iter)), + Get_Range_Ptr_Field_Value (New_Obj (O_Range), + Iter_Type_Info.T.Range_Right), + Ghdl_Bool_Type); + Cond_Dir := New_Compare_Op + (ON_Eq, + Get_Range_Ptr_Field_Value (New_Obj (O_Range), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_Downto_Node), + Ghdl_Bool_Type); + Cond_Downto := New_Dyadic_Op (ON_And, Cond_Dir, Cond_Downto); + Cond := New_Dyadic_Op (ON_Or, Cond_To, Cond_Downto); + end if; + + Start_If_Stmt (If_Blk, Cond); + + -- Start loop. + -- There are two blocks: one for the exit, one for the next. + Loop_Info := Add_Info (Stmt, Kind_Loop); + Start_Loop_Stmt (Loop_Info.Label_Exit); + Start_Loop_Stmt (Loop_Info.Label_Next); + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + New_Exit_Stmt (Loop_Info.Label_Next); + Finish_Loop_Stmt (Loop_Info.Label_Next); + + -- Check end of loop. + -- Equality is necessary and enough. + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + Cond := New_Obj_Value (O_Right); + else + Cond := Get_Range_Ptr_Field_Value + (New_Obj (O_Range), Iter_Type_Info.T.Range_Right); + end if; + Gen_Exit_When (Loop_Info.Label_Exit, + New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)), + Cond, Ghdl_Bool_Type)); + + -- Update the iterator. + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Dir, 1, Iter_Base_Type); + else + Start_If_Stmt + (If_Blk1, New_Compare_Op + (ON_Eq, + Get_Range_Ptr_Field_Value (New_Obj (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 (Loop_Info.Label_Exit); + Finish_If_Stmt (If_Blk); + Close_Temp; + Finish_Declare_Stmt; + + Free_Info (Stmt); + 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 : Iir; + If_Blk : O_If_Block; + Info : Loop_Info_Acc; + Loop_Stmt : Iir; + begin + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); + end if; + Loop_Stmt := Get_Loop (Stmt); + if Loop_Stmt = Null_Iir then + Loop_Stmt := Current_Loop; + 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 (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 (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 : Iir_Element_Declaration; + Elem : Iir; + begin + El := Get_Element_Declaration_Chain (Get_Base_Type (Targ_Type)); + 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 := El; + El := Get_Chain (El); + when Iir_Kind_Choice_By_Name => + Elem := Get_Name (Aggr_El); + El := Null_Iir; + when others => + Error_Kind ("translate_variable_rec_aggr", Aggr_El); + end case; + Translate_Variable_Aggregate_Assignment + (Get_Associated (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 : Iir; + Targ_Type : Iir; + Expr : Iir; + Targ_Node : Mnode; + begin + Target := Get_Target (Stmt); + Targ_Type := Get_Type (Target); + Expr := Get_Expression (Stmt); + 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_Address (New_Obj (Ghdl_Assert_Default_Report), + 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; + + procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) + is + Expr : Iir; + If_Blk : O_If_Block; + begin + 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, Ghdl_Assert_Failed, 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, Ghdl_Assert_Failed, 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; + + function Translate_Simple_String_Choice + (Expr : O_Dnode; + Val : Iir; + 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)), + Chap7.Translate_Expression (Val, Get_Type (Val))); + Func_Info := Get_Info (Func); + Start_Association (Assoc, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); + New_Association (Assoc, New_Obj_Value (Expr)); + New_Association + (Assoc, New_Address (New_Obj (Val_Node), + Tinfo.Ortho_Ptr_Type (Mode_Value))); + return New_Function_Call (Assoc); + end Translate_Simple_String_Choice; + + procedure Translate_String_Choice + (Expr : O_Dnode; + Val_Node : O_Dnode; + Tinfo : Type_Info_Acc; + Func : Iir; + Cond_Var : O_Dnode; + Choice : Iir) + is + Cond : O_Enode; + If_Blk : O_If_Block; + Stmt_Chain : Iir; + First : Boolean; + Ch : Iir; + begin + if Choice = Null_Iir then + return; + end if; + + First := True; + Stmt_Chain := Get_Associated (Choice); + Ch := Choice; + loop + case Get_Kind (Ch) is + when Iir_Kind_Choice_By_Expression => + Cond := Translate_Simple_String_Choice + (Expr, Get_Expression (Ch), 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 (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 + (Expr, Val_Node, Tinfo, Func, Cond_Var, Ch); + Finish_If_Stmt (If_Blk); + end Translate_String_Choice; + + -- Case statement whose expression is an unidim array. + procedure Translate_String_Case_Statement (Stmt : Iir_Case_Statement) + is + Expr : Iir; + Expr_Type : Iir; + Base_Type : Iir; + -- Node containing the address of the selector. + Expr_Node : O_Dnode; + -- Node containing the current choice. + C_Node : O_Dnode; + Tinfo : Type_Info_Acc; + + Choices_Chain : Iir; + Func : Iir; + Cond_Var : O_Dnode; + 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); + + Expr_Node := Create_Temp_Init + (Tinfo.Ortho_Ptr_Type (Mode_Value), + Chap7.Translate_Expression (Expr, Base_Type)); + 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))); + + Cond_Var := Create_Temp (Std_Boolean_Type_Node); + + Func := Chap7.Find_Predefined_Function + (Base_Type, Iir_Predefined_Array_Equality); + + Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); + Translate_String_Choice + (Expr_Node, C_Node, + Tinfo, Func, Cond_Var, Choices_Chain); + end Translate_String_Case_Statement; + + 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_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_Expression (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 + Translate_String_Case_Statement (Stmt); + 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 (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); + if Get_Associated (Choice) /= Null_Iir then + raise Internal_Error; + end if; + 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))); + 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_Ptr_Array + | Type_Mode_Fat_Array => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + New_Procedure_Call (Assocs); + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Write_Procedure_Call; + + procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) + is + F_Assoc : Iir; + Value_Assoc : Iir; + Value : Mnode; + Formal_Type : Iir; + Tinfo : Type_Info_Acc; + Assocs : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + begin + F_Assoc := Param_Chain; + Value_Assoc := Get_Chain (Param_Chain); + Formal_Type := Get_Type (Get_Formal (Value_Assoc)); + Tinfo := Get_Info (Formal_Type); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + Open_Temp; + Start_Association (Assocs, Ghdl_Read_Scalar); + -- compute file parameter (get an index) + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + -- value + Value := Chap6.Translate_Name (Get_Actual (Value_Assoc)); + New_Association + (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + Close_Temp; + when Type_Mode_Array + | Type_Mode_Ptr_Array + | Type_Mode_Record => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc))); + New_Procedure_Call (Assocs); + when Type_Mode_Fat_Array => + declare + Length_Assoc : Iir; + Length : Mnode; + begin + Length_Assoc := Get_Chain (Value_Assoc); + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + Length := Chap6.Translate_Name (Get_Actual (Length_Assoc)); + New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs)); + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Read_Procedure_Call; + + procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) + is + Kind : Iir_Predefined_Functions; + Imp : Iir; + Param_Chain : Iir; + begin + Imp := Get_Implementation (Call); + Kind := Get_Implicit_Definition (Imp); + Param_Chain := Get_Parameter_Association_Chain (Call); + 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 + N_Param : Iir; + Status_Param : Iir; + File_Param : Iir; + Name_Param : Iir; + Kind_Param : Iir; + Constr : O_Assoc_List; + Status : Mnode; + begin + Status_Param := Get_Actual (Param_Chain); + 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_Type)); + end; + + when Iir_Predefined_File_Close => + declare + File_Param : Iir; + Constr : O_Assoc_List; + begin + File_Param := Get_Actual (Param_Chain); + 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 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_Info : Type_Info_Acc; + Res : O_Dnode; + Imp : Iir; + begin + if Conv = Null_Iir then + return M2E (Src); +-- case Get_Type_Info (Dest).Type_Mode is +-- when Type_Mode_Thin => +-- New_Assign_Stmt (M2Lv (Dest), M2E (Src)); +-- when Type_Mode_Fat_Acc => +-- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src)); +-- when others => +-- raise Internal_Error; +-- end case; + else + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + -- Call conversion function. + Imp := Get_Implementation (Conv); + Conv_Info := Get_Info (Imp); + Start_Association (Constr, Conv_Info.Ortho_Func); + + if Conv_Info.Res_Interface /= O_Dnode_Null then + Res := Create_Temp (Conv_Info.Res_Record_Type); + -- Composite result. + New_Association + (Constr, + New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Conv_Info.Subprg_Instance); + + New_Association (Constr, M2E (Src)); + + Res_Info := Get_Info (Get_Return_Type (Imp)); + 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 : Iir := Get_Parameter_Association_Chain (Stmt); + Nbr_Assoc : 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 : Iir; + Info : Subprg_Info_Acc; + 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; + Atype_Info : Type_Info_Acc; + Formal_Info : Ortho_Info_Acc; + Val : O_Enode; + Param : Mnode; + Last_Individual : Natural; + Ptr : O_Lnode; + In_Conv : Iir; + Out_Conv : Iir; + Formal_Object_Kind : Object_Kind_Type; + Bounds : O_Enode; + Obj : Iir; + begin + Imp := Get_Implementation (Stmt); + Info := Get_Info (Imp); + + -- 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); + Base_Formal := Get_Base_Name (Formal); + Formal_Type := Get_Type (Formal); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Signal_Interface_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 := M2E (Chap3.Get_Array_Type_Bounds (Actual_Type)); + Param := Create_Temp (Ftype_Info, Mode_Value); + Chap3.Translate_Object_Allocation + (Param, Alloc_Stack, Formal_Type, Bounds); + else + Param := Create_Temp (Ftype_Info, Mode_Value); + 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 Out_Conv = Null_Iir then + -- Arguments may be assigned if there is an in conversion, + -- or no out conversion. + -- We try to assign even OUT argument, to avoid + -- uninitialized values. + Ptr := New_Selected_Element + (New_Obj (Res), Formal_Info.Interface_Field); + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + Chap7.Translate_Assign + (Param, + Do_Conversion (In_Conv, Act, Params (Pos)), + In_Conv, --FIXME: may be null. + Formal_Type); + 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_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + -- No conversion here. + E_Params (Pos) := Chap7.Translate_Expression + (Act, Formal_Type); + when Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Signal_Interface_Declaration => + Param := Chap6.Translate_Name (Act); + -- Atype may not have been set (eg: slice). + Atype_Info := Get_Info (Actual_Type); + 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)); + 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_Constant_Interface_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); + 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 + declare + Prot_Info : Type_Info_Acc; + begin + Prot_Info := Get_Info (Get_Method_Type (Imp)); + Chap2.Add_Subprg_Instance_Assoc + (Constr, Info.Subprg_Instance, + Prot_Info.Ortho_Type (Mode_Value), + M2E (Chap6.Translate_Name (Obj))); + end; + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + -- Parameters. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Formal := Get_Formal (El); + Base_Formal := Get_Base_Name (Formal); + 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_Signal_Interface_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_Base_Name (Formal); + Formal_Type := Get_Type (Formal); + Ftype_Info := Get_Info (Formal_Type); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Variable_Interface_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); + 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_Conv, --FIXME: use real expr. + Get_Type (Get_Actual (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)); + 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. + 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_B2 => + Subprg := Ghdl_Signal_Simple_Assign_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Simple_Assign_E8; + 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 (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)); + 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_Prepare_Data_Composite (Val : O_Enode; +-- Targ_Type : Iir) is +-- begin +-- null; +-- end Gen_Simple_Signal_Prepare_Data_Composite; + +-- function Gen_Simple_Signal_Update_Data_Array (Val : O_Enode; +-- Targ_Type : Iir; +-- Index : O_Lnode) +-- return O_Enode +-- is +-- Base : O_Lnode; +-- begin +-- Base := Chap3.Get_Array_Base +-- (New_Access_Element (Val), Targ_Type, Mode_Value); +-- return New_Value (New_Indexed_Element (Base, New_Value (Index))); +-- end Gen_Simple_Signal_Update_Data_Array; + +-- function Gen_Simple_Signal_Update_Data_Record +-- (Val : O_Enode; Targ_Type : Iir; El : Iir_Element_Declaration) +-- return O_Enode +-- is +-- begin +-- return New_Value (New_Selected_Element +-- (New_Access_Element (Val), +-- Get_Info (El).Field_Node (Mode_Value))); +-- end Gen_Simple_Signal_Update_Data_Record; + + 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_B2 => + Subprg := Ghdl_Signal_Start_Assign_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Start_Assign_E8; + 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 (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)); + 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_B2 => + Subprg := Ghdl_Signal_Next_Assign_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Next_Assign_E8; + 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; + -- FIXME: check in range. + 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 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_Composite, + 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 + Sub_Aggr : Mnode; + El : Iir; + Index_List : Iir_List; + Nbr_Dim : Natural; + Expr : Iir; + begin + Index_List := Get_Index_Subtype_List (Target_Type); + Nbr_Dim := Get_Nbr_Elements (Index_List); + 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 (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_Decl : Iir_Element_Declaration; + Element : Iir_Element_Declaration; + begin + El_Decl := Get_Element_Declaration_Chain + (Get_Base_Type (Target_Type)); + 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 := El_Decl; + El_Decl := Get_Chain (El_Decl); + when Iir_Kind_Choice_By_Name => + Element := Get_Name (Aggr_El); + El_Decl := Null_Iir; + 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 (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; + + procedure Translate_Signal_Assignment_Statement (Stmt : Iir) + is + Target : Iir; + Target_Type : Iir; + We : Iir_Waveform_Element; + Targ : Mnode; + Val : O_Enode; + Value : Iir; + begin + Target := Get_Target (Stmt); + Target_Type := Get_Type (Target); + 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 + Targ := Chap6.Translate_Name (Target); + if Get_Object_Kind (Targ) /= Mode_Signal then + raise Internal_Error; + end if; + end if; + + We := Get_Waveform_Chain (Stmt); + 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); + 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_Type); + After_Time := Create_Temp (Std_Time_Type); + Del := Get_Time (We); + if Del = Null_Iir then + New_Assign_Stmt + (New_Obj (After_Time), + New_Lit (New_Signed_Literal (Std_Time_Type, 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_Type, 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_Type); + New_Assign_Stmt + (New_Obj (After_Time), + Chap7.Translate_Expression (Get_Time (We), + Time_Type_Definition)); + Value := Get_We_Value (We); + 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 + Assocs : Iir; + Call : Iir_Procedure_Call; + Imp : Iir; + begin + Call := Get_Procedure_Call (Stmt); + Assocs := Canon.Canon_Subprogram_Call (Call); + Imp := Get_Implementation (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; + end Chap8; + + package body Chap9 is + procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc) + is + Inter_List : O_Inter_List; + Instance : O_Dnode; + Info : Proc_Info_Acc; + begin + Info := Get_Info (Proc); + 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. + Push_Scope (Base.Block_Decls_Type, Instance); + Chap8.Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Proc)); + Pop_Scope (Base.Block_Decls_Type); + 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; + Push_Scope (Base.Block_Decls_Type, Instance); + Open_Temp; + New_Return_Stmt (Chap7.Translate_Expression (Guard_Expr)); + Close_Temp; + Pop_Scope (Base.Block_Decls_Type); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Implicit_Guard_Signal; + + procedure Translate_Component_Instantiation_Statement (Inst : Iir) + is + Comp : Iir; + Field : O_Fnode; + Info : Block_Info_Acc; + Comp_Info : Comp_Info_Acc; + begin + Comp := Get_Instantiated_Unit (Inst); + Info := Add_Info (Inst, Kind_Block); + if Get_Kind (Comp) = Iir_Kind_Component_Declaration then + -- Via a component declaration. + Comp_Info := Get_Info (Comp); + Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Comp_Info.Comp_Type); + Info.Block_Decls_Type := Comp_Info.Comp_Type; + Info.Block_Decls_Ptr_Type := Comp_Info.Comp_Ptr_Type; + Info.Block_Parent_Field := Field; + else + -- Direct instantiation. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Rtis.Ghdl_Component_Link_Type); + Info.Block_Decls_Type := O_Tnode_Null; + end if; + end Translate_Component_Instantiation_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 => + declare + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + Itype : O_Tnode; + Field : O_Fnode; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + -- Start child record. + Push_Instance_Factory (O_Tnode_Null); + Info := Add_Info (El, Kind_Process); + Chap4.Translate_Declaration_Chain (El); + Pop_Instance_Factory (Itype); + New_Type_Decl (Create_Identifier ("INSTTYPE"), Itype); + Pop_Identifier_Prefix (Mark); + -- Create a field in the parent record. + Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), Itype); + -- Set info in child record. + Info.Process_Decls_Type := Itype; + Info.Process_Parent_Field := Field; + end; + 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; + Field : O_Fnode; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + Info := Add_Info (El, Kind_Block); + Chap1.Start_Block_Decl (El); + Push_Instance_Factory (Info.Block_Decls_Type); + + 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_Decls_Type); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Decls_Type); + -- Set info in child record. + Info.Block_Parent_Field := Field; + end; + when Iir_Kind_Generate_Statement => + declare + Info : Block_Info_Acc; + Mark : Id_Mark_Type; + Scheme : Iir; + Iter_Type : Iir; + It_Info : Ortho_Info_Acc; + begin + Scheme := Get_Generation_Scheme (El); + + 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_Decls_Type); + + -- 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_Decls_Type); + + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + -- Create array type of block_decls_type + Info.Block_Decls_Array_Type := New_Array_Type + (Info.Block_Decls_Type, 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_Type : O_Tnode; + Comp_Field : O_Fnode) + is + begin + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Element (Get_Instance_Ref (Ref_Type), Comp_Field), + Rtis.Ghdl_Component_Link_Stmt), + New_Lit (Rtis.Get_Context_Rti (Stmt))); + end Set_Component_Link; + + Info : Block_Info_Acc; + + Comp : Iir; + Comp_Info : Comp_Info_Acc; + Parent_Info : Block_Info_Acc; + Inter_List : O_Inter_List; + Instance : O_Dnode; + begin + Info := Get_Info (Stmt); + 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; + Push_Scope (Base.Block_Decls_Type, Instance); + + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + Parent_Info := Get_Info (Get_Parent (Stmt)); + Comp := Get_Instantiated_Unit (Stmt); + if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then + -- This is a direct instantiation. + Set_Component_Link (Parent_Info.Block_Decls_Type, + Info.Block_Parent_Field); + Translate_Entity_Instantiation (Comp, Stmt, Stmt, Null_Iir); + else + Comp_Info := Get_Info (Comp); + Push_Scope (Comp_Info.Comp_Type, Info.Block_Parent_Field, + Parent_Info.Block_Decls_Type); + + -- Set the link from component declaration to component + -- instantiation statement. + Set_Component_Link (Comp_Info.Comp_Type, Comp_Info.Comp_Link); + + Chap5.Elab_Map_Aspect (Stmt, Comp); + + Pop_Scope (Comp_Info.Comp_Type); + end if; + Pop_Scope (Base.Block_Decls_Type); + 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 + Stmt : Iir; + Mark : Id_Mark_Type; + Block_Info : Block_Info_Acc; + Base_Info : Block_Info_Acc; + begin + Base_Info := Get_Info (Base_Block); + + Chap4.Translate_Declaration_Chain_Subprograms (Block, Base_Block); + + Block_Info := Get_Info (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 => + declare + Info : Proc_Info_Acc; + begin + Info := Get_Info (Stmt); + Push_Scope (Info.Process_Decls_Type, + Info.Process_Parent_Field, + Block_Info.Block_Decls_Type); + Chap4.Translate_Declaration_Chain_Subprograms + (Stmt, Base_Block); + Translate_Process_Statement (Stmt, Base_Info); + Pop_Scope (Info.Process_Decls_Type); + end; + when Iir_Kind_Component_Instantiation_Statement => + Chap4.Translate_Association_Subprograms + (Get_Port_Map_Aspect_Chain (Stmt), + Base_Block, + Get_Entity_From_Entity_Aspect + (Get_Instantiated_Unit (Stmt))); + Translate_Component_Instantiation_Subprogram + (Stmt, Base_Info); + when Iir_Kind_Block_Statement => + declare + Info : Block_Info_Acc; + Guard : Iir; + Hdr : Iir; + begin + Info := Get_Info (Stmt); + Push_Scope (Info.Block_Decls_Type, + Info.Block_Parent_Field, + Block_Info.Block_Decls_Type); + Guard := Get_Guard_Decl (Stmt); + if Guard /= Null_Iir then + Translate_Implicit_Guard_Signal (Guard, Base_Info); + end if; + Hdr := Get_Block_Header (Stmt); + if Hdr /= Null_Iir then + Chap4.Translate_Association_Subprograms + (Get_Port_Map_Aspect_Chain (Hdr), + Base_Block, Null_Iir); + end if; + Translate_Block_Subprograms (Stmt, Base_Block); + Pop_Scope (Info.Block_Decls_Type); + end; + when Iir_Kind_Generate_Statement => + declare + Info : Block_Info_Acc; + Prev_Instance : Chap2.Subprg_Instance_Stack; + begin + Info := Get_Info (Stmt); + Chap2.Save_Subprg_Instance (Prev_Instance); + Chap2.Push_Subprg_Instance (Info.Block_Decls_Type, + Info.Block_Decls_Ptr_Type, + Wki_Instance); + Push_Scope_Via_Field_Ptr (Base_Info.Block_Decls_Type, + Info.Block_Origin_Field, + Info.Block_Decls_Type); + Translate_Block_Subprograms (Stmt, Stmt); + Pop_Scope (Base_Info.Block_Decls_Type); + Chap2.Pop_Subprg_Instance (Wki_Instance); + Chap2.Restore_Subprg_Instance (Prev_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_List (List : Iir_List) + is + El : Iir; + Atype : Iir; + Info : Type_Info_Acc; + 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; + 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_Signal_Interface_Declaration + | Iir_Kind_Guard_Signal_Declaration => + exit; + when others => + Error_Kind ("destroy_types_in_list", 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, False); + Clear_Info (Atype); + end if; + end if; + end loop; + end loop; + end Destroy_Types_In_List; + + -- PROC: the process to be elaborated + -- BLOCK_INFO: info for the block containing the process + -- BASE_INFO: info for the global block + procedure Elab_Process (Proc : Iir; + Block_Info : Block_Info_Acc; + Base_Info : Block_Info_Acc) + is + Is_Sensitized : Boolean; + Subprg : O_Dnode; + Constr : O_Assoc_List; + Info : Proc_Info_Acc; + List : Iir_List; + Final : Boolean; + begin + New_Debug_Line_Stmt (Get_Line_Number (Proc)); + + Is_Sensitized := + Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement; + Info := Get_Info (Proc); + + -- Set instance name. + Push_Scope (Info.Process_Decls_Type, + Info.Process_Parent_Field, + Block_Info.Block_Decls_Type); + + -- 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_Decls_Type), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Process_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Proc); +-- New_Association +-- (Constr, +-- New_Address (New_Selected_Element +-- (Get_Instance_Ref (Info.Process_Decls_Type), +-- Info.Process_Name), +-- Ghdl_Instance_Name_Acc)); + New_Procedure_Call (Constr); + + -- First elaborate declarations since a driver may depend on + -- an alias declaration. + Chap4.Elab_Declaration_Chain (Proc, Final); + + List := Get_Driver_List (Proc); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Driver); + + if Is_Sensitized then + List := Get_Sensitivity_List (Proc); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + end if; + + Pop_Scope (Info.Process_Decls_Type); + end Elab_Process; + + 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_Decls_Type), 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_Unit := 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 + (Get_Library_Unit (Entity_Unit)); + end if; + Config := Null_Iir; + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Library_Unit (Get_Configuration (Aspect)); + Entity_Unit := Get_Entity (Config); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + when others => + Error_Kind ("translate_entity_instantiation", Aspect); + end case; + Entity := Get_Library_Unit (Entity_Unit); + 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_Declaration + 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 : 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_Type : O_Tnode; 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_Type), + 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_Type), + 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 : Comp_Info_Acc; + begin + Comp_Info := Get_Info (Parent); + Set_Links (Comp_Info.Comp_Type, Comp_Info.Comp_Link); + end; + when Iir_Kind_Component_Instantiation_Statement => + -- Direct instantiation. + declare + Parent_Info : Block_Info_Acc; + begin + Parent_Info := Get_Info (Get_Parent (Parent)); + Set_Links (Parent_Info.Block_Decls_Type, + Get_Info (Parent).Block_Parent_Field); + end; + when others => + Error_Kind ("translate_entity_instantiation(1)", Parent); + end case; + end; + + Push_Scope (Entity_Info.Block_Decls_Type, Var_Sub); + Chap5.Elab_Map_Aspect (Mapping, Entity); + Pop_Scope (Entity_Info.Block_Decls_Type); + + -- 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 : Iir; + Info : Block_Info_Acc; + Var : O_Dnode; + Blk : O_If_Block; + V : O_Lnode; + Parent_Info : Block_Info_Acc; + Base_Info : Block_Info_Acc; + begin + Parent_Info := Get_Info (Parent); + Base_Info := Get_Info (Base_Block); + Scheme := Get_Generation_Scheme (Stmt); + Info := Get_Info (Stmt); + 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 (New_Sizeof (Info.Block_Decls_Type, + Ghdl_Index_Type)), + 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_Decls_Type); + 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 + Push_Scope (Info.Block_Decls_Type, Var); + Push_Scope_Via_Field_Ptr (Base_Info.Block_Decls_Type, + Info.Block_Origin_Field, + Info.Block_Decls_Type); + Elab_Block_Declarations (Stmt, Stmt); + Pop_Scope (Base_Info.Block_Decls_Type); + Pop_Scope (Info.Block_Decls_Type); + 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 : Iir; + Iter_Type : Iir; + Iter_Base_Type : Iir; + Iter_Type_Info : Type_Info_Acc; + Info : Block_Info_Acc; + Var_Inst : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + V : O_Lnode; + Var : O_Dnode; + Parent_Info : Block_Info_Acc; + Base_Info : Block_Info_Acc; + Range_Ptr : O_Dnode; + begin + Parent_Info := Get_Info (Parent); + Base_Info := Get_Info (Base_Block); + + Scheme := Get_Generation_Scheme (Stmt); + Iter_Type := Get_Type (Scheme); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + Info := Get_Info (Stmt); + + 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 (New_Sizeof (Info.Block_Decls_Type, + Ghdl_Index_Type))), + Info.Block_Decls_Array_Ptr_Type)); + + -- Add a link to child in parent. + V := Get_Instance_Ref (Parent_Info.Block_Decls_Type); + 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 + Push_Scope (Info.Block_Decls_Type, Var); + Push_Scope_Via_Field_Ptr (Base_Info.Block_Decls_Type, + Info.Block_Origin_Field, + Info.Block_Decls_Type); + -- 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); + + Pop_Scope (Base_Info.Block_Decls_Type); + Pop_Scope (Info.Block_Decls_Type); + + 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_B2 => + Init_Subprg := Ghdl_Signal_Init_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Init_Subprg := Ghdl_Signal_Init_E8; + 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 + Block_Info : Block_Info_Acc; + Base_Info : Block_Info_Acc; + Stmt : Iir; + Final : Boolean; + begin + Block_Info := Get_Info (Block); + Base_Info := Get_Info (Base_Block); + + 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_Declaration => + null; + when Iir_Kind_Block_Statement => + declare + Header : Iir_Block_Header; + Guard : Iir; + begin + Guard := Get_Guard_Decl (Block); + if Guard /= Null_Iir then + New_Debug_Line_Stmt (Get_Line_Number (Guard)); + Elab_Implicit_Guard_Signal (Block, Base_Info); + end if; + Header := Get_Block_Header (Block); + 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; + + Chap4.Elab_Declaration_Chain (Block, Final); + + 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, Block_Info, Base_Info); + when Iir_Kind_Component_Instantiation_Statement => + declare + Info : Block_Info_Acc; + Constr : O_Assoc_List; + begin + Info := Get_Info (Stmt); + Start_Association (Constr, Info.Block_Elab_Subprg); + New_Association + (Constr, Get_Instance_Access (Base_Block)); + New_Procedure_Call (Constr); + end; + --Elab_Component_Instantiation (Stmt, Block_Info); + when Iir_Kind_Block_Statement => + declare + Info : Block_Info_Acc; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Info := Get_Info (Stmt); + Push_Scope (Info.Block_Decls_Type, + Info.Block_Parent_Field, + Block_Info.Block_Decls_Type); + Elab_Block_Declarations (Stmt, Base_Block); + Pop_Scope (Info.Block_Decls_Type); + Pop_Identifier_Prefix (Mark); + end; + when Iir_Kind_Generate_Statement => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + if Get_Kind (Get_Generation_Scheme (Stmt)) + = Iir_Kind_Iterator_Declaration + then + Elab_Iterative_Generate_Statement + (Stmt, Block, Base_Block); + else + Elab_Conditionnal_Generate_Statement + (Stmt, Block, Base_Block); + end if; + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("elab_block_declarations", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Elab_Block_Declarations; + end Chap9; + + package body Chap10 is + -- Identifiers. + -- The following functions are helpers to create ortho identifiers. + Identifier_Buffer : String (1 .. 512); + Identifier_Len : Natural := 0; + Identifier_Start : Natural := 1; + Identifier_Local : Local_Identifier_Type := 0; + + + Inst_Build : Inst_Build_Acc := null; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object => Inst_Build_Type, Name => Inst_Build_Acc); + + procedure Set_Global_Storage (Storage : O_Storage) is + begin + Global_Storage := Storage; + end Set_Global_Storage; + + procedure Pop_Build_Instance + is + Old : Inst_Build_Acc; + begin + Old := Inst_Build; + Identifier_Start := Old.Prev_Id_Start; + Inst_Build := Old.Prev; + Unchecked_Deallocation (Old); + end Pop_Build_Instance; + +-- procedure Push_Global_Factory (Storage : O_Storage) +-- is +-- Inst : Inst_Build_Acc; +-- begin +-- if Inst_Build /= null then +-- raise Internal_Error; +-- end if; +-- Inst := new Inst_Build_Type (Global); +-- Inst.Prev := Inst_Build; +-- Inst_Build := Inst; +-- Global_Storage := Storage; +-- end Push_Global_Factory; + +-- procedure Pop_Global_Factory is +-- begin +-- if Inst_Build.Kind /= Global then +-- raise Internal_Error; +-- end if; +-- Pop_Build_Instance; +-- Global_Storage := O_Storage_Private; +-- end Pop_Global_Factory; + + procedure Push_Instance_Factory (Instance_Type : O_Tnode) + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null and then Inst_Build.Kind /= Instance then + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Instance); + Inst.Prev := Inst_Build; + + Inst.Prev_Id_Start := Identifier_Start; + Identifier_Start := Identifier_Len + 1; + + if Instance_Type /= O_Tnode_Null then + Start_Uncomplete_Record_Type (Instance_Type, Inst.Elements); + else + Start_Record_Type (Inst.Elements); + end if; + Inst.Vars := null; + Inst_Build := Inst; + end Push_Instance_Factory; + + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode + is + Res : O_Fnode; + begin + New_Record_Field (Inst_Build.Elements, Res, Name, Ftype); + return Res; + end Add_Instance_Factory_Field; + + procedure Pop_Instance_Factory (Instance_Type : out O_Tnode) + is + Res : O_Tnode; + V : Var_Acc; + begin + if Inst_Build.Kind /= Instance then + -- Not matching. + raise Internal_Error; + end if; + Finish_Record_Type (Inst_Build.Elements, Res); + -- Set type of all variable declared in this instance. + V := Inst_Build.Vars; + while V /= null loop + V.I_Type := Res; + V := V.I_Link; + end loop; + Pop_Build_Instance; + Instance_Type := Res; + end Pop_Instance_Factory; + + procedure Push_Local_Factory + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null + and then (Inst_Build.Kind /= Global and Inst_Build.Kind /= Local) + then + -- Cannot create a local factory on an instance. + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Kind => Local); + Inst.Prev := Inst_Build; + Inst.Prev_Global_Storage := Global_Storage; + + Inst.Prev_Id_Start := Identifier_Start; + Identifier_Start := Identifier_Len + 1; + + Inst_Build := Inst; + case Global_Storage is + when O_Storage_Public => + Global_Storage := O_Storage_Private; + when O_Storage_Private + | O_Storage_External => + null; + when O_Storage_Local => + raise Internal_Error; + end case; + end Push_Local_Factory; + + -- Return TRUE is the current scope is local. + function Is_Local_Scope return Boolean is + begin + if Inst_Build = null then + return False; + end if; + case Inst_Build.Kind is + when Local + | Instance => + return True; + when Global => + return False; + end case; + end Is_Local_Scope; + + procedure Pop_Local_Factory is + begin + if Inst_Build.Kind /= Local then + -- Not matching. + raise Internal_Error; + end if; + Global_Storage := Inst_Build.Prev_Global_Storage; + Pop_Build_Instance; + end Pop_Local_Factory; + + type Scope_Type; + type Scope_Acc is access Scope_Type; + type Scope_Type is record + Is_Ptr : Boolean; + Stype : O_Tnode; + Field : O_Fnode; + Parent : O_Tnode; + Prev : Scope_Acc; + end record; + type Scope_Var_Type; + type Scope_Var_Acc is access Scope_Var_Type; + type Scope_Var_Type is record + Svtype : O_Tnode; + Var : O_Dnode; + Prev : Scope_Var_Acc; + end record; + + Scopes : Scope_Acc := null; + -- Chained list of unused scopes, in order to reduce number of + -- dynamic allocation. + Scopes_Old : Scope_Acc := null; + + Scopes_Var : Scope_Var_Acc := null; + -- Chained list of unused var_scopes, to reduce number of allocations. + Scopes_Var_Old : Scope_Var_Acc := null; + + -- Get a scope, either from the list of free scope or by allocation. + function Get_A_Scope return Scope_Acc is + Res : Scope_Acc; + begin + if Scopes_Old /= null then + Res := Scopes_Old; + Scopes_Old := Scopes_Old.Prev; + else + Res := new Chap10.Scope_Type; + end if; + return Res; + end Get_A_Scope; + + procedure Push_Scope (Scope_Type : O_Tnode; + Scope_Field : O_Fnode; Scope_Parent : O_Tnode) + is + Res : Scope_Acc; + begin + Res := Get_A_Scope; + Res.all := (Is_Ptr => False, + Stype => Scope_Type, + Field => Scope_Field, + Parent => Scope_Parent, + Prev => Scopes); + Scopes := Res; + end Push_Scope; + + procedure Push_Scope_Via_Field_Ptr + (Scope_Type : O_Tnode; + Scope_Field : O_Fnode; Scope_Parent : O_Tnode) + is + Res : Scope_Acc; + begin + Res := Get_A_Scope; + Res.all := (Is_Ptr => True, + Stype => Scope_Type, + Field => Scope_Field, + Parent => Scope_Parent, + Prev => Scopes); + Scopes := Res; + end Push_Scope_Via_Field_Ptr; + + procedure Push_Scope (Scope_Type : O_Tnode; Scope_Param : O_Dnode) + is + Res : Scope_Var_Acc; + begin + if Scopes_Var_Old /= null then + Res := Scopes_Var_Old; + Scopes_Var_Old := Res.Prev; + else + Res := new Scope_Var_Type; + end if; + Res.all := (Svtype => Scope_Type, + Var => Scope_Param, + Prev => Scopes_Var); + Scopes_Var := Res; + end Push_Scope; + + procedure Pop_Scope (Scope_Type : O_Tnode) + is + Old : Scope_Acc; + Var_Old : Scope_Var_Acc; + begin + -- Search in var scope. + if Scopes_Var /= null and then Scopes_Var.Svtype = Scope_Type then + Var_Old := Scopes_Var; + Scopes_Var := Var_Old.Prev; + Var_Old.Prev := Scopes_Var_Old; + Scopes_Var_Old := Var_Old; + elsif Scopes.Stype /= Scope_Type then + -- Bad pop order. + raise Internal_Error; + else + Old := Scopes; + Scopes := Old.Prev; + Old.Prev := Scopes_Old; + Scopes_Old := Old; + end if; + end Pop_Scope; + + procedure Push_Scope_Soft (Scope_Type : O_Tnode; Scope_Param : O_Dnode) + is + begin + if Scope_Type /= O_Tnode_Null then + Push_Scope (Scope_Type, Scope_Param); + end if; + end Push_Scope_Soft; + + procedure Pop_Scope_Soft (Scope_Type : O_Tnode) + is + begin + if Scope_Type /= O_Tnode_Null then + Pop_Scope (Scope_Type); + end if; + end Pop_Scope_Soft; + + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Acc + is + Var : O_Dnode; + begin + New_Var_Decl (Var, Name, Storage, Vtype); + return new Var_Type'(Kind => Var_Global, E => Var); + end Create_Global_Var; + + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Acc + is + Res : O_Dnode; + begin + New_Const_Decl (Res, Name, Storage, Vtype); + if Storage /= O_Storage_External + and then Initial_Value /= O_Cnode_Null + then + Start_Const_Value (Res); + Finish_Const_Value (Res, Initial_Value); + end if; + return new Var_Type'(Kind => Var_Global, E => Res); + end Create_Global_Const; + + procedure Define_Global_Const (Const : Var_Acc; Val : O_Cnode) is + begin + Start_Const_Value (Const.E); + Finish_Const_Value (Const.E, Val); + end Define_Global_Const; + + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Acc + is + Res : O_Dnode; + Field : O_Fnode; + V : Var_Acc; + K : Inst_Build_Kind_Type; + begin + if Inst_Build = null then + K := Global; + else + K := Inst_Build.Kind; + end if; + case K is + when Global => + -- The global scope is in use... + return Create_Global_Var (Name.Id, Vtype, Storage); + when Local => + -- It is always possible to create a variable in a local scope. + -- Create a var. + New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype); + return new Var_Type'(Kind => Var_Local, E => Res); + when Instance => + -- Create a field. + New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype); + V := new Var_Type'(Kind => Var_Scope, I_Field => Field, + I_Type => O_Tnode_Null, + I_Link => Inst_Build.Vars); + Inst_Build.Vars := V; + return V; + end case; + end Create_Var; + + function Find_Scope_Type (Stype : O_Tnode) return O_Lnode + is + S : Scope_Acc; + Sv : Scope_Var_Acc; + begin + -- Find in var. + Sv := Scopes_Var; + while Sv /= null loop + if Sv.Svtype = Stype then + return New_Acc_Value (New_Obj (Sv.Var)); + end if; + Sv := Sv.Prev; + end loop; + + -- Find in fields. + S := Scopes; + while S /= null loop + if S.Stype = Stype then + if S.Is_Ptr then + return New_Access_Element + (New_Value + (New_Selected_Element (Find_Scope_Type (S.Parent), + S.Field))); + else + return New_Selected_Element + (Find_Scope_Type (S.Parent), S.Field); + end if; + end if; + S := S.Prev; + end loop; + + -- Not found. + raise Internal_Error; + end Find_Scope_Type; + + function Get_Instance_Access (Block : Iir) return O_Enode + is + Info : Block_Info_Acc; + begin + Info := Get_Info (Block); + if Info.Block_Decls_Type = Scopes_Var.Svtype then + return New_Value (New_Obj (Scopes_Var.Var)); + else + return New_Address (Get_Instance_Ref (Info.Block_Decls_Type), + Info.Block_Decls_Ptr_Type); + end if; + end Get_Instance_Access; + + function Get_Instance_Ref (Itype : O_Tnode) return O_Lnode + is + begin + -- Variables cannot be referenced if there is an instance being + -- built. + if Inst_Build /= null and then Inst_Build.Kind = Instance then + raise Internal_Error; + end if; + return Find_Scope_Type (Itype); + end Get_Instance_Ref; + + function Get_Var (Var : Var_Acc) return O_Lnode + is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return New_Obj (Var.E); + when Var_Scope => + null; + end case; + + return New_Selected_Element (Get_Instance_Ref (Var.I_Type), + Var.I_Field); + end Get_Var; + + function Get_Alloc_Kind_For_Var (Var : Var_Acc) return Allocation_Kind is + begin + case Var.Kind is + when Var_Local => + return Alloc_Stack; + when Var_Global + | Var_Scope => + return Alloc_System; + end case; + end Get_Alloc_Kind_For_Var; + + function Is_Var_Stable (Var : Var_Acc) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return True; + when Var_Scope => + return False; + end case; + end Is_Var_Stable; + + function Is_Var_Field (Var : Var_Acc) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return False; + when Var_Scope => + return True; + end case; + end Is_Var_Field; + + function Get_Var_Field (Var : Var_Acc) return O_Fnode is + begin + case Var.Kind is + when Var_Local + | Var_Global => + raise Internal_Error; + when Var_Scope => + return Var.I_Field; + end case; + end Get_Var_Field; + + function Get_Var_Label (Var : Var_Acc) return O_Dnode is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return Var.E; + when Var_Scope => + raise Internal_Error; + end case; + end Get_Var_Label; + + procedure Free_Var (Var : in out Var_Acc) + is + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Var_Type, Var_Acc); + begin + Unchecked_Deallocation (Var); + end Free_Var; + +-- type Scope_Layer is record +-- -- How to dereference a variable in the scope. +-- -- O_Enode_Null if no there is no way to dereference an element of +-- -- the scope, like during scope creation. +-- This : O_Enode; + +-- -- Type of the scope; this must be a record type or NULL_TREE for +-- -- the global scope. +-- -- This is very important since a variable (in fact a FIELD_DECL) +-- -- belong to a scope iff the type of the field context is +-- -- Scope_Type. As a consequence, Scope_Type of two different +-- -- layers must be different. +-- -- Note: scope_type is a type definition (such as RECORD_TYPE) and +-- -- *not* a TYPE_DECL. +-- -- NULL_TREE for a local scope. +-- Scope_Type : O_Tnode; + +-- -- The scope just below this one. +-- --Prev : Scope_Acc; +-- end record; + + procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is + begin + Id := Identifier_Local; + end Save_Local_Identifier; + + procedure Restore_Local_Identifier (Id : Local_Identifier_Type) is + begin + if Identifier_Local > Id then + -- If the value is restored with a smaller value, some identifiers + -- will be reused. This is certainly an internal error. + raise Internal_Error; + end if; + Identifier_Local := Id; + end Restore_Local_Identifier; + + -- Reset the identifier. + procedure Reset_Identifier_Prefix is + begin + if Identifier_Len /= 0 or else Identifier_Local /= 0 then + raise Internal_Error; + end if; + end Reset_Identifier_Prefix; + + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is + begin + Identifier_Len := Mark.Len; + Identifier_Local := Mark.Local_Id; + end Pop_Identifier_Prefix; + + procedure Add_String (Len : in out Natural; Str : String) + is + begin + Identifier_Buffer (Len + 1 .. Len + Str'Length) := Str; + Len := Len + Str'Length; + end Add_String; + + procedure Add_Nat (Len : in out Natural; Val : Natural) + is + Num : String (1 .. 10); + V : Natural; + P : Natural; + begin + P := Num'Last; + V := Val; + loop + Num (P) := Character'Val (Character'Pos ('0') + V mod 10); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + Add_String (Len, Num (P .. Num'Last)); + end Add_Nat; + + -- Convert name_id NAME to a string stored to + -- NAME_BUFFER (1 .. NAME_LENGTH). + -- + -- This encodes extended identifiers. + -- + -- Extended identifier encoding: + -- They start with 'X'. + -- Non extended character [0-9a-zA-Z] are left as is, + -- others are encoded to _XX, where XX is the character position in hex. + -- They finish with "__". + procedure Name_Id_To_String (Name : Name_Id) + is + use Name_Table; + + type Bool_Array_Type is array (Character) of Boolean; + pragma Pack (Bool_Array_Type); + Is_Extended_Char : constant Bool_Array_Type := + ('0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' => False, + others => True); + + N_Len : Natural; + P : Natural; + C : Character; + begin + if Is_Character (Name) then + P := Character'Pos (Name_Table.Get_Character (Name)); + Name_Buffer (1) := 'C'; + Name_Buffer (2) := N2hex (P / 16); + Name_Buffer (3) := N2hex (P mod 16); + Name_Length := 3; + return; + else + Image (Name); + end if; + if Name_Buffer (1) /= '\' then + return; + end if; + -- Extended identifier. + -- Supress trailing backslash. + Name_Length := Name_Length - 1; + + -- Count number of characters in the extended string. + N_Len := Name_Length; + for I in 2 .. Name_Length loop + if Is_Extended_Char (Name_Buffer (I)) then + N_Len := N_Len + 2; + end if; + end loop; + + -- Convert. + Name_Buffer (1) := 'X'; + P := N_Len; + for J in reverse 2 .. Name_Length loop + C := Name_Buffer (J); + if Is_Extended_Char (C) then + Name_Buffer (P - 0) := N2hex (Character'Pos (C) mod 16); + Name_Buffer (P - 1) := N2hex (Character'Pos (C) / 16); + Name_Buffer (P - 2) := '_'; + P := P - 3; + else + Name_Buffer (P) := C; + P := P - 1; + end if; + end loop; + Name_Buffer (N_Len + 1) := '_'; + Name_Buffer (N_Len + 2) := '_'; + Name_Length := N_Len + 2; + end Name_Id_To_String; + + procedure Add_Name (Len : in out Natural; Name : Name_Id) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Add_String (Len, Name_Buffer (1 .. Name_Length)); + end Add_Name; + + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0) + is + P : Natural; + begin + Mark.Len := Identifier_Len; + Mark.Local_Id := Identifier_Local; + Identifier_Local := 0; + P := Identifier_Len; + Add_String (P, Name); + if Val > 0 then + Add_String (P, "O"); + Add_Nat (P, Natural (Val)); + end if; + Add_String (P, "__"); + Identifier_Len := P; + end Push_Identifier_Prefix; + + -- Add a suffix to the prefix (!!!). + procedure Push_Identifier_Prefix + (Mark : out Id_Mark_Type; Name : Name_Id; Val : Iir_Int32 := 0) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Push_Identifier_Prefix (Mark, Name_Buffer (1 .. Name_Length), Val); + end Push_Identifier_Prefix; + +-- procedure Add_Local_Identifier (Len : in out Natural) +-- is +-- Str : String := Local_Identifier_Type'Image (Identifier_Local); +-- begin +-- Identifier_Local := Identifier_Local + 1; + +-- if Inst_Build = null then +-- Str (1) := 'N'; +-- else +-- case Inst_Build.Kind is +-- when Local => +-- Str (1) := 'L'; +-- when Global => +-- Str (1) := 'G'; +-- when Instance => +-- Str (1) := 'I'; +-- end case; +-- end if; +-- Add_String (Len, Str); +-- end Add_Local_Identifier; + + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type) + is + Str : String := Local_Identifier_Type'Image (Identifier_Local); + begin + Identifier_Local := Identifier_Local + 1; + Str (1) := 'U'; + Push_Identifier_Prefix (Mark, Str, 0); + end Push_Identifier_Prefix_Uniq; + + procedure Add_Identifier (Len : in out Natural; Id : Name_Id) is + begin + if Id = Null_Identifier then + --Add_Local_Identifier (Len); + null; + else + Add_Name (Len, Id); + end if; + end Add_Identifier; + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Get_Identifier (Id)); + return Get_Identifier (Name_Buffer (1 .. Name_Length)); + end Create_Identifier_Without_Prefix; + + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Id); + Name_Buffer (Name_Length + 1 .. Name_Length + Str'Length) := Str; + return Get_Identifier (Name_Buffer (1 .. Name_Length + Str'Length)); + end Create_Identifier_Without_Prefix; + + -- Create an identifier from IIR node ID with prefix. + function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean) + return O_Ident + is + L : Natural; + begin + L := Identifier_Len; + Add_Identifier (L, Id); + Add_String (L, Str); + --Identifier_Buffer (L + Str'Length + 1) := Nul; + if Is_Local then + return Get_Identifier + (Identifier_Buffer (Identifier_Start .. L)); + else + return Get_Identifier (Identifier_Buffer (1 .. L)); + end if; + end Create_Id; + + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident + is + begin + return Create_Id (Id, Str, False); + end Create_Identifier; + + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident + is + begin + return Create_Id (Get_Identifier (Id), Str, False); + end Create_Identifier; + + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_Identifier (Len, Get_Identifier (Id)); + + if Val > 0 then + Add_String (Len, "O"); + Add_Nat (Len, Natural (Val)); + end if; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier (Str : String) + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier return O_Ident + is + begin + return Get_Identifier (Identifier_Buffer (1 .. Identifier_Len - 2)); + end Create_Identifier; + + function Create_Var_Identifier (Id : Iir) + return Var_Ident_Type + is + Res : Var_Ident_Type; + begin + Res.Id := Create_Id (Get_Identifier (Id), "", Is_Local_Scope); + return Res; + end Create_Var_Identifier; + + function Create_Var_Identifier (Id : String) + return Var_Ident_Type + is + Res : Var_Ident_Type; + begin + Res.Id := Create_Id (Null_Identifier, Id, Is_Local_Scope); + return Res; + end Create_Var_Identifier; + + function Create_Uniq_Identifier return Var_Ident_Type + is + Res : Var_Ident_Type; + begin + Res.Id := Create_Uniq_Identifier; + return Res; + end Create_Uniq_Identifier; + end Chap10; + + package body Chap14 is + function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode + is + Prefix : Iir; + Arr : Mnode; + Dim : Natural; + begin + Prefix := Get_Prefix (Expr); + case Get_Kind (Prefix) is + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Arr := T2M (Get_Type (Prefix), Mode_Value); + when others => + Arr := Chap6.Translate_Name (Prefix); + end case; + 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, which must be stable. + -- Put the result into RES. + procedure Range_To_High_Low + (Range_Var : Mnode; Res : O_Dnode; Is_High : Boolean) + is + Op : ON_Op_Kind; + If_Blk : O_If_Block; + begin + 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_Var)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Left (Range_Var))); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Right (Range_Var))); + Finish_If_Stmt (If_Blk); + end Range_To_High_Low; + + function Translate_High_Low_Array_Attribute (Expr : Iir; + Is_High : Boolean) + return O_Enode + is + Prefix : Iir; + Prefix_Type : Iir; + Dim : Natural; + Index_Type : Iir; + Index_Info : Type_Info_Acc; + Res : O_Dnode; + Range_Var : Mnode; + begin + Prefix := Get_Prefix (Expr); + Prefix_Type := Get_Type (Prefix); + Dim := Natural (Get_Value (Get_Parameter (Expr))); + Index_Type := Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), + Dim - 1); + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + + Res := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + Open_Temp; + Range_Var := Stabilize (Translate_Array_Attribute_To_Range (Expr)); + Range_To_High_Low (Range_Var, Res, Is_High); + Close_Temp; + return New_Obj_Value (Res); + 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_Low_High_Type_Attribute + (Atype : Iir; Is_Low : Boolean) + return O_Enode + is + Range_Constr : Iir; + begin + if Get_Type_Staticness (Atype) = Locally then + Range_Constr := Get_Range_Constraint (Atype); + if Get_Direction (Range_Constr) = Iir_To xor Is_Low then + -- TO and HIGH or DOWNTO and LOW -> right + return New_Lit (Chap7.Translate_Static_Range_Right + (Range_Constr, Atype)); + else + -- TO and LOW or DOWNTO and HIGH -> left + return New_Lit (Chap7.Translate_Static_Range_Left + (Range_Constr, Atype)); + end if; + else + declare + Res : O_Dnode; + Rng : Mnode; + begin + Res := Create_Temp (Get_Ortho_Type (Atype, Mode_Value)); + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Atype)); + Range_To_High_Low (Rng, Res, not Is_Low); + Close_Temp; + return New_Obj_Value (Res); + end; + end if; + end Translate_Low_High_Type_Attribute; + + function Translate_High_Type_Attribute (Atype : Iir) return O_Enode is + begin + return Translate_Low_High_Type_Attribute (Atype, False); + end Translate_High_Type_Attribute; + + function Translate_Low_Type_Attribute (Atype : Iir) return O_Enode is + begin + return Translate_Low_High_Type_Attribute (Atype, True); + end Translate_Low_Type_Attribute; + + function Translate_Left_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_Left + (Get_Range_Constraint (Atype), Atype)); + else + Info := Get_Info (Atype); + 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 + Info : Type_Info_Acc; + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Right + (Get_Range_Constraint (Atype), Atype)); + else + Info := Get_Info (Atype); + 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 + T : O_Dnode; + Prefix : Iir; + Ttype : O_Tnode; + begin + Prefix := Get_Type (Attr); + Ttype := Get_Ortho_Type (Prefix, 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, Get_Type (Get_Prefix (Attr))); + return New_Obj_Value (T); + 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); + 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_B2 + | 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; + + -- Read the boolean attribute (active or event) FIELD of simple signal + -- SIG. + function Read_Bool_Signal_Attribute (Sig : O_Enode; Field : O_Fnode) + return O_Enode + is + S : O_Enode; + begin + S := New_Convert_Ov (Sig, Ghdl_Signal_Ptr); + return New_Value + (New_Selected_Element (New_Access_Element (S), Field)); + --Ghdl_Signal_Event_Node)); + end Read_Bool_Signal_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, + Read_Bool_Signal_Attribute (New_Value (M2Lv (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 : 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_Bool_Signal_Attribute (New_Value (M2Lv (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_Node); + end Translate_Event_Attribute; + + function Translate_Active_Attribute (Attr : Iir) return O_Enode is + begin + return Translate_Bool_Signal_Attribute + (Attr, Ghdl_Signal_Active_Node); + 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 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_Node)); + 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_Type, + 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_Type); + + 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_Type, -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_Type, 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_Type, 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_B2 => + Subprg := Ghdl_Signal_Driving_Value_B2; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Driving_Value_E8; + 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 : Iir; + Pinfo : Type_Info_Acc; + Res : O_Dnode; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + Conv : O_Tnode; + begin + Prefix_Type := Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo := Get_Info (Prefix_Type); + Res := Create_Temp (Std_String_Node); + Create_Temp_Stack2_Mark; + case Pinfo.Type_Mode is + when Type_Mode_B2 => + Subprg := Ghdl_Image_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Image_E8; + 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_B2 + | Type_Mode_E8 + | 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 : Iir; + Pinfo : Type_Info_Acc; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + Conv : O_Tnode; + begin + Prefix_Type := Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo := Get_Info (Prefix_Type); + case Pinfo.Type_Mode is + when Type_Mode_B2 => + Subprg := Ghdl_Value_B2; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Value_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 => + Subprg := Ghdl_Value_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_Value_P64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Value_F64; + Conv := Ghdl_Real_Type; + 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_B2 + | Type_Mode_E8 + | 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), Conv); + end Translate_Value_Attribute; + + -- Current path for name attributes. + Path_Str : String_Acc := null; + Path_Maxlen : Natural := 0; + Path_Len : Natural; + Path_Instance : Iir; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Name => String_Acc, Object => String); + + procedure Path_Reset is + begin + Path_Len := 0; + Path_Instance := Null_Iir; + if Path_Maxlen = 0 then + Path_Maxlen := 256; + Path_Str := new String (1 .. Path_Maxlen); + end if; + end Path_Reset; + + procedure Path_Add (Str : String) + is + N_Len : Natural; + N_Path : String_Acc; + begin + N_Len := Path_Maxlen; + loop + exit when Path_Len + Str'Length <= N_Len; + N_Len := N_Len * 2; + end loop; + if N_Len /= Path_Maxlen then + N_Path := new String (1 .. N_Len); + N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len); + Deallocate (Path_Str); + Path_Str := N_Path; + Path_Maxlen := N_Len; + end if; + Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str; + Path_Len := Path_Len + Str'Length; + end Path_Add; + + procedure Path_Add_Type_Name (Atype : Iir) + is + use Name_Table; + Adecl : Iir; + begin + Adecl := Get_Type_Declarator (Atype); + Image (Get_Identifier (Adecl)); + Path_Add (Name_Buffer (1 .. Name_Length)); + end Path_Add_Type_Name; + + procedure Path_Add_Signature (Subprg : Iir) + is + Chain : Iir; + begin + Path_Add ("["); + Chain := Get_Interface_Declaration_Chain (Subprg); + while Chain /= Null_Iir loop + Path_Add_Type_Name (Get_Type (Chain)); + Chain := Get_Chain (Chain); + if Chain /= Null_Iir then + Path_Add (","); + end if; + end loop; + + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Implicit_Function_Declaration => + Path_Add (" return "); + Path_Add_Type_Name (Get_Return_Type (Subprg)); + when others => + null; + end case; + Path_Add ("]"); + end Path_Add_Signature; + + procedure Path_Add_Name (N : Iir) + is + use Name_Table; + begin + Eval_Simple_Name (Get_Identifier (N)); + if Name_Buffer (1) /= 'P' then + -- Skip anonymous processes. + Path_Add (Name_Buffer (1 .. Name_Length)); + end if; + end Path_Add_Name; + + procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) + is + begin + -- LRM 14.1 + -- E'INSTANCE_NAME + -- There is one full pah instance element for each component + -- instantiation, block statement, generate statemenent, process + -- statement, or subprogram body in the design hierarchy between + -- the top design entity and the named entity denoted by the + -- prefix. + -- + -- E'PATH_NAME + -- There is one path instance element for each component + -- instantiation, block statement, generate statement, process + -- statement, or subprogram body in the design hierarchy between + -- the root design entity and the named entity denoted by the + -- prefix. + case Get_Kind (El) is + when Iir_Kind_Library_Declaration => + Path_Add (":"); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Package_Declaration => + Path_Add_Element + (Get_Library (Get_Design_File (Get_Design_Unit (El))), + Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Entity_Declaration => + Path_Instance := El; + when Iir_Kind_Architecture_Declaration => + Path_Instance := El; + when Iir_Kind_Design_Unit => + Path_Add_Element (Get_Library_Unit (El), Is_Instance); + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + if Flags.Vhdl_Std >= Vhdl_02 then + -- Add signature. + Path_Add_Signature (El); + end if; + Path_Add (":"); + when Iir_Kind_Procedure_Body => + Path_Add_Element (Get_Subprogram_Specification (El), + Is_Instance); + when Iir_Kind_Generate_Statement => + declare + Scheme : Iir; + begin + Scheme := Get_Generation_Scheme (El); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Path_Instance := El; + else + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + end if; + end; + when Iir_Kinds_Sequential_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + when others => + Error_Kind ("path_add_element", El); + end case; + end Path_Add_Element; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode + is + Prefix : Iir; + Res : O_Dnode; + Name_Cst : O_Dnode; + Constr : O_Assoc_List; + Is_Instance : Boolean; + begin + Prefix := Get_Prefix (Attr); + Is_Instance := Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + + Path_Reset; + + -- LRM 14.1 + -- E'PATH_NAME + -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless + -- E denotes a library, package, subprogram or label. In this + -- latter case, the package based path or instance based path, + -- as appropriate, will not contain a local item name. + -- + -- E'INSTANCE_NAME + -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME, + -- unless E denotes a library, package, subprogram, or label. In + -- this latter case, the package based path or full instance based + -- path, as appropriate, will not contain a local item name. + case Get_Kind (Prefix) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Path_Add_Element (Get_Parent (Prefix), Is_Instance); + Path_Add_Name (Prefix); + when Iir_Kind_Library_Declaration + | Iir_Kind_Design_Unit + | Iir_Kind_Package_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + Path_Add_Element (Prefix, Is_Instance); + when others => + Error_Kind ("translate_path_instance_name_attribute", Prefix); + end case; + Create_Temp_Stack2_Mark; + + Res := Create_Temp (Std_String_Node); + 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, + Create_String_Len (Path_Str (1 .. Path_Len), + Create_Uniq_Identifier)); + 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 Path_Instance = Null_Iir then + Rtis.Associate_Null_Rti_Context (Constr); + else + Rtis.Associate_Rti_Context (Constr, 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 unit value. + Ghdl_Rti_Unit_Val : O_Tnode; + Ghdl_Rti_Unit_32 : O_Fnode; + Ghdl_Rti_Unit_64 : O_Fnode; + Ghdl_Rti_Unit_Addr : O_Fnode; + + -- Node for an unit. + Ghdl_Rtin_Unit : O_Tnode; + Ghdl_Rtin_Unit_Common : O_Fnode; + Ghdl_Rtin_Unit_Name : O_Fnode; + Ghdl_Rtin_Unit_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_b2"), + Ghdl_Rtik_Type_B2); + 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_array_ptr"), + Ghdl_Rtik_Subtype_Array_Ptr); + 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_unit"), + Ghdl_Rtik_Unit); + + 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_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_rti_loc + declare + Constr : O_Element_List; + begin + Start_Union_Type (Constr); + New_Union_Field (Constr, Ghdl_Rti_Loc_Offset, + Get_Identifier ("offset"), Ghdl_Index_Type); + New_Union_Field (Constr, Ghdl_Rti_Loc_Address, + Get_Identifier ("address"), Ghdl_Ptr_Type); + Finish_Union_Type (Constr, Ghdl_Rti_Loc); + New_Type_Decl (Get_Identifier ("__ghdl_rti_loc"), Ghdl_Rti_Loc); + 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_Rti_Loc); + 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_Rti_Loc); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Scalar); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_scalar"), + Ghdl_Rtin_Subtype_Scalar); + end; + + declare + Constr : O_Element_List; + begin + Start_Union_Type (Constr); + New_Union_Field (Constr, Ghdl_Rti_Unit_32, + Get_Identifier ("unit_32"), Ghdl_I32_Type); + if not Flag_Only_32b then + New_Union_Field (Constr, Ghdl_Rti_Unit_64, + Get_Identifier ("unit_64"), Ghdl_I64_Type); + end if; + New_Union_Field (Constr, Ghdl_Rti_Unit_Addr, + Get_Identifier ("addr"), Ghdl_Ptr_Type); + Finish_Union_Type (Constr, Ghdl_Rti_Unit_Val); + New_Type_Decl (Get_Identifier ("__ghdl_rti_unit_val"), + Ghdl_Rti_Unit_Val); + end; + + -- Unit + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Unit_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Unit_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Unit_Value, + Get_Identifier ("value"), Ghdl_Rti_Unit_Val); + Finish_Record_Type (Constr, Ghdl_Rtin_Unit); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_unit"), + Ghdl_Rtin_Unit); + 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_Rti_Loc); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Valsize, + Get_Identifier ("val_size"), Ghdl_Rti_Loc); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Sigsize, + Get_Identifier ("sig_size"), Ghdl_Rti_Loc); + 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); + --New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Valsize, + -- Get_Identifier ("val_size"), Ghdl_Rti_Loc); + --New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Sigsize, + -- Get_Identifier ("sig_size"), Ghdl_Rti_Loc); + 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_Rti_Loc); + 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_Rti_Loc); + 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_Acc := null) return Rti_Depth_Type + is + begin + if Var = null 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_Acc := null; 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_Union_Aggr (Ghdl_Rti_Loc, + Ghdl_Rti_Loc_Address, + New_Null_Access (Ghdl_Ptr_Type)); + end Get_Null_Loc; + + function Var_Acc_To_Loc (Var : Var_Acc) return O_Cnode + is + begin + if Is_Var_Field (Var) then + return New_Union_Aggr (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Offset, + New_Offsetof (Get_Var_Field (Var), + Ghdl_Index_Type)); + else + return New_Union_Aggr + (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Address, + 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 + Val : O_Cnode; + Info : Type_Info_Acc; + begin + Info := Get_Info (Atype); + 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 : Iir_List := Get_Enumeration_Literal_List (Atype); + Nbr_Lit : 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_B2 => + Kind := Ghdl_Rtik_Type_B2; + 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_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; + Field : O_Fnode; + Const : O_Dnode; + Conv_Type : O_Tnode; + Unit_Type : Type_Info_Acc; + Info : Object_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Unit)); + Name := Generate_Name (Unit); + New_Const_Decl (Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Unit); + Start_Const_Value (Const); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Unit); + New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Unit)); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + Info := Get_Info (Unit); + if Info /= null then + -- Handle non-static units. The only possibility is a unit of + -- std.standard.time. + Field := Ghdl_Rti_Unit_Addr; + Val := New_Global_Unchecked_Address + (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type); + else + Unit_Type := Get_Info (Get_Type (Unit)); + case Unit_Type.Type_Mode is + when Type_Mode_P64 => + Field := Ghdl_Rti_Unit_64; + Conv_Type := Ghdl_I64_Type; + when Type_Mode_P32 => + Field := Ghdl_Rti_Unit_32; + Conv_Type := Ghdl_I32_Type; + when others => + raise Internal_Error; + end case; + Val := Chap7.Translate_Numeric_Literal (Unit, Conv_Type); + end if; + New_Record_Aggr_El + (Aggr, New_Union_Aggr (Ghdl_Rti_Unit_Val, Field, 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; + Mode : Integer; + 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); + if Get_Info (Unit) /= null then + Mode := 1; + else + Mode := 0; + end if; + 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, Mode)); + 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_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 Iir_Kind_Unconstrained_Array_Subtype_Definition => + Base_Type := Get_Base_Type (Atype); + Base := Get_Info (Base_Type).Type_Rti; + Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; + 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 : Iir_List; + Nbr_Indexes : Integer; + Index : Iir; + Tmp : O_Dnode; + Arr_Type : O_Tnode; + Arr_Aggr : O_Array_Aggr_List; + Val : O_Cnode; + Mark : Id_Mark_Type; + begin + -- Translate each index. + List := Get_Index_Subtype_List (Atype); + Nbr_Indexes := Get_Nbr_Elements (List); + for I in 1 .. Nbr_Indexes loop + Index := Get_Nth_Element (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 0 .. Nbr_Indexes - 1 loop + Index := Get_Nth_Element (List, I); + 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 (Info : Type_Info_Acc) return Natural is + begin + if Info.C /= null then + return 1; + else + return 0; + end if; + 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; + 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 (Info))); + 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; + Bounds : Var_Acc; + Name : O_Dnode; + Kind : O_Cnode; + Mark : Id_Mark_Type; + Depth : Rti_Depth_Type; + begin + 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_Ptr_Array => + Kind := Ghdl_Rtik_Subtype_Array_Ptr; + 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 (Info))); + 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 (Bounds)); + for I in Mode_Value .. Mode_Signal loop + if I = Mode_Signal and then not Get_Signal_Type_Flag (Atype) then + Val := Get_Null_Loc; + else + case Info.Type_Mode is + when Type_Mode_Array => + Val := New_Union_Aggr (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Offset, + New_Sizeof (Info.Ortho_Type (I), + Ghdl_Index_Type)); + when Type_Mode_Ptr_Array => + Val := Var_Acc_To_Loc (Info.C.Size_Var (I)); + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; + end if; + 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_Chain : Iir; + El : Iir; + Prev : Rti_Block; + El_Arr : O_Dnode; + Res : O_Cnode; + Info : Type_Info_Acc; + Max_Depth : Rti_Depth_Type; + begin + Info := Get_Info (Atype); + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Record); + if Global_Storage = O_Storage_External then + return; + end if; + + El_Chain := Get_Element_Declaration_Chain (Atype); + Max_Depth := 0; + + -- Generate elements. + Push_Rti_Node (Prev, False); + El := El_Chain; + while El /= Null_Iir loop + declare + Type_Rti : O_Dnode; + El_Name : O_Dnode; + El_Type : Iir; + Aggr : O_Record_Aggr_List; + Field_Info : Field_Info_Acc; + Val : O_Cnode; + El_Const : O_Dnode; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + El_Type := Get_Type (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); + Field_Info := Get_Info (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 (Field_Info.Field_Node (I), + Ghdl_Index_Type); + else + Val := New_Unsigned_Literal (Ghdl_Index_Type, 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; + El := Get_Chain (El); + 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 (Info))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El + (Aggr, New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Get_Number_Element_Declaration (Atype)))); + 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 (Info))); + 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 : Type_Info_Acc; + begin + Info := Get_Info (Atype); + 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 + | Iir_Kind_Unconstrained_Array_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 : Iir; + Info : Type_Info_Acc; + Rti_Type : O_Tnode; + begin + Ndef := Get_Type (Get_Type_Declarator (Def)); + Info := Get_Info (Ndef); + 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 + Rti : O_Dnode; + Mark : Id_Mark_Type; + Id : Name_Id; + Def : Iir; + begin + Id := Get_Identifier (Decl); + Push_Identifier_Prefix (Mark, Id); + Def := Get_Type (Decl); + 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_Acc; + 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; + 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_Signal_Interface_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_Constant_Interface_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; + 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_Signal_Interface_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_Signal_Interface_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 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; + + procedure Generate_Instance (Stmt : Iir; Parent : O_Dnode) + is + Name : O_Dnode; + List : O_Record_Aggr_List; + Val : O_Cnode; + Inst : Iir; + Info : Block_Info_Acc; + begin + Name := Generate_Name (Stmt); + Info := Get_Info (Stmt); + + New_Const_Decl (Info.Block_Rti_Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Instance); + + Inst := Get_Instantiated_Unit (Stmt); + 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_Union_Aggr (Ghdl_Rti_Loc, Ghdl_Rti_Loc_Offset, + New_Offsetof (Info.Block_Parent_Field, + Ghdl_Index_Type))); + New_Record_Aggr_El (List, New_Rti_Address (Parent)); + case Get_Kind (Inst) is + when Iir_Kind_Component_Declaration => + Val := New_Rti_Address (Get_Info (Inst).Comp_Rti_Const); + when Iir_Kind_Entity_Aspect_Entity => + declare + Ent : Iir; + begin + Ent := Get_Library_Unit (Get_Entity (Inst)); + Val := New_Rti_Address (Get_Info (Ent).Block_Rti_Const); + end; + when Iir_Kind_Entity_Aspect_Configuration => + declare + Config : Iir; + Ent : Iir; + begin + Config := Get_Library_Unit (Get_Configuration (Inst)); + Ent := Get_Library_Unit (Get_Entity (Config)); + Val := New_Rti_Address (Get_Info (Ent).Block_Rti_Const); + end; + when others => + Val := New_Null_Access (Ghdl_Rti_Access); + end case; + + 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_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_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Add_Rti_Node (Generate_Type_Decl (Decl)); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Constant_Interface_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_Function_Body + | Iir_Kind_Procedure_Declaration + | Iir_Kind_Procedure_Body => + -- FIXME: to be added (for foreign). + 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", 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 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 : O_Fnode; + 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 := O_Fnode_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; + -- FIXME: yes or not ? + --Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + when Iir_Kind_Architecture_Declaration => + Kind := Ghdl_Rtik_Architecture; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Field := Info.Block_Parent_Field; + Inst := Info.Block_Decls_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 := Info.Block_Decls_Type; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Kind := Ghdl_Rtik_Process; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Field := Info.Process_Parent_Field; + Inst := Info.Process_Decls_Type; + when Iir_Kind_Block_Statement => + Kind := Ghdl_Rtik_Block; + declare + Guard : Iir; + Header : Iir; + Guard_Info : Object_Info_Acc; + begin + Guard := Get_Guard_Decl (Blk); + 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; + Header := Get_Block_Header (Blk); + 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 := Info.Block_Parent_Field; + Inst := Info.Block_Decls_Type; + when Iir_Kind_Generate_Statement => + declare + Scheme : Iir; + Scheme_Rti : O_Dnode := O_Dnode_Null; + begin + Scheme := Get_Generation_Scheme (Blk); + 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); + Field := Info.Block_Parent_Field; + Inst := Info.Block_Decls_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 = O_Fnode_Null then + Res := Get_Null_Loc; + else + Res := New_Union_Aggr (Ghdl_Rti_Loc, + Ghdl_Rti_Loc_Offset, + New_Offsetof (Field, Ghdl_Index_Type)); + end if; + New_Record_Aggr_El (List, Res); + 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 := New_Unsigned_Literal (Ghdl_Index_Type, 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_Declaration + | 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_Declaration => + 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_Architecture_Declaration => + Info.Block_Rti_Const := Rti; + when 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); + Info.Package_Rti_Const := Rti; + end; + 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_Declaration => + 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 (Arch : Iir) + is + use Configuration; + + Unit : Iir_Design_Unit; + Lib_Unit : Iir; + Lib : Iir_Library_Declaration; + Arr : O_Dnode; + Res : O_Cnode; + Aggr : O_Record_Aggr_List; + Prev : Rti_Block; + begin + Push_Rti_Node (Prev); + Add_Rti_Node (Get_Info (Standard_Package).Package_Rti_Const); + 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); + + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + Add_Rti_Node (Get_Info (Lib_Unit).Package_Rti_Const); + when others => + null; + end case; + end loop; + Arr := Generate_Rti_Array (Get_Identifier ("__ghdl_top_RTIARRAY")); + New_Const_Decl (Ghdl_Rti_Top, Get_Identifier ("__ghdl_rti_top"), + O_Storage_Public, Ghdl_Rtin_Block); + Start_Const_Value (Ghdl_Rti_Top); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Block); + New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Top)); + New_Record_Aggr_El (Aggr, New_Null_Access (Char_Ptr_Type)); + New_Record_Aggr_El (Aggr, Get_Null_Loc); + New_Record_Aggr_El + (Aggr, New_Rti_Address (Get_Info (Arch).Block_Rti_Const)); + New_Record_Aggr_El (Aggr, New_Unsigned_Literal (Ghdl_Index_Type, 0)); + New_Record_Aggr_El + (Aggr, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr))); + New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (Aggr, Res); + Finish_Const_Value (Ghdl_Rti_Top, Res); + 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_Declaration + | 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 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 : Ortho_Info_Acc; + + Block_Type : O_Tnode; + begin + Node_Info := Get_Info (Node); + + case Get_Kind (Node) is + when Iir_Kind_Component_Declaration => + Block_Type := Node_Info.Comp_Type; + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Declaration + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Block_Type := Node_Info.Block_Decls_Type; + 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 => + Block_Type := Node_Info.Process_Decls_Type; + when others => + Error_Kind ("get_context_addr", Node); + end case; + return New_Unchecked_Address (Get_Instance_Ref (Block_Type), + Ghdl_Ptr_Type); + end Get_Context_Addr; + + procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir) + is + begin + New_Association (Assoc, New_Lit (Get_Context_Rti (Node))); + New_Association (Assoc, Get_Context_Addr (Node)); + end Associate_Rti_Context; + + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List) is + begin + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Rti_Access))); + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end Associate_Null_Rti_Context; + end Rtis; + + procedure Gen_Filename (Design_File : Iir) + is + Info : Design_File_Info_Acc; + begin + if Current_Filename_Node /= O_Dnode_Null then + raise Internal_Error; + end if; + Info := Get_Info (Design_File); + if Info = null then + Info := Add_Info (Design_File, Kind_Design_File); + Info.Design_Filename := Create_String + (Get_Design_File_Filename (Design_File), + Create_Uniq_Identifier, O_Storage_Private); + end if; + Current_Filename_Node := Info.Design_Filename; + end Gen_Filename; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Translate (Unit : Iir_Design_Unit; Main : Boolean) + is + Design_File : Iir_Design_File; + El : Iir; + Lib : Iir_Library_Declaration; + Lib_Mark, Ent_Mark, Sep_Mark, Unit_Mark : Id_Mark_Type; + Id : Name_Id; + begin + Update_Node_Infos; + + Design_File := Get_Design_File (Unit); + + if False then + El := Get_Context_Items (Unit); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Library_Clause => + null; + when others => + Error_Kind ("translate1", El); + end case; + end loop; + end if; + + El := Get_Library_Unit (Unit); + if Flags.Verbose then + Ada.Text_IO.Put ("translating "); + if Main then + Ada.Text_IO.Put ("(with code generation) "); + end if; + Ada.Text_IO.Put_Line (Disp_Node (El)); + end if; + + -- Create the prefix for identifiers. + Lib := Get_Library (Get_Design_File (Unit)); + Reset_Identifier_Prefix; + if Lib = Libraries.Work_Library then + Id := Libraries.Work_Library_Name; + else + Id := Get_Identifier (Lib); + end if; + Push_Identifier_Prefix (Lib_Mark, Id); + + if Get_Kind (El) = Iir_Kind_Architecture_Declaration then + -- Put 'ARCH' between the entity name and the architecture name, to + -- avoid a name clash with names from entity (eg an entity port with + -- the same name as an architecture). + Push_Identifier_Prefix (Ent_Mark, Get_Identifier (Get_Entity (El))); + Push_Identifier_Prefix (Sep_Mark, "ARCH"); + end if; + Id := Get_Identifier (El); + if Id /= Null_Identifier then + Push_Identifier_Prefix (Unit_Mark, Id); + end if; + + if Main then + Set_Global_Storage (O_Storage_Public); + -- Create the variable containing the current file name. + Gen_Filename (Get_Design_File (Unit)); + else + Set_Global_Storage (O_Storage_External); + end if; + + New_Debug_Filename_Decl + (Name_Table.Image (Get_Design_File_Filename (Design_File))); + + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + New_Debug_Comment_Decl + ("package declaration " & Image_Identifier (El)); + Chap2.Translate_Package_Declaration (El); + when Iir_Kind_Package_Body => + New_Debug_Comment_Decl ("package body " & Image_Identifier (El)); + --Push_Global_Factory (O_Storage_Private); + Chap2.Translate_Package_Body (El); + --Pop_Global_Factory; + when Iir_Kind_Entity_Declaration => + New_Debug_Comment_Decl ("entity " & Image_Identifier (El)); + --Set_Global_Storage (O_Storage_Private); + Chap1.Translate_Entity_Declaration (El); + when Iir_Kind_Architecture_Declaration => + New_Debug_Comment_Decl ("architecture " & Image_Identifier (El)); + --Set_Global_Storage (O_Storage_Private); + Chap1.Translate_Architecture_Declaration (El); + when Iir_Kind_Configuration_Declaration => + New_Debug_Comment_Decl ("configuration " & Image_Identifier (El)); + if Id = Null_Identifier then + declare + Mark : Id_Mark_Type; + Mark_Entity : Id_Mark_Type; + Mark_Arch : Id_Mark_Type; + Mark_Sep : Id_Mark_Type; + Arch : Iir; + Entity : Iir; + begin + -- Note: this is done inside the architecture identifier. + Entity := Get_Library_Unit (Get_Entity (El)); + Push_Identifier_Prefix + (Mark_Entity, Get_Identifier (Entity)); + Arch := Get_Block_Specification + (Get_Block_Configuration (El)); + Push_Identifier_Prefix (Mark_Sep, "ARCH"); + Push_Identifier_Prefix (Mark_Arch, Get_Identifier (Arch)); + Push_Identifier_Prefix + (Mark, Name_Table.Get_Identifier ("DEFAULT_CONFIG")); + Chap1.Translate_Configuration_Declaration (El); + Pop_Identifier_Prefix (Mark); + Pop_Identifier_Prefix (Mark_Entity); + Pop_Identifier_Prefix (Mark_Sep); + Pop_Identifier_Prefix (Mark_Arch); + end; + else + Chap1.Translate_Configuration_Declaration (El); + end if; + when others => + Error_Kind ("translate", El); + end case; + + Current_Filename_Node := O_Dnode_Null; + + --Pop_Global_Factory; + if Id /= Null_Identifier then + Pop_Identifier_Prefix (Unit_Mark); + end if; + if Get_Kind (El) = Iir_Kind_Architecture_Declaration then + Pop_Identifier_Prefix (Sep_Mark); + Pop_Identifier_Prefix (Ent_Mark); + end if; + Pop_Identifier_Prefix (Lib_Mark); + end Translate; + + procedure Initialize + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Node_Infos.Init; + Node_Infos.Set_Last (4); + Node_Infos.Table (0 .. 4) := (others => null); + New_Debug_Comment_Decl ("internal declarations, part 1"); + -- Give a name to sizetype. + --Finish_Type_Decl (Sizetype, Get_Identifier ("__ghdl_size_t")); + + -- Create well known identifiers. + Wki_This := Get_Identifier ("this"); + Wki_Size := Get_Identifier ("size"); + Wki_Res := Get_Identifier ("res"); + Wki_Dir_To := Get_Identifier ("dir_to"); + Wki_Dir_Downto := Get_Identifier ("dir_downto"); + Wki_Left := Get_Identifier ("left"); + Wki_Right := Get_Identifier ("right"); + Wki_Dir := Get_Identifier ("dir"); + Wki_Length := Get_Identifier ("length"); + Wki_Kind := Get_Identifier ("kind"); + Wki_Dim := Get_Identifier ("dim"); + Wki_I := Get_Identifier ("I"); + Wki_Instance := Get_Identifier ("INSTANCE"); + Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE"); + Wki_Name := Get_Identifier ("NAME"); + Wki_Sig := Get_Identifier ("sig"); + Wki_Obj := Get_Identifier ("OBJ"); + Wki_Rti := Get_Identifier ("RTI"); + Wki_Parent := Get_Identifier ("parent"); + + Sizetype := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); + + -- Create __ghdl_index_type, which is the type for *all* array index. + Ghdl_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_index_type"), Ghdl_Index_Type); + + Ghdl_I32_Type := New_Signed_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_i32"), Ghdl_I32_Type); + + Ghdl_Real_Type := New_Float_Type; + New_Type_Decl (Get_Identifier ("__ghdl_real"), Ghdl_Real_Type); + + if not Flag_Only_32b then + Ghdl_I64_Type := New_Signed_Type (64); + New_Type_Decl (Get_Identifier ("__ghdl_i64"), Ghdl_I64_Type); + end if; + + -- File index for elaborated file object. + Ghdl_File_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_file_index"), + Ghdl_File_Index_Type); + Ghdl_File_Index_Ptr_Type := New_Access_Type (Ghdl_File_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_file_index_ptr"), + Ghdl_File_Index_Ptr_Type); + + -- Create char, char [] and char *. + Char_Type_Node := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_char"), Char_Type_Node); + + Chararray_Type := New_Array_Type (Char_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_chararray"), Chararray_Type); + + Char_Ptr_Type := New_Access_Type (Chararray_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr"), Char_Ptr_Type); + + Char_Ptr_Array_Type := New_Array_Type (Char_Ptr_Type, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array"), + Char_Ptr_Array_Type); + + Char_Ptr_Array_Ptr_Type := New_Access_Type (Char_Ptr_Array_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array_ptr"), + Char_Ptr_Array_Ptr_Type); + + -- Generic pointer. + Ghdl_Ptr_Type := New_Access_Type (Char_Type_Node); + Const_Ptr_Type_Node := Ghdl_Ptr_Type; + New_Type_Decl (Get_Identifier ("__ghdl_ptr"), Ghdl_Ptr_Type); + + -- Create record + -- len : natural; + -- str : C_String; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Str_Len_Type_Len_Field, + Get_Identifier ("len"), Ghdl_Index_Type); + New_Record_Field + (Constr, Ghdl_Str_Len_Type_Str_Field, + Get_Identifier ("str"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len"), + Ghdl_Str_Len_Type_Node); + end; + + Ghdl_Str_Len_Array_Type_Node := New_Array_Type + (Ghdl_Str_Len_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_array"), + Ghdl_Str_Len_Array_Type_Node); + + -- Create type __ghdl_str_len_ptr is access all __ghdl_str_len + Ghdl_Str_Len_Ptr_Node := New_Access_Type (Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_ptr"), + Ghdl_Str_Len_Ptr_Node); + + -- Create type __ghdl_bool_type is (false, true) + New_Boolean_Type (Ghdl_Bool_Type, + Get_Identifier ("false"), + Ghdl_Bool_False_Node, + Get_Identifier ("true"), + Ghdl_Bool_True_Node); + New_Type_Decl (Get_Identifier ("__ghdl_bool_type"), + Ghdl_Bool_Type); + + -- __ghdl_bool_array is array (ghdl_index_type) of ghdl_bool_type + Ghdl_Bool_Array_Type := + New_Array_Type (Ghdl_Bool_Type, Ghdl_Index_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_type"), Ghdl_Bool_Array_Type); + + -- __ghdl_bool_array_ptr is access __ghdl_bool_array; + Ghdl_Bool_Array_Ptr := New_Access_Type (Ghdl_Bool_Array_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_ptr"), Ghdl_Bool_Array_Ptr); + + -- Create type ghdl_compare_type is (lt, eq, ge); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Get_Identifier ("lt"), Ghdl_Compare_Lt); + New_Enum_Literal (Constr, Get_Identifier ("eq"), Ghdl_Compare_Eq); + New_Enum_Literal (Constr, Get_Identifier ("gt"), Ghdl_Compare_Gt); + Finish_Enum_Type (Constr, Ghdl_Compare_Type); + New_Type_Decl (Get_Identifier ("__ghdl_compare_type"), + Ghdl_Compare_Type); + end; + + -- Create: + -- type __ghdl_location is record + -- file : __ghdl_str_len_ptr; + -- line : integer; + -- col : Integer; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Location_Filename_Node, + Get_Identifier ("filename"), + Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Location_Line_Node, + Get_Identifier ("line"), + Ghdl_I32_Type); + New_Record_Field (Constr, Ghdl_Location_Col_Node, + Get_Identifier ("col"), + Ghdl_I32_Type); + Finish_Record_Type (Constr, Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location"), + Ghdl_Location_Type_Node); + end; + -- Create type __ghdl_location_ptr is access __ghdl_location; + Ghdl_Location_Ptr_Node := New_Access_Type (Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location_ptr"), + Ghdl_Location_Ptr_Node); + + -- Create type ghdl_dir_type is (dir_to, dir_downto); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Wki_Dir_To, Ghdl_Dir_To_Node); + New_Enum_Literal (Constr, Wki_Dir_Downto, Ghdl_Dir_Downto_Node); + Finish_Enum_Type (Constr, Ghdl_Dir_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_dir_type"), + Ghdl_Dir_Type_Node); + end; + + -- Create void* __ghdl_alloc (unsigned size); + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_alloc"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Sizetype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Alloc_Ptr); + + -- procedure __ghdl_program_error -- (loc : __ghdl_location_acc); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_program_error"), + O_Storage_External); + --New_Interface_Decl (Interfaces, Param, + -- Get_Identifier ("location"), + -- Ghdl_Location_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Program_Error); + + -- procedure __ghdl_bound_check_failed_l0; + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_bound_check_failed_l0"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("index"), + Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Bound_Check_Failed_L0); + + -- procedure __ghdl_bound_check_failed_l1 (filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_bound_check_failed_l1"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("filename"), Char_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("line"), Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Bound_Check_Failed_L1); + + -- Secondary stack subprograms. + -- function __ghdl_stack2_allocate (size : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_allocate"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Allocate); + + -- function __ghdl_stack2_mark return ghdl_ptr_type; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_stack2_mark"), + O_Storage_External, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Mark); + + -- procedure __ghdl_stack2_release (mark : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_release"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mark"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Release); + + -- procedure __ghdl_memcpy (dest : ghdl_ptr_type; + -- src : ghdl_ptr_type; + -- length : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_memcpy"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("dest"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Memcpy); + + -- procedure __ghdl_deallocate (ptr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_deallocate"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Deallocate); + + -- function __ghdl_malloc (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc); + + -- function __ghdl_malloc0 (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc0"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc0); + + -- function __ghdl_text_file_elaborate return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Elaborate); + + -- function __ghdl_file_elaborate (name : char_ptr_type) + -- return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Name, Char_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Elaborate); + + -- procedure __ghdl_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Finalize); + + -- procedure __ghdl_text_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Finalize); + + declare + procedure Create_Protected_Subprg + (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Protected_Subprg; + begin + -- procedure __ghdl_protected_enter (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_enter", Ghdl_Protected_Enter); + + -- procedure __ghdl_protected_leave (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_leave", Ghdl_Protected_Leave); + + Create_Protected_Subprg + ("__ghdl_protected_init", Ghdl_Protected_Init); + + Create_Protected_Subprg + ("__ghdl_protected_fini", Ghdl_Protected_Fini); + end; + + if Flag_Rti then + Rtis.Rti_Initialize; + end if; + + -- procedure __ghdl_signal_name_rti + -- (obj : ghdl_rti_access; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_name_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Name_Rti); + + declare + -- procedure NAME (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + procedure Create_Process_Register (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Process_Register; + begin + Create_Process_Register ("__ghdl_process_register", + Ghdl_Process_Register); + Create_Process_Register ("__ghdl_sensitized_process_register", + Ghdl_Sensitized_Process_Register); + Create_Process_Register ("__ghdl_postponed_process_register", + Ghdl_Postponed_Process_Register); + Create_Process_Register + ("__ghdl_postponed_sensitized_process_register", + Ghdl_Postponed_Sensitized_Process_Register); + end; + end Initialize; + + procedure Create_Signal_Subprograms + (Suffix : String; + Val_Type : O_Tnode; + Create_Signal : out O_Dnode; + Init_Signal : out O_Dnode; + Simple_Assign : out O_Dnode; + Start_Assign : out O_Dnode; + Next_Assign : out O_Dnode; + Associate_Value : out O_Dnode; + Driving_Value : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + -- function __ghdl_create_signal_XXX (init_val : VAL_TYPE) + -- resolv_func : ghdl_ptr_type; + -- resolv_inst : ghdl_ptr_type; + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_signal_" & Suffix), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("init_val"), Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_func"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_inst"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Create_Signal); + + -- procedure __ghdl_signal_init_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_init_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), Val_Type); + Finish_Subprogram_Decl (Interfaces, Init_Signal); + + -- procedure __ghdl_signal_simple_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), Val_Type); + Finish_Subprogram_Decl (Interfaces, Simple_Assign); + + -- procedure __ghdl_signal_start_assign_XXX (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Start_Assign); + + -- procedure __ghdl_signal_next_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Next_Assign); + + -- procedure __ghdl_signal_associate_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_associate_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + Val_Type); + Finish_Subprogram_Decl (Interfaces, Associate_Value); + + -- function __ghdl_signal_driving_value_XXX (sign : __ghdl_signal_ptr) + -- return VAL_TYPE; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving_value_" & Suffix), + O_Storage_External, Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Driving_Value); + end Create_Signal_Subprograms; + + -- procedure __ghdl_image_NAME (res : std_string_ptr_node; + -- val : VAL_TYPE; + -- rti : ghdl_rti_access); + -- + -- function __ghdl_value_NAME (val : std_string_ptr_node; + -- rti : ghdl_rti_access); + -- return VAL_TYPE; + procedure Create_Image_Value_Subprograms (Name : String; + Val_Type : O_Tnode; + Has_Td : Boolean; + Image_Subprg : out O_Dnode; + Value_Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_image_" & Name), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("res"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("val"), Val_Type); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Image_Subprg); + + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_value_" & Name), + O_Storage_External, Val_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("val"), Std_String_Ptr_Node); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Value_Subprg); + end Create_Image_Value_Subprograms; + + -- Do internal declarations that need std.standard declarations. + procedure Post_Initialize + is + Interfaces : O_Inter_List; + Rec : O_Element_List; + Param : O_Dnode; + Integer_Otype : O_Tnode; + Real_Otype : O_Tnode; + Time_Otype : O_Tnode; + Info : Type_Info_Acc; + begin + New_Debug_Comment_Decl ("internal declarations, part 2"); + Info := Get_Info (String_Type_Definition); + Std_String_Node := Info.Ortho_Type (Mode_Value); + Std_String_Ptr_Node := Info.Ortho_Ptr_Type (Mode_Value); + Integer_Otype := Get_Ortho_Type (Integer_Type_Definition, Mode_Value); + Real_Otype := Get_Ortho_Type (Real_Type_Definition, Mode_Value); + Time_Otype := Get_Ortho_Type (Time_Type_Definition, Mode_Value); + + -- __ghdl_now : time; + -- ??? maybe this should be a function ? + New_Var_Decl (Ghdl_Now, Get_Identifier ("__ghdl_now"), + O_Storage_External, Time_Otype); + + -- procedure __ghdl_assert_failed (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + + -- procedure __ghdl_report (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + declare + procedure Create_Report_Subprg (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("msg"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("severity"), + Get_Ortho_Type (Severity_Level_Type_Definition, Mode_Value)); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("location"), + Ghdl_Location_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Report_Subprg; + begin + Create_Report_Subprg ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg ("__ghdl_report", Ghdl_Report); + end; + + New_Var_Decl (Ghdl_Assert_Default_Report, + Get_Identifier ("__ghdl_assert_default_report"), + O_Storage_External, + Get_Info (String_Type_Definition).Ortho_Type (Mode_Value)); + + -- procedure __ghdl_text_write (file : __ghdl_file_index; + -- str : std_string_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_write"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Write); + + -- function __ghdl_text_read_length (file : __ghdl_file_index; + -- str : std_string_ptr) + -- return std__standard_integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_read_length"), + O_Storage_External, Integer_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Read_Length); + + -- procedure __ghdl_write_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_write_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Write_Scalar); + + -- procedure __ghdl_read_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_read_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Read_Scalar); + + -- function __ghdl_real_exp (left : std__standard__real; + -- right : std__standard__integer) + -- return std__standard__real; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_real_exp"), O_Storage_External, + Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("left"), + Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("right"), + Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Real_Exp); + + -- function __ghdl_integer_exp (left : std__standard__integer; + -- right : std__standard__integer) + -- return std__standard__integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_integer_exp"), O_Storage_External, + Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Left, Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Right, Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Integer_Exp); + + + -- procedure __ghdl_image_b2 (res : std_string_ptr_node; + -- val : ghdl_bool_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("b2", Ghdl_Bool_Type, True, Ghdl_Image_B2, Ghdl_Value_B2); + + -- procedure __ghdl_image_e8 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("e8", Ghdl_I32_Type, True, Ghdl_Image_E8, Ghdl_Value_E8); + + -- procedure __ghdl_image_i32 (res : std_string_ptr_node; + -- val : ghdl_i32_type); + Create_Image_Value_Subprograms + ("i32", Ghdl_I32_Type, False, Ghdl_Image_I32, Ghdl_Value_I32); + + -- procedure __ghdl_image_p32 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("p32", Ghdl_I32_Type, True, Ghdl_Image_P32, Ghdl_Value_P32); + + -- procedure __ghdl_image_p64 (res : std_string_ptr_node; + -- val : ghdl_i64_type; + -- rti : ghdl_rti_access); + if not Flag_Only_32b then + Create_Image_Value_Subprograms + ("p64", Ghdl_I64_Type, True, Ghdl_Image_P64, Ghdl_Value_P64); + end if; + + -- procedure __ghdl_image_f64 (res : std_string_ptr_node; + -- val : ghdl_real_type); + Create_Image_Value_Subprograms + ("f64", Ghdl_Real_Type, False, Ghdl_Image_F64, Ghdl_Value_F64); + + ------------- + -- files -- + ------------- + + -- procedure __ghdl_text_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open); + + -- procedure __ghdl_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open); + + -- function __ghdl_text_file_open_status + -- (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open_Status); + + -- function __ghdl_file_open_status (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open_Status); + + -- function __ghdl_file_endfile (file : file_index_type) + -- return std_boolean_type_node; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_file_endfile"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Endfile); + + -- procedure __ghdl_text_file_close (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Close); + + -- procedure __ghdl_file_close (file : file_index_type); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Close); + + --------------- + -- signals -- + --------------- + + -- procedure __ghdl_signal_create_resolution + -- (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- sig : ghdl_ptr_type; + -- nbr_sig : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_resolution"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("nbr_sig"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Resolution); + + -- Declarations for signals. + -- Max length of a scalar type. + -- type __ghdl_scalar_bytes is __ghdl_chararray (0 .. 8); + Ghdl_Scalar_Bytes := New_Constrained_Array_Type + (Chararray_Type, New_Unsigned_Literal (Ghdl_Index_Type, 8)); + New_Type_Decl (Get_Identifier ("__ghdl_scalar_bytes"), + Ghdl_Scalar_Bytes); + -- Type __signal_signal is record + Start_Record_Type (Rec); + New_Record_Field (Rec, Ghdl_Signal_Value_Node, + Get_Identifier ("value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Driving_Value_Node, + Get_Identifier ("driving_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Value_Node, + Get_Identifier ("last_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Event_Node, + Get_Identifier ("last_event"), + Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Last_Active_Node, + Get_Identifier ("last_active"), + Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Event_Node, + Get_Identifier ("event"), + Std_Boolean_Type_Node); + New_Record_Field (Rec, Ghdl_Signal_Active_Node, + Get_Identifier ("active"), + Std_Boolean_Type_Node); + Finish_Record_Type (Rec, Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal"), Ghdl_Signal_Type); + + Ghdl_Signal_Ptr := New_Access_Type (Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr"), Ghdl_Signal_Ptr); + + Ghdl_Signal_Ptr_Ptr := New_Access_Type (Ghdl_Signal_Ptr); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr_ptr"), + Ghdl_Signal_Ptr_Ptr); + + -- procedure __ghdl_signal_merge_rti + -- (sig : ghdl_signal_ptr; rti : ghdl_rti_access) + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_merge_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Merge_Rti); + + -- procedure __ghdl_signal_add_source (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_add_source"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Source); + + -- procedure __ghdl_signal_effective_value (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_effective_value"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Effective_Value); + + -- procedure __ghdl_signal_set_disconnect (sig : __ghdl_signal_ptr; + -- val : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_set_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("time"), Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Set_Disconnect); + + -- procedure __ghdl_signal_disconnect (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Disconnect); + + -- function __ghdl_signal_get_nbr_drivers (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_drivers"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Drivers); + + -- function __ghdl_signal_get_nbr_sources (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_ports"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Ports); + + -- function __ghdl_signal_read_driver (sig : __ghdl_signal_ptr; + -- num : ghdl_index_type) + -- return ghdl_ptr_type; + declare + procedure Create_Signal_Read (Name : String; Subprg : out O_Dnode) is + begin + Start_Function_Decl + (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("num"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Signal_Read; + begin + Create_Signal_Read + ("__ghdl_signal_read_driver", Ghdl_Signal_Read_Driver); + Create_Signal_Read + ("__ghdl_signal_read_port", Ghdl_Signal_Read_Port); + end; + + -- function __ghdl_signal_driving (sig : __ghdl_signal_ptr) + -- return std_boolean; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Driving); + + -- procedure __ghdl_signal_simple_assign_error + -- (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Simple_Assign_Error); + + -- procedure __ghdl_signal_start_assign_error (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Error); + + -- procedure __ghdl_signal_next_assign_error (sig : __ghdl_signal_ptr; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Error); + + -- procedure __ghdl_signal_start_assign_null (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Null); + + -- procedure __ghdl_signal_next_assign_null (sig : __ghdl_signal_ptr; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("signal"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Null); + + -- function __ghdl_create_signal_enum8 (init_val : ghdl_i32_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_e8 (sign : __ghdl_signal_ptr; + -- val : __ghdl_integer); + Create_Signal_Subprograms ("e8", Ghdl_I32_Type, + Ghdl_Create_Signal_E8, + Ghdl_Signal_Init_E8, + Ghdl_Signal_Simple_Assign_E8, + Ghdl_Signal_Start_Assign_E8, + Ghdl_Signal_Next_Assign_E8, + Ghdl_Signal_Associate_E8, + Ghdl_Signal_Driving_Value_E8); + + -- function __ghdl_create_signal_b2 (init_val : ghdl_bool_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_b2 (sign : __ghdl_signal_ptr; + -- val : ghdl_bool_type); + Create_Signal_Subprograms ("b2", Ghdl_Bool_Type, + Ghdl_Create_Signal_B2, + Ghdl_Signal_Init_B2, + Ghdl_Signal_Simple_Assign_B2, + Ghdl_Signal_Start_Assign_B2, + Ghdl_Signal_Next_Assign_B2, + Ghdl_Signal_Associate_B2, + Ghdl_Signal_Driving_Value_B2); + + Create_Signal_Subprograms ("i32", Ghdl_I32_Type, + Ghdl_Create_Signal_I32, + Ghdl_Signal_Init_I32, + Ghdl_Signal_Simple_Assign_I32, + Ghdl_Signal_Start_Assign_I32, + Ghdl_Signal_Next_Assign_I32, + Ghdl_Signal_Associate_I32, + Ghdl_Signal_Driving_Value_I32); + + Create_Signal_Subprograms ("f64", Ghdl_Real_Type, + Ghdl_Create_Signal_F64, + Ghdl_Signal_Init_F64, + Ghdl_Signal_Simple_Assign_F64, + Ghdl_Signal_Start_Assign_F64, + Ghdl_Signal_Next_Assign_F64, + Ghdl_Signal_Associate_F64, + Ghdl_Signal_Driving_Value_F64); + + if not Flag_Only_32b then + Create_Signal_Subprograms ("i64", Ghdl_I64_Type, + Ghdl_Create_Signal_I64, + Ghdl_Signal_Init_I64, + Ghdl_Signal_Simple_Assign_I64, + Ghdl_Signal_Start_Assign_I64, + Ghdl_Signal_Next_Assign_I64, + Ghdl_Signal_Associate_I64, + Ghdl_Signal_Driving_Value_I64); + end if; + + -- procedure __ghdl_process_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Sensitivity); + + -- procedure __ghdl_process_add_driver (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_driver"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Driver); + + declare + procedure Create_Signal_Conversion (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src_len"), Ghdl_Index_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst_len"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Conversion; + begin + -- procedure __ghdl_signal_in_conversion (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- src : ghdl_signal_ptr; + -- src_len : ghdl_index_type; + -- dst : ghdl_signal_ptr; + -- dst_len : ghdl_index_type); + Create_Signal_Conversion + ("__ghdl_signal_in_conversion", Ghdl_Signal_In_Conversion); + Create_Signal_Conversion + ("__ghdl_signal_out_conversion", Ghdl_Signal_Out_Conversion); + end; + + declare + -- function __ghdl_create_XXX_signal (val : std_time) + -- return __ghdl_signal_ptr; + procedure Create_Signal_Attribute (Name : String; Res : out O_Dnode) + is + begin + Start_Function_Decl (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Attribute; + begin + -- function __ghdl_create_stable_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_stable_signal", Ghdl_Create_Stable_Signal); + + -- function __ghdl_create_quiet_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_quiet_signal", Ghdl_Create_Quiet_Signal); + + -- function __ghdl_create_transaction_signal + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_transaction_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Transaction_Signal); + end; + + -- procedure __ghdl_signal_attribute_register_prefix + -- (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, + Get_Identifier ("__ghdl_signal_attribute_register_prefix"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl + (Interfaces, Ghdl_Signal_Attribute_Register_Prefix); + + -- function __ghdl_create_delayed_signal (sig : __ghdl_signal_ptr; + -- val : std_time) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_delayed_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("sig"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Delayed_Signal); + + -- function __ghdl_signal_create_guard + -- (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- instance_name : __ghdl_instance_name_acc) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_guard"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("this"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("proc"), + Ghdl_Ptr_Type); +-- New_Interface_Decl (Interfaces, Param, Get_Identifier ("instance_name"), +-- Ghdl_Instance_Name_Acc); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Guard); + + -- procedure __ghdl_signal_guard_dependence (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_guard_dependence"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Guard_Dependence); + + -- procedure __ghdl_process_wait_exit (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_exit"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Exit); + + -- void __ghdl_process_wait_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Timeout); + + -- void __ghdl_process_wait_set_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_set_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Set_Timeout); + + -- void __ghdl_process_wait_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Add_Sensitivity); + + -- function __ghdl_process_wait_suspend return __ghdl_bool_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_suspend"), + O_Storage_External, Ghdl_Bool_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Suspend); + + -- void __ghdl_process_wait_close (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_close"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Close); + + declare + procedure Create_Get_Name (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Get_Name; + begin + -- procedure __ghdl_get_path_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_path_name", Ghdl_Get_Path_Name); + + -- procedure __ghdl_get_instance_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_instance_name", Ghdl_Get_Instance_Name); + end; + end Post_Initialize; + + procedure Translate_Std_Type_Declaration (Decl : Iir) + is + Chain : Iir; + Infos : Chap7.Implicit_Subprogram_Infos; + begin + case Get_Kind (Decl) is + when Iir_Kind_Type_Declaration => + Chap4.Translate_Type_Declaration (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Chap4.Translate_Anonymous_Type_Declaration (Decl); + when others => + Error_Kind ("translate_std_type_declaration", Decl); + end case; + + -- Also declares the subprograms. + Chain := Get_Chain (Decl); + Chap7.Init_Implicit_Subprogram_Infos (Infos); + while Chain /= Null_Iir loop + case Get_Kind (Chain) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Chap7.Translate_Implicit_Subprogram (Chain, Infos); + Chain := Get_Chain (Chain); + when others => + exit; + end case; + end loop; + end Translate_Std_Type_Declaration; + + procedure Translate_Standard (Main : Boolean) + is + use Std_Package; + Lib_Mark, Unit_Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + begin + Update_Node_Infos; + + New_Debug_Comment_Decl ("package std.standard"); + if Main then + Gen_Filename (Std_Standard_File); + Set_Global_Storage (O_Storage_Public); + else + Set_Global_Storage (O_Storage_External); + end if; + + Info := Add_Info (Standard_Package, Kind_Package); + + Reset_Identifier_Prefix; + Push_Identifier_Prefix + (Lib_Mark, Get_Identifier (Libraries.Std_Library)); + Push_Identifier_Prefix + (Unit_Mark, Get_Identifier (Standard_Package)); + + Chap4.Translate_Bool_Type_Declaration (Boolean_Type); + -- We need this type very early, for predefined functions. + Std_Boolean_Type_Node := + Get_Ortho_Type (Boolean_Type_Definition, Mode_Value); + Std_Boolean_True_Node := Get_Ortho_Expr (Boolean_True); + Std_Boolean_False_Node := Get_Ortho_Expr (Boolean_False); + + Chap4.Translate_Bool_Type_Declaration (Bit_Type); + + Chap4.Translate_Type_Declaration (Character_Type); + + Chap4.Translate_Type_Declaration (Severity_Level_Type); + + Chap4.Translate_Anonymous_Type_Declaration (Universal_Integer_Type); + Chap4.Translate_Subtype_Declaration (Universal_Integer_Subtype); + + Chap4.Translate_Anonymous_Type_Declaration (Universal_Real_Type); + Chap4.Translate_Subtype_Declaration (Universal_Real_Subtype); + + Chap4.Translate_Anonymous_Type_Declaration (Convertible_Integer_Type); + Chap4.Translate_Anonymous_Type_Declaration (Convertible_Real_Type); + + Translate_Std_Type_Declaration (Real_Type); + Std_Real_Type_Node := Get_Ortho_Type (Real_Type_Definition, Mode_Value); + Chap4.Translate_Subtype_Declaration (Real_Subtype); + + Translate_Std_Type_Declaration (Integer_Type); + Std_Integer_Type_Node := Get_Ortho_Type + (Integer_Type_Definition, Mode_Value); + Chap4.Translate_Subtype_Declaration (Integer_Subtype); + Chap4.Translate_Subtype_Declaration (Natural_Subtype); + Chap4.Translate_Subtype_Declaration (Positive_Subtype); + + Translate_Std_Type_Declaration (String_Type); + + Translate_Std_Type_Declaration (Bit_Vector_Type); + + declare + Type_Staticness : Iir_Staticness; + Subtype_Staticness : Iir_Staticness; + begin + -- With VHDL93 and later, time type is globally static. As a result, + -- it will be elaborated at run-time (and not statically). + -- However, there is no elaboration of std.standard. Furthermore, + -- time type can be pre-elaborated without any difficulties. + -- There is a kludge here: set type staticess of time type locally + -- and then revert it just after its translation. + Type_Staticness := Get_Type_Staticness (Time_Type_Definition); + Subtype_Staticness := Get_Type_Staticness (Time_Subtype_Definition); + if Flags.Flag_Time_64 then + Set_Type_Staticness (Time_Type_Definition, Locally); + end if; + Set_Type_Staticness (Time_Subtype_Definition, Locally); + + Translate_Std_Type_Declaration (Time_Type); + Chap4.Translate_Subtype_Declaration (Time_Subtype); + + if Flags.Vhdl_Std > Vhdl_87 then + Set_Type_Staticness (Delay_Length_Subtype_Definition, Locally); + Chap4.Translate_Subtype_Declaration (Delay_Length_Subtype); + Set_Type_Staticness (Delay_Length_Subtype_Definition, + Subtype_Staticness); + end if; + + Set_Type_Staticness (Time_Type_Definition, Type_Staticness); + Set_Type_Staticness (Time_Subtype_Definition, Subtype_Staticness); + end; + Std_Time_Type := Get_Ortho_Type (Time_Type_Definition, Mode_Value); + + if Flags.Vhdl_Std > Vhdl_87 then + Translate_Std_Type_Declaration (File_Open_Kind_Type); + Translate_Std_Type_Declaration (File_Open_Status_Type); + Std_File_Open_Status_Type := + Get_Ortho_Type (File_Open_Status_Type_Definition, Mode_Value); + end if; + + if Flag_Rti then + Rtis.Generate_Unit (Standard_Package); + Std_Standard_Boolean_Rti + := Get_Info (Boolean_Type_Definition).Type_Rti; + Std_Standard_Bit_Rti + := Get_Info (Bit_Type_Definition).Type_Rti; + end if; + + Pop_Identifier_Prefix (Unit_Mark); + Pop_Identifier_Prefix (Lib_Mark); + + Post_Initialize; + Current_Filename_Node := O_Dnode_Null; + --Pop_Global_Factory; + end Translate_Standard; + + procedure Finalize + is + Info : Ortho_Info_Acc; + Prev_Info : Ortho_Info_Acc; + begin + Prev_Info := null; + for I in Node_Infos.First .. Node_Infos.Last loop + Info := Get_Info (I); + if Info /= null and then Info /= Prev_Info then + case Get_Kind (I) is + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration_Flag (I) = False + and then Get_Deferred_Declaration (I) /= Null_Iir + then + -- Info are copied from incomplete constant declaration + -- to full constant declaration. + Clear_Info (I); + else + Free_Info (I); + end if; + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_Unconstrained_Array_Subtype_Definition => + null; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Free_Type_Info (Info, True); + when Iir_Kind_Array_Subtype_Definition => + Free_Var (Info.T.Array_Bounds); + Info.T := Ortho_Info_Type_Array_Init; + Free_Type_Info (Info, True); + when others => + -- By default, info are not shared. + -- The exception is infos for implicit subprograms, but + -- they are always consecutive and not free twice due to + -- prev_info mechanism. + Free_Info (I); + end case; + Prev_Info := Info; + end if; + end loop; + Node_Infos.Free; + Free_Old_Temp; + end Finalize; + + package body Chap12 is + -- Create __ghdl_ELABORATE + procedure Gen_Main (Entity : Iir_Entity_Declaration; + Arch : Iir_Architecture_Declaration; + Config_Subprg : O_Dnode) + 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; + begin + Arch_Info := Get_Info (Arch); + Entity_Info := Get_Info (Entity); + + -- We need to create code. + Set_Global_Storage (O_Storage_Private); + + New_Var_Decl + (Ghdl_Rti_Top_Instance, Get_Identifier ("__ghdl_rti_top_instance"), + O_Storage_External, Ghdl_Ptr_Type); + + New_Var_Decl (Ghdl_Rti_Top_Ptr, + Get_Identifier ("__ghdl_rti_top_ptr"), + O_Storage_External, Ghdl_Ptr_Type); + + + -- Declare (but do not define): + -- Variable for the hierarchy top instance. + + 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 (New_Sizeof (Arch_Info.Block_Decls_Type, + Ghdl_Index_Type)), + 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. + New_Assign_Stmt (New_Obj (Ghdl_Rti_Top_Instance), + New_Convert_Ov (New_Obj_Value (Arch_Instance), + Ghdl_Ptr_Type)); + + New_Assign_Stmt (New_Obj (Ghdl_Rti_Top_Ptr), + New_Unchecked_Address (New_Obj (Ghdl_Rti_Top), + Ghdl_Ptr_Type)); + + Gen_Filename (Get_Design_File (Get_Design_Unit (Entity))); + + -- init instance + Push_Scope (Entity_Info.Block_Decls_Type, Instance); + 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_Scope (Entity_Info.Block_Decls_Type); + Finish_Subprogram_Body; + + Current_Filename_Node := O_Dnode_Null; + end Gen_Main; + + procedure Gen_Setup_Info + is + Cst : O_Dnode; + begin + Cst := Create_String (Flags.Flag_String, + Get_Identifier ("__ghdl_flag_string"), + O_Storage_Public); + end Gen_Setup_Info; + + -- Return TRUE iff ENTITY can be at the top of a hierarchy, ie: + -- ENTITY has no generics or all generics have a default expression + -- ENTITY has no ports or all ports type are constrained. + procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration) + is + Has_Error : Boolean := False; + + procedure Error (Msg : String; Loc : Iir) is + begin + if not Has_Error then + Error_Msg_Elab + (Disp_Node (Entity) & " cannot be at the top of a design"); + Has_Error := True; + end if; + Error_Msg_Elab (Msg, Loc); + end Error; + + El : Iir; + begin + -- Check generics. + El := Get_Generic_Chain (Entity); + while El /= Null_Iir loop + if Get_Default_Value (El) = Null_Iir then + Error ("(" & Disp_Node (El) & " has no default value)", El); + end if; + El := Get_Chain (El); + end loop; + + -- Check port. + El := Get_Port_Chain (Entity); + while El /= Null_Iir loop + if Get_Kind (Get_Type (El)) in + Iir_Kinds_Unconstrained_Array_Type_Definition + and then Get_Default_Value (El) = Null_Iir + then + Error ("(" & Disp_Node (El) + & " is unconstrained and has no default value)", El); + end if; + El := Get_Chain (El); + end loop; + end Check_Entity_Declaration_Top; + + procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration) + is + Entity_Info : Block_Info_Acc; + + Arch : Iir_Architecture_Declaration; + 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, New_Sizeof (Arch_Info.Block_Decls_Type, Ghdl_Index_Type)); + + -- 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_Declaration) + 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); + 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. + 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); + + 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_Declaration => + 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; + 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_Declaration; + Conf_Info : Config_Info_Acc; + Last_Design_Unit : 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_Library_Unit (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); + if Get_Analysis_Checks_List (Unit) /= Null_Iir_List then + -- There cannot be remaining checks to do. + raise Internal_Error; + end if; + 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_Declaration + | Iir_Kind_Package_Declaration => + Set_Elab_Flag (Unit, False); + Translate (Unit, Whole); + when Iir_Kind_Package_Body => + 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. + 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_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration => + null; + when others => + Error_Kind ("elaborate(2)", Lib_Unit); + end case; + end loop; + + if Flag_Rti then + Rtis.Generate_Top (Arch); + end if; + + -- Create main code. + Conf_Info := Get_Info (Config_Lib); + Gen_Main (Entity, Arch, Conf_Info.Config_Subprg); + + 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; |