diff options
Diffstat (limited to 'src/vhdl/translate/translation.adb')
| -rw-r--r-- | src/vhdl/translate/translation.adb | 31355 |
1 files changed, 31355 insertions, 0 deletions
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb new file mode 100644 index 000000000..7c5fbe85c --- /dev/null +++ b/src/vhdl/translate/translation.adb @@ -0,0 +1,31355 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002, 2003, 2004, 2005, 2006 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; +with Ortho_Nodes; use Ortho_Nodes; +with Ortho_Ident; use Ortho_Ident; +with Evaluation; use Evaluation; +with Flags; use Flags; +with Ada.Text_IO; +with Types; use Types; +with Errorout; use Errorout; +with Name_Table; -- use Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Libraries; +with Files_Map; +with Std_Names; +with Configuration; +with Interfaces.C_Streams; +with Sem_Names; +with Sem_Inst; +with Sem; +with Iir_Chains; use Iir_Chains; +with Nodes; +with Nodes_Meta; +with GNAT.Table; +with Ieee.Std_Logic_1164; +with Canon; +with Canon_PSL; +with PSL.Nodes; +with PSL.NFAs; +with PSL.NFAs.Utils; +with Trans_Decls; use Trans_Decls; +with Trans_Analyzes; + +package body Translation is + + -- Ortho type node for STD.BOOLEAN. + Std_Boolean_Type_Node : O_Tnode; + Std_Boolean_True_Node : O_Cnode; + Std_Boolean_False_Node : O_Cnode; + -- Array of STD.BOOLEAN. + Std_Boolean_Array_Type : O_Tnode; + -- Std_ulogic indexed array of STD.Boolean. + Std_Ulogic_Boolean_Array_Type : O_Tnode; + -- Ortho type node for string template pointer. + Std_String_Ptr_Node : O_Tnode; + Std_String_Node : O_Tnode; + + -- Ortho type for std.standard.integer. + Std_Integer_Otype : O_Tnode; + + -- Ortho type for std.standard.real. + Std_Real_Otype : O_Tnode; + + -- Ortho type node for std.standard.time. + Std_Time_Otype : O_Tnode; + + -- Node for the variable containing the current filename. + Current_Filename_Node : O_Dnode := O_Dnode_Null; + Current_Library_Unit : Iir := Null_Iir; + + -- Global declarations. + Ghdl_Ptr_Type : O_Tnode; + Sizetype : O_Tnode; + Ghdl_I32_Type : O_Tnode; + Ghdl_I64_Type : O_Tnode; + Ghdl_Real_Type : O_Tnode; + -- Constant character. + Char_Type_Node : O_Tnode; + -- Array of char. + Chararray_Type : O_Tnode; + -- Pointer to array of char. + Char_Ptr_Type : O_Tnode; + -- Array of char ptr. + Char_Ptr_Array_Type : O_Tnode; + Char_Ptr_Array_Ptr_Type : O_Tnode; + + Ghdl_Index_Type : O_Tnode; + Ghdl_Index_0 : O_Cnode; + Ghdl_Index_1 : O_Cnode; + + -- Type for a file (this is in fact a index in a private table). + Ghdl_File_Index_Type : O_Tnode; + Ghdl_File_Index_Ptr_Type : O_Tnode; + + -- Record containing a len and string fields. + Ghdl_Str_Len_Type_Node : O_Tnode; + Ghdl_Str_Len_Type_Len_Field : O_Fnode; + Ghdl_Str_Len_Type_Str_Field : O_Fnode; + Ghdl_Str_Len_Ptr_Node : O_Tnode; + Ghdl_Str_Len_Array_Type_Node : O_Tnode; + + -- Location. + Ghdl_Location_Type_Node : O_Tnode; + Ghdl_Location_Filename_Node : O_Fnode; + Ghdl_Location_Line_Node : O_Fnode; + Ghdl_Location_Col_Node : O_Fnode; + Ghdl_Location_Ptr_Node : O_Tnode; + + -- Allocate memory for a block. + Ghdl_Alloc_Ptr : O_Dnode; + + -- bool type. + Ghdl_Bool_Type : O_Tnode; + type Enode_Boolean_Array is array (Boolean) of O_Cnode; + Ghdl_Bool_Nodes : Enode_Boolean_Array; + Ghdl_Bool_False_Node : O_Cnode renames Ghdl_Bool_Nodes (False); + Ghdl_Bool_True_Node : O_Cnode renames Ghdl_Bool_Nodes (True); + + Ghdl_Bool_Array_Type : O_Tnode; + Ghdl_Bool_Array_Ptr : O_Tnode; + + -- Comparaison type. + Ghdl_Compare_Type : O_Tnode; + Ghdl_Compare_Lt : O_Cnode; + Ghdl_Compare_Eq : O_Cnode; + Ghdl_Compare_Gt : O_Cnode; + + -- Dir type. + Ghdl_Dir_Type_Node : O_Tnode; + Ghdl_Dir_To_Node : O_Cnode; + Ghdl_Dir_Downto_Node : O_Cnode; + + -- Signals. + Ghdl_Scalar_Bytes : O_Tnode; + Ghdl_Signal_Type : O_Tnode; + Ghdl_Signal_Value_Field : O_Fnode; + Ghdl_Signal_Driving_Value_Field : O_Fnode; + Ghdl_Signal_Last_Value_Field : O_Fnode; + Ghdl_Signal_Last_Event_Field : O_Fnode; + Ghdl_Signal_Last_Active_Field : O_Fnode; + Ghdl_Signal_Event_Field : O_Fnode; + Ghdl_Signal_Active_Field : O_Fnode; + Ghdl_Signal_Has_Active_Field : O_Fnode; + + Ghdl_Signal_Ptr : O_Tnode; + Ghdl_Signal_Ptr_Ptr : O_Tnode; + + type Object_Kind_Type is (Mode_Value, Mode_Signal); + + -- Well known identifiers. + Wki_This : O_Ident; + Wki_Size : O_Ident; + Wki_Res : O_Ident; + Wki_Dir_To : O_Ident; + Wki_Dir_Downto : O_Ident; + Wki_Left : O_Ident; + Wki_Right : O_Ident; + Wki_Dir : O_Ident; + Wki_Length : O_Ident; + Wki_I : O_Ident; + Wki_Instance : O_Ident; + Wki_Arch_Instance : O_Ident; + Wki_Name : O_Ident; + Wki_Sig : O_Ident; + Wki_Obj : O_Ident; + Wki_Rti : O_Ident; + Wki_Parent : O_Ident; + Wki_Filename : O_Ident; + Wki_Line : O_Ident; + Wki_Lo : O_Ident; + Wki_Hi : O_Ident; + Wki_Mid : O_Ident; + Wki_Cmp : O_Ident; + Wki_Upframe : O_Ident; + Wki_Frame : O_Ident; + Wki_Val : O_Ident; + Wki_L_Len : O_Ident; + Wki_R_Len : O_Ident; + + -- ALLOCATION_KIND defines the type of memory storage. + -- ALLOC_STACK means the object is allocated on the local stack and + -- deallocated at the end of the function. + -- ALLOC_SYSTEM for object created during design elaboration and whose + -- life is infinite. + -- ALLOC_RETURN for unconstrained object returns by function. + -- ALLOC_HEAP for object created by new. + type Allocation_Kind is + (Alloc_Stack, Alloc_Return, Alloc_Heap, Alloc_System); + + package Chap10 is + -- There are three data storage kind: global, local or instance. + -- For example, a constant can have: + -- * a global storage when declared inside a package. This storage + -- can be accessed from any point. + -- * a local storage when declared in a subprogram. This storage + -- can be accessed from the subprogram, is created when the subprogram + -- is called and destroy when the subprogram exit. + -- * an instance storage when declared inside a process. This storage + -- can be accessed from the process via an instance pointer, is + -- created during elaboration. + --procedure Push_Global_Factory (Storage : O_Storage); + --procedure Pop_Global_Factory; + procedure Set_Global_Storage (Storage : O_Storage); + + -- Set the global scope handling. + Global_Storage : O_Storage; + + -- Scope for variables. This is used both to build instances (so it + -- contains the record type that contains objects declared in that + -- scope) and to use instances (it contains the path to access to these + -- objects). + type Var_Scope_Type is private; + + type Var_Scope_Acc is access all Var_Scope_Type; + for Var_Scope_Acc'Storage_Size use 0; + + Null_Var_Scope : constant Var_Scope_Type; + + type Var_Type is private; + Null_Var : constant Var_Type; + + -- Return the record type for SCOPE. + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode; + + -- Return the size for instances of SCOPE. + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode; + + -- Return True iff SCOPE is defined. + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean; + + -- Create an empty and incomplete scope type for SCOPE using NAME. + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident); + + -- Declare a pointer PTR_TYPE with NAME to scope type SCOPE. + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode); + + -- Start to build an instance. + -- If INSTANCE_TYPE is not O_TNODE_NULL, it must be an uncompleted + -- record type, that will be completed. + procedure Push_Instance_Factory (Scope : Var_Scope_Acc); + + -- Manually add a field to the current instance being built. + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode; + + -- In the scope being built, add a field NAME that contain sub-scope + -- CHILD. CHILD is modified so that accesses to CHILD objects is done + -- via SCOPE. + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type); + + -- Return the offset of field for CHILD in its parent scope. + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode; + + -- Finish the building of the current instance and return the type + -- built. + procedure Pop_Instance_Factory (Scope : Var_Scope_Acc); + + -- Create a new scope, in which variable are created locally + -- (ie, on the stack). Always created unlocked. + procedure Push_Local_Factory; + + -- Destroy a local scope. + procedure Pop_Local_Factory; + + -- Set_Scope defines how to access to variables of SCOPE. + -- Variables defined in SCOPE can be accessed via field SCOPE_FIELD + -- in scope SCOPE_PARENT. + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + + -- Variables defined in SCOPE can be accessed by dereferencing + -- field SCOPE_FIELD defined in SCOPE_PARENT. + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + + -- Variables/scopes defined in SCOPE can be accessed via + -- dereference of parameter SCOPE_PARAM. + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode); + + -- Variables/scopes defined in SCOPE can be accessed via DECL. + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode); + + -- Variables/scopes defined in SCOPE can be accessed by derefencing + -- VAR. + procedure Set_Scope_Via_Var_Ptr + (Scope : in out Var_Scope_Type; Var : Var_Type); + + -- No more accesses to SCOPE_TYPE are allowed. Scopes must be cleared + -- before being set. + procedure Clear_Scope (Scope : in out Var_Scope_Type); + + -- Reset the identifier. + type Id_Mark_Type is limited private; + type Local_Identifier_Type is private; + + procedure Reset_Identifier_Prefix; + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : Name_Id; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type); + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type); + + -- Save/restore the local identifier number; this is used by package + -- body, which has the same prefix as the package declaration, so it + -- must continue local identifiers numbers. + -- This is used by subprogram bodies too. + procedure Save_Local_Identifier (Id : out Local_Identifier_Type); + procedure Restore_Local_Identifier (Id : Local_Identifier_Type); + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) + return O_Ident; + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident; + + -- Create an identifier from the current prefix. + function Create_Identifier return O_Ident; + + -- Create an identifier from IIR node ID with prefix. + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident; + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident; + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident; + -- Create a prefixed identifier from a string. + function Create_Identifier (Str : String) return O_Ident; + + -- Create an identifier for a variable. + -- IE, if the variable is global, prepend the prefix, + -- if the variable belong to an instance, no prefix is added. + type Var_Ident_Type is private; + function Create_Var_Identifier (Id : Iir) return Var_Ident_Type; + function Create_Var_Identifier (Id : String) return Var_Ident_Type; + function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) + return Var_Ident_Type; + function Create_Uniq_Identifier return Var_Ident_Type; + + -- Create variable NAME of type VTYPE in the current scope. + -- If the current scope is the global scope, then a variable is + -- created at the top level (using decl_global_storage). + -- If the current scope is not the global scope, then a field is added + -- to the current scope. + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Type; + + -- Create a global variable. + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Type; + + -- Create a global constant and initialize it to INITIAL_VALUE. + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Type; + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode); + + -- Return the (real) reference to a variable created by Create_Var. + function Get_Var (Var : Var_Type) return O_Lnode; + + -- Return a reference to the instance of type ITYPE. + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode; + + -- Return the address of the instance for block BLOCK. + function Get_Instance_Access (Block : Iir) return O_Enode; + + -- Return the storage for the variable VAR. + function Get_Alloc_Kind_For_Var (Var : Var_Type) return Allocation_Kind; + + -- Return TRUE iff VAR is stable, ie get_var (VAR) can be referenced + -- several times. + function Is_Var_Stable (Var : Var_Type) return Boolean; + + -- Used only to generate RTI. + function Is_Var_Field (Var : Var_Type) return Boolean; + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode; + function Get_Var_Label (Var : Var_Type) return O_Dnode; + + -- For package instantiation. + + -- Associate INST_SCOPE as the instantiated scope for ORIG_SCOPE. + procedure Push_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc); + + -- Remove the association for INST_SCOPE. + procedure Pop_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc); + + -- Get the associated instantiated scope for SCOPE. + function Instantiated_Var_Scope (Scope : Var_Scope_Acc) + return Var_Scope_Acc; + + -- Create a copy of VAR using instantiated scope (if needed). + function Instantiate_Var (Var : Var_Type) return Var_Type; + + -- Create a copy of SCOPE using instantiated scope (if needed). + function Instantiate_Var_Scope (Scope : Var_Scope_Type) + return Var_Scope_Type; + private + type Local_Identifier_Type is new Natural; + type Id_Mark_Type is record + Len : Natural; + Local_Id : Local_Identifier_Type; + end record; + + type Var_Ident_Type is record + Id : O_Ident; + end record; + + -- An instance contains all the data (variable, signals, constant...) + -- which are declared by an entity and an architecture. + -- (An architecture inherits the data of its entity). + -- + -- The processes and implicit guard signals of an entity/architecture + -- are translated into functions. The first argument of these functions + -- is a pointer to the instance. + + type Inst_Build_Kind_Type is (Local, Global, Instance); + type Inst_Build_Type (Kind : Inst_Build_Kind_Type); + type Inst_Build_Acc is access Inst_Build_Type; + type Inst_Build_Type (Kind : Inst_Build_Kind_Type) is record + Prev : Inst_Build_Acc; + Prev_Id_Start : Natural; + case Kind is + when Local => + -- Previous global storage. + Prev_Global_Storage : O_Storage; + when Global => + null; + when Instance => + Scope : Var_Scope_Acc; + Elements : O_Element_List; + end case; + end record; + + -- Kind of variable: + -- VAR_NONE: the variable doesn't exist. + -- VAR_GLOBAL: the variable is a global variable (static or not). + -- VAR_LOCAL: the variable is on the stack. + -- VAR_SCOPE: the variable is in the instance record. + type Var_Kind is (Var_None, Var_Global, Var_Local, Var_Scope); + + type Var_Type (Kind : Var_Kind := Var_None) is record + case Kind is + when Var_None => + null; + when Var_Global + | Var_Local => + E : O_Dnode; + when Var_Scope => + I_Field : O_Fnode; + I_Scope : Var_Scope_Acc; + end case; + end record; + + Null_Var : constant Var_Type := (Kind => Var_None); + + type Var_Scope_Kind is (Var_Scope_None, + Var_Scope_Ptr, + Var_Scope_Decl, + Var_Scope_Field, + Var_Scope_Field_Ptr); + + type Var_Scope_Type (Kind : Var_Scope_Kind := Var_Scope_None) is record + Scope_Type : O_Tnode := O_Tnode_Null; + + case Kind is + when Var_Scope_None => + -- Not set, cannot be referenced. + null; + when Var_Scope_Ptr + | Var_Scope_Decl => + -- Instance for entity, architecture, component, subprogram, + -- resolver, process, guard function, PSL directive, PSL cover, + -- PSL assert, component instantiation elaborator + D : O_Dnode; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + -- For an entity: the architecture. + -- For an architecture: ptr to a generate subblock. + -- For a subprogram: parent frame + Field : O_Fnode; + Up_Link : Var_Scope_Acc; + end case; + end record; + + Null_Var_Scope : constant Var_Scope_Type := (Scope_Type => O_Tnode_Null, + Kind => Var_Scope_None); + + end Chap10; + use Chap10; + + package Chap1 is + -- Declare types for block BLK + procedure Start_Block_Decl (Blk : Iir); + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration); + + -- Generate code to initialize generics of instance INSTANCE of ENTITY + -- using the default values. + -- This is used when ENTITY is at the top of a design hierarchy. + procedure Translate_Entity_Init (Entity : Iir); + + procedure Translate_Architecture_Body (Arch : Iir); + + -- CONFIG may be one of: + -- * configuration_declaration + -- * component_configuration + procedure Translate_Configuration_Declaration (Config : Iir); + end Chap1; + + package Chap2 is + -- Subprogram specification being currently translated. This is used + -- for the return statement. + Current_Subprogram : Iir := Null_Iir; + + procedure Translate_Subprogram_Interfaces (Spec : Iir); + procedure Elab_Subprogram_Interfaces (Spec : Iir); + + procedure Translate_Subprogram_Declaration (Spec : Iir); + procedure Translate_Subprogram_Body (Subprg : Iir); + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type); + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration); + procedure Translate_Package_Body (Decl : Iir_Package_Body); + procedure Translate_Package_Instantiation_Declaration (Inst : Iir); + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir); + + -- Add info for an interface_package_declaration or a + -- package_instantiation_declaration + procedure Instantiate_Info_Package (Inst : Iir); + + -- Elaborate packages that DESIGN_UNIT depends on (except std.standard). + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit); + + -- Declare an incomplete record type DECL_TYPE and access PTR_TYPE to + -- it. The names are respectively INSTTYPE and INSTPTR. + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode); + + -- Subprograms instances. + -- + -- Subprograms declared inside entities, architecture, blocks + -- or processes (but not inside packages) may access to data declared + -- outside the subprogram (and this with a life longer than the + -- subprogram life). These data correspond to constants, variables, + -- files, signals or types. However these data are not shared between + -- instances of the same entity, architecture... Subprograms instances + -- is the way subprograms access to these data. + -- One subprogram instance corresponds to a record. + + -- Type to save an old instance builder. Subprograms may have at most + -- one instance. If they need severals (for example a protected + -- subprogram), the most recent one will have a reference to the + -- previous one. + type Subprg_Instance_Stack is limited private; + + -- Declare an instance to be added for subprograms. + -- DECL is the node for which the instance is created. This is used by + -- PUSH_SCOPE. + -- PTR_TYPE is a pointer to DECL_TYPE. + -- IDENT is an identifier for the interface. + -- The previous instance is stored to PREV. It must be restored with + -- Pop_Subprg_Instance. + -- Add_Subprg_Instance_Interfaces will add an interface of name IDENT + -- and type PTR_TYPE for every instance declared by + -- PUSH_SUBPRG_INSTANCE. + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + Prev : out Subprg_Instance_Stack); + + -- Since local subprograms has a direct access to its father interfaces, + -- they do not required instances interfaces. + -- These procedures are provided to temporarly disable the addition of + -- instances interfaces. Use Pop_Subpg_Instance to restore to the + -- previous state. + procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack); + + -- Revert of the previous subprogram. + -- Instances must be removed in opposite order they are added. + procedure Pop_Subprg_Instance (Ident : O_Ident; + Prev : Subprg_Instance_Stack); + + -- True iff there is currently a subprogram instance. + function Has_Current_Subprg_Instance return Boolean; + + -- Contains the subprogram interface for the instance. + type Subprg_Instance_Type is private; + Null_Subprg_Instance : constant Subprg_Instance_Type; + + -- Add interfaces during the creation of a subprogram. + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type); + + -- Add a field in the current factory that reference the current + -- instance. + procedure Add_Subprg_Instance_Field (Field : out O_Fnode); + + -- Associate values to the instance interface during invocation of a + -- subprogram. + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type); + + -- Get the value to be associated to the instance interface. + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode; + + -- True iff VARS is associated with an instance. + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean; + + -- Assign the instance field FIELD of VAR. + procedure Set_Subprg_Instance_Field + (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type); + + -- To be called at the beginning and end of a subprogram body creation. + -- Call PUSH_SCOPE for the subprogram intances. + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type); + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type); + + -- Call Push_Scope to reference instance from FIELD. + procedure Start_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode); + procedure Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode); + + -- Same as above, but for IIR. + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir); + + procedure Start_Subprg_Instance_Use (Subprg : Iir); + procedure Finish_Subprg_Instance_Use (Subprg : Iir); + + function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) + return Subprg_Instance_Type; + private + type Subprg_Instance_Type is record + Inter : O_Dnode; + Inter_Type : O_Tnode; + Scope : Var_Scope_Acc; + end record; + Null_Subprg_Instance : constant Subprg_Instance_Type := + (O_Dnode_Null, O_Tnode_Null, null); + + type Subprg_Instance_Stack is record + Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + end record; + + Null_Subprg_Instance_Stack : constant Subprg_Instance_Stack := + (null, O_Tnode_Null, O_Ident_Nul); + + Current_Subprg_Instance : Subprg_Instance_Stack := + Null_Subprg_Instance_Stack; + end Chap2; + + package Chap5 is + -- Attribute specification. + procedure Translate_Attribute_Specification + (Spec : Iir_Attribute_Specification); + procedure Elab_Attribute_Specification + (Spec : Iir_Attribute_Specification); + + -- Disconnection specification. + procedure Elab_Disconnection_Specification + (Spec : Iir_Disconnection_Specification); + + -- Elab an unconstrained port. + procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir); + + procedure Elab_Generic_Map_Aspect (Mapping : Iir); + + -- There are 4 cases of generic/port map: + -- 1) component instantiation + -- 2) component configuration (association of a component with an entity + -- / architecture) + -- 3) block header + -- 4) direct (entity + architecture or configuration) instantiation + -- + -- MAPPING is the node containing the generic/port map aspects. + procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir); + end Chap5; + + + package Chap8 is + procedure Translate_Statements_Chain (First : Iir); + + -- Return true if there is a return statement in the chain. + function Translate_Statements_Chain_Has_Return (First : Iir) + return Boolean; + + -- Create a case branch for CHOICE. + -- Used by case statement and aggregates. + procedure Translate_Case_Choice + (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block); + + -- Inc or dec by VAL ITERATOR according to DIR. + -- Used for loop statements. + procedure Gen_Update_Iterator (Iterator : O_Dnode; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir); + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir); + end Chap8; + + package Chap9 is + procedure Translate_Block_Declarations (Block : Iir; Origin : Iir); + procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir); + procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir); + + -- Generate code to instantiate an entity. + -- ASPECT must be an entity_aspect. + -- MAPPING must be a node with get_port/generic_map_aspect_list. + -- PARENT is the block in which the instantiation is done. + -- CONFIG_OVERRIDE, if set, is the configuration to use; if not set, the + -- configuration to use is determined from ASPECT. + procedure Translate_Entity_Instantiation + (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir); + + end Chap9; + + package Rtis is + -- Run-Time Information (RTI) Kind. + Ghdl_Rtik : O_Tnode; + Ghdl_Rtik_Top : O_Cnode; + Ghdl_Rtik_Library : O_Cnode; + Ghdl_Rtik_Package : O_Cnode; + Ghdl_Rtik_Package_Body : O_Cnode; + Ghdl_Rtik_Entity : O_Cnode; + Ghdl_Rtik_Architecture : O_Cnode; + Ghdl_Rtik_Process : O_Cnode; + Ghdl_Rtik_Block : O_Cnode; + Ghdl_Rtik_If_Generate : O_Cnode; + Ghdl_Rtik_For_Generate : O_Cnode; + Ghdl_Rtik_Instance : O_Cnode; + Ghdl_Rtik_Constant : O_Cnode; + Ghdl_Rtik_Iterator : O_Cnode; + Ghdl_Rtik_Variable : O_Cnode; + Ghdl_Rtik_Signal : O_Cnode; + Ghdl_Rtik_File : O_Cnode; + Ghdl_Rtik_Port : O_Cnode; + Ghdl_Rtik_Generic : O_Cnode; + Ghdl_Rtik_Alias : O_Cnode; + Ghdl_Rtik_Guard : O_Cnode; + Ghdl_Rtik_Component : O_Cnode; + Ghdl_Rtik_Attribute : O_Cnode; + Ghdl_Rtik_Type_B1 : O_Cnode; + Ghdl_Rtik_Type_E8 : O_Cnode; + Ghdl_Rtik_Type_E32 : O_Cnode; + Ghdl_Rtik_Type_I32 : O_Cnode; + Ghdl_Rtik_Type_I64 : O_Cnode; + Ghdl_Rtik_Type_F64 : O_Cnode; + Ghdl_Rtik_Type_P32 : O_Cnode; + Ghdl_Rtik_Type_P64 : O_Cnode; + Ghdl_Rtik_Type_Access : O_Cnode; + Ghdl_Rtik_Type_Array : O_Cnode; + Ghdl_Rtik_Type_Record : O_Cnode; + Ghdl_Rtik_Type_File : O_Cnode; + Ghdl_Rtik_Subtype_Scalar : O_Cnode; + Ghdl_Rtik_Subtype_Array : O_Cnode; + Ghdl_Rtik_Subtype_Unconstrained_Array : O_Cnode; + Ghdl_Rtik_Subtype_Record : O_Cnode; + Ghdl_Rtik_Subtype_Access : O_Cnode; + Ghdl_Rtik_Type_Protected : O_Cnode; + Ghdl_Rtik_Element : O_Cnode; + Ghdl_Rtik_Unit64 : O_Cnode; + Ghdl_Rtik_Unitptr : O_Cnode; + Ghdl_Rtik_Attribute_Transaction : O_Cnode; + Ghdl_Rtik_Attribute_Quiet : O_Cnode; + Ghdl_Rtik_Attribute_Stable : O_Cnode; + Ghdl_Rtik_Psl_Assert : O_Cnode; + Ghdl_Rtik_Error : O_Cnode; + + -- RTI types. + Ghdl_Rti_Depth : O_Tnode; + Ghdl_Rti_U8 : O_Tnode; + + -- Common node. + Ghdl_Rti_Common : O_Tnode; + Ghdl_Rti_Common_Kind : O_Fnode; + Ghdl_Rti_Common_Depth : O_Fnode; + Ghdl_Rti_Common_Mode : O_Fnode; + Ghdl_Rti_Common_Max_Depth : O_Fnode; + + -- Node accesses and arrays. + Ghdl_Rti_Access : O_Tnode; + Ghdl_Rti_Array : O_Tnode; + Ghdl_Rti_Arr_Acc : O_Tnode; + + -- Instance link. + -- This is a structure at the beginning of each entity/architecture + -- instance. This allow the run-time to find the parent of an instance. + Ghdl_Entity_Link_Type : O_Tnode; + -- RTI for this instance. + Ghdl_Entity_Link_Rti : O_Fnode; + -- RTI of the parent, which has instancied the instance. + Ghdl_Entity_Link_Parent : O_Fnode; + + Ghdl_Component_Link_Type : O_Tnode; + -- Pointer to a Ghdl_Entity_Link_Type, which is the entity instantiated. + Ghdl_Component_Link_Instance : O_Fnode; + -- RTI for the component instantiation statement. + Ghdl_Component_Link_Stmt : O_Fnode; + + -- Access to Ghdl_Entity_Link_Type. + Ghdl_Entity_Link_Acc : O_Tnode; + -- Access to a Ghdl_Component_Link_Type. + Ghdl_Component_Link_Acc : O_Tnode; + + -- Generate initial rti declarations. + procedure Rti_Initialize; + + -- Get address (as Ghdl_Rti_Access) of constant RTI. + function New_Rti_Address (Rti : O_Dnode) return O_Cnode; + + -- Generate rtis for a library unit. + procedure Generate_Unit (Lib_Unit : Iir); + + -- Generate a constant declaration for SIG; but do not set its value. + procedure Generate_Signal_Rti (Sig : Iir); + + -- Generate RTIs for subprogram body BOD. + procedure Generate_Subprogram_Body (Bod : Iir); + + -- Generate RTI for LIB. If PUBLIC is FALSE, only generate the + -- declaration as external. + procedure Generate_Library (Lib : Iir_Library_Declaration; + Public : Boolean); + + -- Generate RTI for the top of the hierarchy. Return the maximum number + -- of packages. + procedure Generate_Top (Nbr_Pkgs : out Natural); + + -- Add two associations to ASSOC to add an rti_context for NODE. + procedure Associate_Rti_Context + (Assoc : in out O_Assoc_List; Node : Iir); + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List); + + function Get_Context_Rti (Node : Iir) return O_Cnode; + function Get_Context_Addr (Node : Iir) return O_Enode; + end Rtis; + + type Ortho_Info_Kind is + ( + Kind_Type, + Kind_Incomplete_Type, + Kind_Index, + Kind_Expr, + Kind_Subprg, + Kind_Object, + Kind_Alias, + Kind_Iterator, + Kind_Interface, + Kind_Disconnect, + Kind_Process, + Kind_Psl_Directive, + Kind_Loop, + Kind_Block, + Kind_Component, + Kind_Field, + Kind_Package, + Kind_Package_Instance, + Kind_Config, + Kind_Assoc, + Kind_Str_Choice, + Kind_Design_File, + Kind_Library + ); + + type Ortho_Info_Type_Kind is + ( + Kind_Type_Scalar, + Kind_Type_Array, + Kind_Type_Record, + Kind_Type_File, + Kind_Type_Protected + ); + type O_Tnode_Array is array (Object_Kind_Type) of O_Tnode; + type O_Fnode_Array is array (Object_Kind_Type) of O_Fnode; + + type Rti_Depth_Type is new Natural range 0 .. 255; + + type Ortho_Info_Type_Type (Kind : Ortho_Info_Type_Kind := Kind_Type_Scalar) + is record + -- For all types: + -- This is the maximum depth of RTI, that is the max of the depth of + -- the type itself and every types it depends on. + Rti_Max_Depth : Rti_Depth_Type; + + case Kind is + when Kind_Type_Scalar => + -- For scalar types: + -- True if no need to check against low/high bound. + Nocheck_Low : Boolean := False; + Nocheck_Hi : Boolean := False; + + -- Ortho type for the range record type. + Range_Type : O_Tnode; + + -- Ortho type for an access to the range record type. + Range_Ptr_Type : O_Tnode; + + -- Tree for the range record declaration. + Range_Var : Var_Type; + + -- Fields of TYPE_RANGE_TYPE. + Range_Left : O_Fnode; + Range_Right : O_Fnode; + Range_Dir : O_Fnode; + Range_Length : O_Fnode; + + when Kind_Type_Array => + Base_Type : O_Tnode_Array; + Base_Ptr_Type : O_Tnode_Array; + Bounds_Type : O_Tnode; + Bounds_Ptr_Type : O_Tnode; + + Base_Field : O_Fnode_Array; + Bounds_Field : O_Fnode_Array; + + -- True if the array bounds are static. + Static_Bounds : Boolean; + + -- Variable containing the bounds for a constrained array. + Array_Bounds : Var_Type; + + -- Variable containing a 1 length bound for unidimensional + -- unconstrained arrays. + Array_1bound : Var_Type; + + -- Variable containing the description for each index. + Array_Index_Desc : Var_Type; + + when Kind_Type_Record => + -- Variable containing the description for each element. + Record_El_Desc : Var_Type; + + when Kind_Type_File => + -- Constant containing the signature of the file. + File_Signature : O_Dnode; + + when Kind_Type_Protected => + Prot_Scope : aliased Var_Scope_Type; + + -- Init procedure for the protected type. + Prot_Init_Subprg : O_Dnode; + Prot_Init_Instance : Chap2.Subprg_Instance_Type; + -- Final procedure. + Prot_Final_Subprg : O_Dnode; + Prot_Final_Instance : Chap2.Subprg_Instance_Type; + -- The outer instance, if any. + Prot_Subprg_Instance_Field : O_Fnode; + -- The LOCK field in the object type + Prot_Lock_Field : O_Fnode; + end case; + end record; + +-- Ortho_Info_Type_Scalar_Init : constant Ortho_Info_Type_Type := +-- (Kind => Kind_Type_Scalar, +-- Range_Type => O_Tnode_Null, +-- Range_Ptr_Type => O_Tnode_Null, +-- Range_Var => null, +-- Range_Left => O_Fnode_Null, +-- Range_Right => O_Fnode_Null, +-- Range_Dir => O_Fnode_Null, +-- Range_Length => O_Fnode_Null); + + Ortho_Info_Type_Array_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Array, + Rti_Max_Depth => 0, + Base_Type => (O_Tnode_Null, O_Tnode_Null), + Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null), + Bounds_Type => O_Tnode_Null, + Bounds_Ptr_Type => O_Tnode_Null, + Base_Field => (O_Fnode_Null, O_Fnode_Null), + Bounds_Field => (O_Fnode_Null, O_Fnode_Null), + Static_Bounds => False, + Array_Bounds => Null_Var, + Array_1bound => Null_Var, + Array_Index_Desc => Null_Var); + + Ortho_Info_Type_Record_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Record, + Rti_Max_Depth => 0, + Record_El_Desc => Null_Var); + + Ortho_Info_Type_File_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_File, + Rti_Max_Depth => 0, + File_Signature => O_Dnode_Null); + + Ortho_Info_Type_Prot_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Protected, + Rti_Max_Depth => 0, + Prot_Scope => Null_Var_Scope, + Prot_Init_Subprg => O_Dnode_Null, + Prot_Init_Instance => Chap2.Null_Subprg_Instance, + Prot_Final_Subprg => O_Dnode_Null, + Prot_Subprg_Instance_Field => O_Fnode_Null, + Prot_Final_Instance => Chap2.Null_Subprg_Instance, + Prot_Lock_Field => O_Fnode_Null); + + -- Mode of the type; roughly speaking, this corresponds to its size + -- (for scalars) or its layout (for composite types). + -- Used to select library subprograms for signals. + type Type_Mode_Type is + ( + -- Unknown mode. + Type_Mode_Unknown, + -- Boolean type, with 2 elements. + Type_Mode_B1, + -- Enumeration with at most 256 elements. + Type_Mode_E8, + -- Enumeration with more than 256 elements. + Type_Mode_E32, + -- Integer types. + Type_Mode_I32, + Type_Mode_I64, + -- Physical types. + Type_Mode_P32, + Type_Mode_P64, + -- Floating point type. + Type_Mode_F64, + -- File type. + Type_Mode_File, + -- Thin access. + Type_Mode_Acc, + + -- Fat access. + Type_Mode_Fat_Acc, + + -- Record. + Type_Mode_Record, + -- Protected type + Type_Mode_Protected, + -- Constrained array type (length is known at compile-time). + Type_Mode_Array, + -- Fat array type (used for unconstrained array). + Type_Mode_Fat_Array); + + subtype Type_Mode_Scalar is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_F64; + + subtype Type_Mode_Non_Composite is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Fat_Acc; + + -- Composite types, with the vhdl meaning: record and arrays. + subtype Type_Mode_Composite is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Array types. + subtype Type_Mode_Arrays is Type_Mode_Type range + Type_Mode_Array .. Type_Mode_Fat_Array; + + -- Thin types, ie types whose length is a scalar. + subtype Type_Mode_Thin is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Acc; + + -- Fat types, ie types whose length is longer than a scalar. + subtype Type_Mode_Fat is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Array; + + -- These parameters are passed by value, ie the argument of the subprogram + -- is the value of the object. + subtype Type_Mode_By_Value is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Acc; + + -- These parameters are passed by copy, ie a copy of the object is created + -- and the reference of the copy is passed. If the object is not + -- modified by the subprogram, the object could be passed by reference. + subtype Type_Mode_By_Copy is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Acc; + + -- The parameters are passed by reference, ie the argument of the + -- subprogram is an address to the object. + subtype Type_Mode_By_Ref is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Additional informations for a resolving function. + type Subprg_Resolv_Info is record + Resolv_Func : O_Dnode; + -- Parameter nodes. + Var_Instance : Chap2.Subprg_Instance_Type; + + -- Signals + Var_Vals : O_Dnode; + -- Driving vector. + Var_Vec : O_Dnode; + -- Length of Vector. + Var_Vlen : O_Dnode; + Var_Nbr_Drv : O_Dnode; + Var_Nbr_Ports : O_Dnode; + end record; + type Subprg_Resolv_Info_Acc is access Subprg_Resolv_Info; + + -- Complex types. + -- + -- A complex type is not a VHDL notion, but a translation notion. + -- A complex type is a composite type whose size is not known at compile + -- type. This happends in VHDL because a bound can be globally static. + -- Therefore, the length of an array may not be known at compile type, + -- and this propagates to composite types (record and array) if they + -- have such an element. This is different from unconstrained arrays. + -- + -- This occurs frequently in VHDL, and could even happen within + -- subprograms. + -- + -- Such types are always dynamically allocated (on the stack or on the + -- heap). They must be continuous in memory so that they could be copied + -- via memcpy/memmove. + -- + -- At runtime, the size of such type is computed. A builder procedure + -- is also created to setup inner pointers. This builder procedure should + -- be called at initialization, but also after a copy. + -- + -- Example: + -- 1) subtype bv_type is bit_vector (l to h); + -- variable a : bv_type + -- + -- This is represented by a pointer to an array of bit. No need for + -- builder procedure, as the element type is not complex. But there + -- is a size variable for the size of bv_type + -- + -- 2) type rec1_type is record + -- f1 : integer; + -- f2 : bv_type; + -- end record; + -- + -- This is represented by a pointer to a record. The 'f2' field is + -- an offset to an array of bit. The size of the object is the size + -- of the record (with f2 as a pointer) + the size of bv_type. + -- The alinment of the object is the maximum alignment of its sub- + -- objects: rec1 and bv_type. + -- A builder procedure is needed to initialize the 'f2' field. + -- The memory layout is: + -- +--------------+ + -- | rec1: f1 | + -- | f2 |---+ + -- +--------------+ | + -- | bv_type |<--+ + -- | ... | + -- +--------------+ + -- + -- 3) type rec2_type is record + -- g1: rec1_type; + -- g2: bv_type; + -- g3: bv_type; + -- end record; + -- + -- This is represented by a pointer to a record. All the three fields + -- are offset (relative to rec2). Alignment is the maximum alignment of + -- the sub-objects (rec2, rec1, bv_type x 3). + -- The memory layout is: + -- +--------------+ + -- | rec2: g1 |---+ + -- | g2 |---|---+ + -- | g3 |---|---|---+ + -- +--------------+ | | | + -- | rec1: f1 |<--+ | | + -- | f2 |---+ | | + -- +--------------+ | | | + -- | bv_type (f2) |<--+ | | + -- | ... | | | + -- +--------------+ | | + -- | bv_type (g2) |<------+ | + -- | ... | | + -- +--------------+ | + -- | bv_type (g3) |<----------+ + -- | ... | + -- +--------------+ + -- + -- 4) type bv_arr_type is array (natural range <>) of bv_type; + -- arr2 : bv_arr_type (1 to 4) + -- + -- This should be represented by a pointer to bv_type. + -- The memory layout is: + -- +--------------+ + -- | bv_type (1) | + -- | ... | + -- +--------------+ + -- | bv_type (2) | + -- | ... | + -- +--------------+ + -- | bv_type (3) | + -- | ... | + -- +--------------+ + -- | bv_type (4) | + -- | ... | + -- +--------------+ + + -- Additional info for complex types. + type Complex_Type_Info is record + -- Variable containing the size of the type. + -- This is defined only for types whose size is only known at + -- running time (and not a compile-time). + Size_Var : Var_Type; + + -- Variable containing the alignment of the type. + -- Only defined for recods and for Mode_Value. + -- Note: this is not optimal, because the alignment could be computed + -- at compile time, but there is no way to do that with ortho (no + -- operation on constants). Furthermore, the alignment is independent + -- of the instance, so there could be one global variable. But this + -- doesn't fit in the whole machinery (in particular, there is no + -- easy way to compute it once). As the overhead is very low, no need + -- to bother with this issue. + Align_Var : Var_Type; + + Builder_Need_Func : Boolean; + + -- Parameters for type builders. + -- NOTE: this is only set for types (and *not* for subtypes). + Builder_Instance : Chap2.Subprg_Instance_Type; + Builder_Base_Param : O_Dnode; + Builder_Bound_Param : O_Dnode; + Builder_Func : O_Dnode; + end record; + type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info; + type Complex_Type_Info_Acc is access Complex_Type_Arr_Info; + procedure Free_Complex_Type_Info is new Ada.Unchecked_Deallocation + (Complex_Type_Arr_Info, Complex_Type_Info_Acc); + + type Assoc_Conv_Info is record + -- The subprogram created to do the conversion. + Subprg : O_Dnode; + -- The local base block + Instance_Block : Iir; + -- and its address. + Instance_Field : O_Fnode; + -- The instantiated entity (if any). + Instantiated_Entity : Iir; + -- and its address. + Instantiated_Field : O_Fnode; + In_Field : O_Fnode; + Out_Field : O_Fnode; + Record_Type : O_Tnode; + Record_Ptr_Type : O_Tnode; + end record; + + type Direct_Driver_Type is record + Sig : Iir; + Var : Var_Type; + end record; + type Direct_Driver_Arr is array (Natural range <>) of Direct_Driver_Type; + type Direct_Drivers_Acc is access Direct_Driver_Arr; + + type Ortho_Info_Type; + type Ortho_Info_Acc is access Ortho_Info_Type; + + type Ortho_Info_Type (Kind : Ortho_Info_Kind) is record + case Kind is + when Kind_Type => + -- Mode of the type. + Type_Mode : Type_Mode_Type := Type_Mode_Unknown; + + -- If true, the type is (still) incomplete. + Type_Incomplete : Boolean := False; + + -- For array only. True if the type is constrained with locally + -- static bounds. May have non locally-static bounds in some + -- of its sub-element (ie being a complex type). + Type_Locally_Constrained : Boolean := False; + + -- Additionnal info for complex types. + C : Complex_Type_Info_Acc := null; + + -- Ortho node which represents the type. + -- Type -> Ortho type + -- scalar -> scalar + -- record (complex or not) -> record + -- constrained non-complex array -> constrained array + -- constrained complex array -> the element + -- unconstrained array -> fat pointer + -- access to unconstrained array -> fat pointer + -- access (others) -> access + -- file -> file_index_type + -- protected -> instance + Ortho_Type : O_Tnode_Array; + + -- Ortho pointer to the type. This is always an access to the + -- ortho_type. + Ortho_Ptr_Type : O_Tnode_Array; + + -- Chain of temporary types to be destroyed at end of scope. + Type_Transient_Chain : Iir := Null_Iir; + + -- More info according to the type. + T : Ortho_Info_Type_Type; + + -- Run-time information. + Type_Rti : O_Dnode := O_Dnode_Null; + + when Kind_Incomplete_Type => + -- The declaration of the incomplete type. + Incomplete_Type : Iir; + Incomplete_Array : Ortho_Info_Acc; + + when Kind_Index => + -- Field declaration for array dimension. + Index_Field : O_Fnode; + + when Kind_Expr => + -- Ortho tree which represents the expression, used for + -- enumeration literals. + Expr_Node : O_Cnode; + + when Kind_Subprg => + -- True if the function can return a value stored in the secondary + -- stack. In this case, the caller must deallocate the area + -- allocated by the callee when the value was used. + Use_Stack2 : Boolean := False; + + -- Subprogram declaration node. + Ortho_Func : O_Dnode; + + -- For a function: + -- If the return value is not composite, then this field + -- must be O_DNODE_NULL. + -- If the return value is a composite type, then the caller must + -- give to the callee an area to put the result. This area is + -- given via an (hidden to the user) interface. Furthermore, + -- the function is translated into a procedure. + -- For a procedure: + -- If there are copy-out interfaces, they are gathered in a + -- record and a pointer to the record is passed to the + -- procedure. RES_INTERFACE is the interface for this pointer. + Res_Interface : O_Dnode := O_Dnode_Null; + + -- Field in the frame for a pointer to the RESULT structure. + Res_Record_Var : Var_Type := Null_Var; + + -- For a subprogram with a result interface: + -- Type definition for the record. + Res_Record_Type : O_Tnode := O_Tnode_Null; + -- Type definition for access to the record. + Res_Record_Ptr : O_Tnode := O_Tnode_Null; + + -- Access to the declarations within this subprogram. + Subprg_Frame_Scope : aliased Var_Scope_Type; + + -- Instances for the subprograms. + Subprg_Instance : Chap2.Subprg_Instance_Type := + Chap2.Null_Subprg_Instance; + + Subprg_Resolv : Subprg_Resolv_Info_Acc := null; + + -- Local identifier number, set by spec, continued by body. + Subprg_Local_Id : Local_Identifier_Type; + + -- If set, return should be converted into exit out of the + -- SUBPRG_EXIT loop and the value should be assigned to + -- SUBPRG_RESULT, if any. + Subprg_Exit : O_Snode := O_Snode_Null; + Subprg_Result : O_Dnode := O_Dnode_Null; + + when Kind_Object => + -- For constants: set when the object is defined as a constant. + Object_Static : Boolean; + -- The object itself. + Object_Var : Var_Type; + -- Direct driver for signal (if any). + Object_Driver : Var_Type := Null_Var; + -- RTI constant for the object. + Object_Rti : O_Dnode := O_Dnode_Null; + -- Function to compute the value of object (used for implicit + -- guard signal declaration). + Object_Function : O_Dnode := O_Dnode_Null; + + when Kind_Alias => + Alias_Var : Var_Type; + Alias_Kind : Object_Kind_Type; + + when Kind_Iterator => + Iterator_Var : Var_Type; + + when Kind_Interface => + -- Ortho declaration for the interface. If not null, there is + -- a corresponding ortho parameter for the interface. While + -- translating nested subprograms (that are unnested), + -- Interface_Field may be set to the corresponding field in the + -- FRAME record. So: + -- Node: not null, Field: null: parameter + -- Node: not null, Field: not null: parameter with a copy in + -- the FRAME record. + -- Node: null, Field: null: not possible + -- Node: null, Field: not null: field in RESULT record + Interface_Node : O_Dnode := O_Dnode_Null; + -- Field of the result record for copy-out arguments of procedure. + -- In that case, Interface_Node must be null. + Interface_Field : O_Fnode; + -- Type of the interface. + Interface_Type : O_Tnode; + + when Kind_Disconnect => + -- Variable which contains the time_expression of the + -- disconnection specification + Disconnect_Var : Var_Type; + + when Kind_Process => + Process_Scope : aliased Var_Scope_Type; + + -- Subprogram for the process. + Process_Subprg : O_Dnode; + + -- List of drivers if Flag_Direct_Drivers. + Process_Drivers : Direct_Drivers_Acc := null; + + -- RTI for the process. + Process_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Psl_Directive => + Psl_Scope : aliased Var_Scope_Type; + + -- Procedure for the state machine. + Psl_Proc_Subprg : O_Dnode; + -- Procedure for finalization. Handles EOS. + Psl_Proc_Final_Subprg : O_Dnode; + + -- Length of the state vector. + Psl_Vect_Len : Natural; + + -- Type of the state vector. + Psl_Vect_Type : O_Tnode; + + -- State vector variable. + Psl_Vect_Var : Var_Type; + + -- Boolean variable (for cover) + Psl_Bool_Var : Var_Type; + + -- RTI for the process. + Psl_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Loop => + -- Labels for the loop. + -- Used for exit/next from while-loop, and to exit from for-loop. + Label_Exit : O_Snode; + -- Used to next from for-loop, with an exit statment. + Label_Next : O_Snode; + + when Kind_Block => + -- Access to declarations of this block. + Block_Scope : aliased Var_Scope_Type; + + -- Instance type (ortho record) for declarations contained in the + -- block/entity/architecture. + Block_Decls_Ptr_Type : O_Tnode; + + -- For Entity: field in the instance type containing link to + -- parent. + -- For an instantiation: link in the parent block to the instance. + Block_Link_Field : O_Fnode; + + -- For an entity: must be o_fnode_null. + -- For an architecture: the entity field. + -- For a block, a component or a generate block: field in the + -- parent instance which contains the declarations for this + -- block. + Block_Parent_Field : O_Fnode; + + -- For a generate block: field in the block providing a chain to + -- the previous block (note: this may not be the parent, but + -- is a parent). + Block_Origin_Field : O_Fnode; + -- For an iterative block: boolean field set when the block + -- is configured. This is used to check if the block was already + -- configured since index and slice are not compelled to be + -- locally static. + Block_Configured_Field : O_Fnode; + + -- For iterative generate block: array of instances. + Block_Decls_Array_Type : O_Tnode; + Block_Decls_Array_Ptr_Type : O_Tnode; + + -- Subprogram which elaborates the block (for entity or arch). + Block_Elab_Subprg : O_Dnode; + -- Size of the block instance. + Block_Instance_Size : O_Dnode; + + -- Only for an entity: procedure that elaborate the packages this + -- units depend on. That must be done before elaborating the + -- entity and before evaluating default expressions in generics. + Block_Elab_Pkg_Subprg : O_Dnode; + + -- RTI constant for the block. + Block_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Component => + -- How to access to component interfaces. + Comp_Scope : aliased Var_Scope_Type; + + -- Instance for the component. + Comp_Ptr_Type : O_Tnode; + -- Field containing a pointer to the instance link. + Comp_Link : O_Fnode; + -- RTI for the component. + Comp_Rti_Const : O_Dnode; + + when Kind_Config => + -- Subprogram that configure the block. + Config_Subprg : O_Dnode; + + when Kind_Field => + -- Node for a record element declaration. + Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null); + + when Kind_Package => + -- Subprogram which elaborate the package spec/body. + -- External units should call the body elaborator. + -- The spec elaborator is called only from the body elaborator. + Package_Elab_Spec_Subprg : O_Dnode; + Package_Elab_Body_Subprg : O_Dnode; + + -- Instance for the elaborators. + Package_Elab_Spec_Instance : Chap2.Subprg_Instance_Type; + Package_Elab_Body_Instance : Chap2.Subprg_Instance_Type; + + -- Variable set to true when the package is elaborated. + Package_Elab_Var : Var_Type; + + -- RTI constant for the package. + Package_Rti_Const : O_Dnode; + + -- Access to declarations of the spec. + Package_Spec_Scope : aliased Var_Scope_Type; + + -- Instance type for uninstantiated package + Package_Spec_Ptr_Type : O_Tnode; + + Package_Body_Scope : aliased Var_Scope_Type; + Package_Body_Ptr_Type : O_Tnode; + + -- Field to the spec within the body. + Package_Spec_Field : O_Fnode; + + -- Local id, set by package declaration, continued by package + -- body. + Package_Local_Id : Local_Identifier_Type; + + when Kind_Package_Instance => + -- The variables containing the instance. There are two variables + -- for interface package: one for the spec, one for the body. + -- For package instantiation, only the variable for the body is + -- used. The variable for spec is added so that packages with + -- package interfaces don't need to know the body of their + -- interfaces. + Package_Instance_Spec_Var : Var_Type; + Package_Instance_Body_Var : Var_Type; + + -- Elaboration procedure for the instance. + Package_Instance_Elab_Subprg : O_Dnode; + + Package_Instance_Spec_Scope : aliased Var_Scope_Type; + Package_Instance_Body_Scope : aliased Var_Scope_Type; + + when Kind_Assoc => + -- Association informations. + Assoc_In : Assoc_Conv_Info; + Assoc_Out : Assoc_Conv_Info; + + when Kind_Str_Choice => + -- List of choices, used to sort them. + Choice_Chain : Ortho_Info_Acc; + -- Association index. + Choice_Assoc : Natural; + -- Corresponding choice simple expression. + Choice_Expr : Iir; + -- Corresponding choice. + Choice_Parent : Iir; + + when Kind_Design_File => + Design_Filename : O_Dnode; + + when Kind_Library => + Library_Rti_Const : O_Dnode; + end case; + end record; + + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => Ortho_Info_Acc, Object => Ortho_Info_Type); + + subtype Type_Info_Acc is Ortho_Info_Acc (Kind_Type); + subtype Incomplete_Type_Info_Acc is Ortho_Info_Acc (Kind_Incomplete_Type); + subtype Index_Info_Acc is Ortho_Info_Acc (Kind_Index); + subtype Subprg_Info_Acc is Ortho_Info_Acc (Kind_Subprg); + subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object); + subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias); + subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process); + subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Directive); + subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop); + subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block); + subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component); + subtype Field_Info_Acc is Ortho_Info_Acc (Kind_Field); + subtype Config_Info_Acc is Ortho_Info_Acc (Kind_Config); + subtype Assoc_Info_Acc is Ortho_Info_Acc (Kind_Assoc); + subtype Inter_Info_Acc is Ortho_Info_Acc (Kind_Interface); + subtype Design_File_Info_Acc is Ortho_Info_Acc (Kind_Design_File); + subtype Library_Info_Acc is Ortho_Info_Acc (Kind_Library); + + package Node_Infos is new GNAT.Table + (Table_Component_Type => Ortho_Info_Acc, + Table_Index_Type => Iir, + Table_Low_Bound => 0, + Table_Initial => 1024, + Table_Increment => 100); + + procedure Update_Node_Infos + is + use Nodes; + F, L : Iir; + begin + F := Node_Infos.Last; + L := Nodes.Get_Last_Node; + Node_Infos.Set_Last (L); + Node_Infos.Table (F + 1 .. L) := (others => null); + end Update_Node_Infos; + + procedure Set_Info (Target : Iir; Info : Ortho_Info_Acc) is + begin + if Node_Infos.Table (Target) /= null then + raise Internal_Error; + end if; + Node_Infos.Table (Target) := Info; + end Set_Info; + + procedure Clear_Info (Target : Iir) is + begin + Node_Infos.Table (Target) := null; + end Clear_Info; + + function Get_Info (Target : Iir) return Ortho_Info_Acc is + begin + return Node_Infos.Table (Target); + end Get_Info; + + -- Create an ortho_info field of kind KIND for iir node TARGET, and + -- return it. + function Add_Info (Target : Iir; Kind : Ortho_Info_Kind) + return Ortho_Info_Acc + is + Res : Ortho_Info_Acc; + begin + Res := new Ortho_Info_Type (Kind); + Set_Info (Target, Res); + return Res; + end Add_Info; + + procedure Free_Info (Target : Iir) + is + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Target); + if Info /= null then + Unchecked_Deallocation (Info); + Clear_Info (Target); + end if; + end Free_Info; + + procedure Free_Type_Info (Info : in out Type_Info_Acc) is + begin + if Info.C /= null then + Free_Complex_Type_Info (Info.C); + end if; + Unchecked_Deallocation (Info); + end Free_Type_Info; + + procedure Set_Ortho_Expr (Target : Iir; Expr : O_Cnode) + is + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Target, Kind_Expr); + Info.Expr_Node := Expr; + end Set_Ortho_Expr; + + function Get_Ortho_Expr (Target : Iir) return O_Cnode is + begin + return Get_Info (Target).Expr_Node; + end Get_Ortho_Expr; + + function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type) + return O_Tnode is + begin + return Get_Info (Target).Ortho_Type (Is_Sig); + end Get_Ortho_Type; + + function Get_Ortho_Decl (Subprg : Iir) return O_Dnode + is + begin + return Get_Info (Subprg).Ortho_Func; + end Get_Ortho_Decl; + + function Get_Resolv_Ortho_Decl (Func : Iir) return O_Dnode + is + Info : Subprg_Resolv_Info_Acc; + begin + Info := Get_Info (Func).Subprg_Resolv; + if Info = null then + -- Maybe the resolver is not used. + return O_Dnode_Null; + else + return Info.Resolv_Func; + end if; + end Get_Resolv_Ortho_Decl; + + -- Return true is INFO is a type info for a composite type, ie: + -- * a record + -- * an array (fat or thin) + -- * a fat pointer. + function Is_Composite (Info : Type_Info_Acc) return Boolean; + pragma Inline (Is_Composite); + + function Is_Composite (Info : Type_Info_Acc) return Boolean is + begin + return Info.Type_Mode in Type_Mode_Fat; + end Is_Composite; + + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean; + pragma Inline (Is_Complex_Type); + + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is + begin + return Tinfo.C /= null; + end Is_Complex_Type; + + -- In order to simplify the handling of Enode/Lnode, let's introduce + -- Mnode (yes, another node). + -- An Mnode is a typed union, containing either an Lnode or a Enode. + -- See Mstate for a description of the union. + -- The real data is contained insisde a record, so that the discriminant + -- can be changed. + type Mnode; + + -- State of an Mmode. + type Mstate is + ( + -- The Mnode contains an Enode, which can be either a value or a + -- pointer. + -- This Mnode can be used only once. + Mstate_E, + + -- The Mnode contains an Lnode representing a value. + -- This Lnode can be used only once. + Mstate_Lv, + + -- The Mnode contains an Lnode representing a pointer. + -- This Lnode can be used only once. + Mstate_Lp, + + -- The Mnode contains an Dnode for a variable representing a value. + -- This Dnode may be used several times. + Mstate_Dv, + + -- The Mnode contains an Dnode for a variable representing a pointer. + -- This Dnode may be used several times. + Mstate_Dp, + + -- Null Mnode. + Mstate_Null, + + -- The Mnode is invalid (such as already used). + Mstate_Bad); + + type Mnode1 (State : Mstate := Mstate_Bad) is record + -- True if the object is composite (its value cannot be read directly). + Comp : Boolean; + + -- Additionnal informations about the objects: kind and type. + K : Object_Kind_Type; + T : Type_Info_Acc; + + -- Ortho type of the object. + Vtype : O_Tnode; + + -- Type for a pointer to the object. + Ptype : O_Tnode; + + case State is + when Mstate_E => + E : O_Enode; + when Mstate_Lv => + Lv : O_Lnode; + when Mstate_Lp => + Lp : O_Lnode; + when Mstate_Dv => + Dv : O_Dnode; + when Mstate_Dp => + Dp : O_Dnode; + when Mstate_Bad + | Mstate_Null => + null; + end case; + end record; + --pragma Pack (Mnode1); + + type Mnode is record + M1 : Mnode1; + end record; + + -- Null Mnode. + Mnode_Null : constant Mnode := Mnode'(M1 => (State => Mstate_Null, + Comp => False, + K => Mode_Value, + Ptype => O_Tnode_Null, + Vtype => O_Tnode_Null, + T => null)); + + + -- Object kind of a Mnode + function Get_Object_Kind (M : Mnode) return Object_Kind_Type; + + -- Transform VAR to Mnode. + function Get_Var + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode; + + -- Return a stabilized node for M. + -- The former M is not usuable anymore. + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode; + + -- Stabilize M. + procedure Stabilize (M : in out Mnode); + + -- If M is not stable, create a variable containing the value of M. + -- M must be scalar (or access). + function Stabilize_Value (M : Mnode) return Mnode; + + -- Create a temporary of type INFO and kind KIND. + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode; + + package Chap3 is + -- Translate the subtype of an object, since an object can define + -- a subtype. + -- This can be done only for a declaration. + -- DECL must have an identifier and a type. + procedure Translate_Object_Subtype + (Decl : Iir; With_Vars : Boolean := True); + procedure Elab_Object_Subtype (Def : Iir); + + -- Translate the subtype of a literal. + -- This can be done not at declaration time, ie no variables are created + -- for this subtype. + --procedure Translate_Literal_Subtype (Def : Iir); + + -- Translation of a type definition or subtype indication. + -- 1. Create corresponding Ortho type. + -- 2. Create bounds type + -- 3. Create bounds declaration + -- 4. Create bounds constructor + -- 5. Create type descriptor declaration + -- 6. Create type descriptor constructor + procedure Translate_Type_Definition + (Def : Iir; With_Vars : Boolean := True); + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id); + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean); + + -- Some expressions may be evaluated several times in different + -- contexts. Type info created for these expressions may not be + -- shared between these contexts. + procedure Destroy_Type_Info (Atype : Iir); + + -- Translate subprograms for types. + procedure Translate_Type_Subprograms (Decl : Iir); + + procedure Create_Type_Definition_Type_Range (Def : Iir); + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode; + + -- Same as Translate_type_definition only for std.standard.boolean and + -- std.standard.bit. + procedure Translate_Bool_Type_Definition (Def : Iir); + + -- Call lock or unlock on a protected object. + procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode); + + procedure Translate_Protected_Type_Body (Bod : Iir); + procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir); + + -- Translate_type_definition_Elab do 4 and 6. + -- It generates code to do type elaboration. + procedure Elab_Type_Declaration (Decl : Iir); + procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration); + + -- Builders. + -- A complex type is a type whose size is not locally static. + -- + -- The most simple example is an unidimensionnl array whose range + -- depends on generics. + -- + -- We call first order complex type any array whose bounds are not + -- locally static and whose sub-element size is locally static. + -- + -- First order complex type objects are represented by a pointer to an + -- array of sub-element, and the storage area for the array is + -- allocated at run-time. + -- + -- Since a sub-element type may be a complex type, a type may be + -- complex because one of its sub-element type is complex. + -- EG, a record type whose one element is a complex array. + -- + -- A type may be complex either because it is a first order complex + -- type (ie an array whose bounds are not locally static) or because + -- one of its sub-element type is such a type (this is recursive). + -- + -- We call second order complex type a complex type that is not of first + -- order. + -- We call third order complex type a second order complex type which is + -- an array whose bounds are not locally static. + -- + -- In a complex type, sub-element of first order complex type are + -- represented by a pointer. + -- Any complex type object (constant, signal, variable, port, generic) + -- is represented by a pointer. + -- + -- Creation of a second or third order complex type object consists in + -- allocating the memory and building the object. + -- Building a object consists in setting internal pointers. + -- + -- A complex type has always a non-null INFO.C, and its size is computed + -- during elaboration. + -- + -- For a second or third order complex type, INFO.C.BUILDER_NEED_FUNC + -- is set to TRUE. + + -- Call builder for variable pointed VAR of type VAR_TYPE. + procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir); + + -- Functions for fat array. + -- Fat array are array whose size is not known at compilation time. + -- This corresponds to an unconstrained array or a non locally static + -- constrained array. + -- A fat array is a structure containing 2 fields: + -- * base: a pointer to the data of the array. + -- * bounds: a pointer to a structure containing as many fields as + -- number of dimensions; these fields are a structure describing the + -- range of the dimension. + + -- Index array BASE of type ATYPE with INDEX. + -- INDEX must be of type ghdl_index_type, thus no bounds checks are + -- performed. + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode; + + -- Same for for slicing. + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode; + + -- Get the length of the array (the number of elements). + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode; + + -- Get the number of elements for bounds BOUNDS. BOUNDS are + -- automatically stabilized if necessary. + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode; + + -- Get the number of elements in array ATYPE. + function Get_Array_Type_Length (Atype : Iir) return O_Enode; + + -- Get the base of array ARR. + function Get_Array_Base (Arr : Mnode) return Mnode; + + -- Get the bounds of array ARR. + function Get_Array_Bounds (Arr : Mnode) return Mnode; + + -- Get the range ot ATYPE. + function Type_To_Range (Atype : Iir) return Mnode; + + -- Get length of range R. + function Range_To_Length (R : Mnode) return Mnode; + + -- Get direction of range R. + function Range_To_Dir (R : Mnode) return Mnode; + + -- Get left/right bounds for range R. + function Range_To_Left (R : Mnode) return Mnode; + function Range_To_Right (R : Mnode) return Mnode; + + -- Get range for dimension DIM (1 based) of array bounds B or type + -- ATYPE. + function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) + return Mnode; + + -- Get the range of dimension DIM (1 based) of array ARR of type ATYPE. + function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) + return Mnode; + + -- Get array bounds for type ATYPE. + function Get_Array_Type_Bounds (Atype : Iir) return Mnode; + + -- Deallocate OBJ. + procedure Gen_Deallocate (Obj : O_Enode); + + -- Performs deallocation of PARAM (the parameter of a deallocate call). + procedure Translate_Object_Deallocation (Param : Iir); + + -- Allocate an object of type OBJ_TYPE and set RES. + -- RES must be a stable access of type ortho_ptr_type. + -- For an unconstrained array, BOUNDS is a pointer to the boundaries of + -- the object, which are copied. + procedure Translate_Object_Allocation + (Res : in out Mnode; + Alloc_Kind : Allocation_Kind; + Obj_Type : Iir; + Bounds : Mnode); + + -- Copy SRC to DEST. + -- Both have the same type, OTYPE. + -- Furthermore, arrays are of the same length. + procedure Translate_Object_Copy + (Dest : Mnode; Src : O_Enode; Obj_Type : Iir); + + -- Get size (in bytes with type ghdl_index_type) of object OBJ. + -- For an unconstrained array, OBJ must be really an object, otherwise, + -- it may be a null_mnode, created by T2M. + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode; + + -- Allocate the base of a fat array, whose length is determined from + -- the bounds. + -- RES_PTR is a pointer to the fat pointer (must be a variable that + -- can be referenced several times). + -- ARR_TYPE is the type of the array. + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; + Res : Mnode; + Arr_Type : Iir); + + -- Create the bounds for SUB_TYPE. + -- SUB_TYPE is expected to be a non-static, anonymous array type. + procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean); + + -- Return TRUE if VALUE is not is the range specified by ATYPE. + -- VALUE must be stable. + function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode; + + -- Return TRUE if base type of ATYPE is larger than its bounds, ie + -- if a value of type ATYPE may be out of range. + function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean; + + -- Generate an error if VALUE (computed from EXPR which may be NULL_IIR + -- if not from a tree) is not in range specified by ATYPE. + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir); + + -- Insert a scalar check for VALUE of type ATYPE. EXPR may be NULL_IIR. + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode; + + -- The base type of EXPR and the base type of ATYPE must be the same. + -- If the type is a scalar type, and if a range check is needed, this + -- function inserts the check. Otherwise, it returns VALUE. + function Maybe_Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir) + return O_Enode; + + -- Return True iff all indexes of L_TYPE and R_TYPE have the same + -- length. They must be locally static. + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean; + + -- Check bounds length of L match bounds length of R. + -- If L_TYPE (resp. R_TYPE) is not a thin array, then L_NODE + -- (resp. R_NODE) are not used (and may be Mnode_Null). + -- If L_TYPE (resp. T_TYPE) is a fat array, then L_NODE (resp. R_NODE) + -- must designate the array. + procedure Check_Array_Match (L_Type : Iir; + L_Node : Mnode; + R_Type : Iir; + R_Node : Mnode; + Loc : Iir); + + -- Create a subtype range to be stored into the location pointed by + -- RANGE_PTR from length LENGTH, which is of type INDEX_TYPE. + -- This is done according to rules 7.2.4 of LRM93, ie: + -- direction and left bound of the range is the same of INDEX_TYPE. + -- LENGTH and RANGE_PTR are variables. LOC is the location in case of + -- error. + procedure Create_Range_From_Length + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir); + + end Chap3; + + package Chap4 is + -- Translate of a type declaration corresponds to the translation of + -- its definition. + procedure Translate_Type_Declaration (Decl : Iir); + procedure Translate_Anonymous_Type_Declaration (Decl : Iir); + procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration); + procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration); + + -- Translate declaration DECL, which must not be a subprogram + -- specification. + procedure Translate_Declaration (Decl : Iir); + + -- Translate declarations, except subprograms spec and bodies. + procedure Translate_Declaration_Chain (Parent : Iir); + + -- Translate subprograms in declaration chain of PARENT. + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir); + + -- Create subprograms for type/function conversion of signal + -- associations. + -- ENTITY is the entity instantiated, which can be either + -- an entity_declaration (for component configuration or direct + -- component instantiation), a component declaration (for a component + -- instantiation) or Null_Iir (for a block header). + -- BLOCK is the block/architecture containing the instantiation stmt. + -- STMT is either the instantiation stmt or the block header. + procedure Translate_Association_Subprograms + (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir); + + -- Elaborate In/Out_Conversion for ASSOC (signals only). + -- NDEST is the data structure to be registered. + procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode); + procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode); + + -- Create code to elaborate declarations. + -- NEED_FINAL is set when at least one declaration needs to be + -- finalized (eg: file declaration, protected objects). + procedure Elab_Declaration_Chain + (Parent : Iir; Need_Final : out Boolean); + + -- Finalize declarations. + procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean); + + -- Translate port or generic declarations of PARENT. + procedure Translate_Port_Chain (Parent : Iir); + procedure Translate_Generic_Chain (Parent : Iir); + + -- Elaborate signal subtypes and allocate the storage for the object. + procedure Elab_Signal_Declaration_Storage (Decl : Iir); + + -- Create signal object. + -- Note: SIG can be a signal sub-element (used when signals are + -- collapsed). + -- If CHECK_NULL is TRUE, create the signal only if it was not yet + -- created. + -- PARENT is used to link the signal to its parent by rti. + procedure Elab_Signal_Declaration_Object + (Sig : Iir; Parent : Iir; Check_Null : Boolean); + + -- True of SIG has a direct driver. + function Has_Direct_Driver (Sig : Iir) return Boolean; + + -- Allocate memory for direct driver if necessary. + procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir); + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Value (Obj : Iir; Value : Iir); + + -- Allocate the storage for OBJ, if necessary. + procedure Elab_Object_Storage (Obj : Iir); + + -- Initialize NAME/OBJ with VALUE. + procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir); + + -- Get the ortho type for an object of type TINFO. + function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) + return O_Tnode; + + -- Allocate (and build) a complex object of type OBJ_TYPE. + -- VAR is the object to be allocated. + procedure Allocate_Complex_Object (Obj_Type : Iir; + Alloc_Kind : Allocation_Kind; + Var : in out Mnode); + + --function Translate_Interface_Declaration + -- (Decl : Iir; Subprg : Iir) return Tree; + + -- Create a record that describe thes location of an IIR node and + -- returns the address of it. + function Get_Location (N : Iir) return O_Dnode; + + -- Set default value to OBJ. + procedure Init_Object (Obj : Mnode; Obj_Type : Iir); + end Chap4; + + package Chap6 is + -- Translate NAME. + -- RES contains a lnode for the result. This is the object. + -- RES can be a tree, so it may be referenced only once. + -- SIG is true if RES is a signal object. + function Translate_Name (Name : Iir) return Mnode; + + -- Translate signal NAME into its node (SIG) and its direct driver + -- node (DRV). + procedure Translate_Direct_Driver + (Name : Iir; Sig : out Mnode; Drv : out Mnode); + + -- Same as Translate_Name, but only for formal names. + -- If SCOPE_TYPE and SCOPE_PARAM are not null, use them for the scope + -- of the base name. + -- Indeed, for recursive instantiation, NAME can designates the actual + -- and the formal. +-- function Translate_Formal_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir) +-- return Mnode; + + -- Get record element EL of PREFIX. + function Translate_Selected_Element (Prefix : Mnode; + El : Iir_Element_Declaration) + return Mnode; + + function Get_Array_Bound_Length (Arr : Mnode; + Arr_Type : Iir; + Dim : Natural) + return O_Enode; + + procedure Gen_Bound_Error (Loc : Iir); + + -- Generate code to emit a program error. + Prg_Err_Missing_Return : constant Natural := 1; + Prg_Err_Block_Configured : constant Natural := 2; + Prg_Err_Dummy_Config : constant Natural := 3; + Prg_Err_No_Choice : constant Natural := 4; + Prg_Err_Bad_Choice : constant Natural := 5; + procedure Gen_Program_Error (Loc : Iir; Code : Natural); + + -- Generate code to emit a failure if COND is TRUE, indicating an + -- index violation for dimension DIM of an array. LOC is usually + -- the expression which has computed the index and is used only for + -- its location. + procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural); + + -- Get the deepest range_expression of ATYPE. + -- This follows 'range and 'reverse_range. + -- Set IS_REVERSE to true if the range must be reversed. + procedure Get_Deep_Range_Expression + (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean); + + -- Get the offset of INDEX in the range RNG. + -- This checks INDEX belongs to the range. + -- RANGE_TYPE is the subtype of the array index (or the subtype of RNG). + -- For unconstrained ranges, INDEX_EXPR must be NULL_IIR and RANGE_TYPE + -- must be set. + function Translate_Index_To_Offset (Rng : Mnode; + Index : O_Enode; + Index_Expr : Iir; + Range_Type : Iir; + Loc : Iir) + return O_Enode; + end Chap6; + + package Chap7 is + -- Generic function to extract a value from a signal. + generic + with function Read_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + + -- Extract the effective value of SIG. + function Translate_Signal_Effective_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + function Translate_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + + -- Directly set the effective value of SIG with VAL. + -- Used only by conversion. + procedure Set_Effective_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode); + + procedure Set_Driving_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode); + + -- Translate expression EXPR into ortho tree. + function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) + return O_Enode; + + -- Translate call to function IMP. + -- ASSOC_CHAIN is the chain of a associations for this call. + -- OBJ, if not NULL_IIR is the protected object. + function Translate_Function_Call + (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) + return O_Enode; + + -- Translate range and return an lvalue containing the range. + -- The node returned can be used only one time. + function Translate_Range (Arange : Iir; Range_Type : Iir) + return O_Lnode; + + -- Translate range expression EXPR and store the result into the node + -- pointed by RES_PTR, of type RANGE_TYPE. + procedure Translate_Range_Ptr + (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir); + function Translate_Static_Range (Arange : Iir; Range_Type : Iir) + return O_Cnode; + + -- Same as Translate_Range_Ptr, but for a discrete range (ie: ARANGE + -- can be a discrete subtype indication). + procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir); + + -- Return TRUE iff constant declaration DECL can be staticly defined. + -- This is of course true if its expression is a locally static literal, + -- but can be true in a few cases for aggregates. + -- This function belongs to Translation, since it is defined along + -- with the translate_static_aggregate procedure. + function Is_Static_Constant (Decl : Iir_Constant_Declaration) + return Boolean; + + -- Translate the static expression EXPR into an ortho expression whose + -- type must be RES_TYPE. Therefore, an implicite conversion might + -- occurs. + function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) + return O_Cnode; + function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) + return O_Cnode; + + -- Convert (if necessary) EXPR of type EXPR_TYPE to type ATYPE. + function Translate_Implicit_Conv + (Expr : O_Enode; + Expr_Type : Iir; + Atype : Iir; + Is_Sig : Object_Kind_Type; + Loc : Iir) + return O_Enode; + + function Translate_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode; + + -- Convert range EXPR into ortho tree. + -- If RANGE_TYPE /= NULL_IIR, convert bounds to RANGE_TYPE. + --function Translate_Range (Expr : Iir; Range_Type : Iir) return O_Enode; + function Translate_Static_Range_Left + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode; + function Translate_Static_Range_Right + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode; + function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode; + function Translate_Static_Range_Length (Expr : Iir) return O_Cnode; + + -- These functions evaluates left bound/right bound/length of the + -- range expression EXPR. + function Translate_Range_Expression_Left (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode; + function Translate_Range_Expression_Right (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode; + function Translate_Range_Expression_Length (Expr : Iir) return O_Enode; + + -- Get the length of any range expression (ie maybe an attribute). + function Translate_Range_Length (Expr : Iir) return O_Enode; + + -- Assign AGGR to TARGET of type TARGET_TYPE. + procedure Translate_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir); + + -- Translate implicit functions defined by a type. + type Implicit_Subprogram_Infos is private; + procedure Init_Implicit_Subprogram_Infos + (Infos : out Implicit_Subprogram_Infos); + procedure Translate_Implicit_Subprogram + (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos); + + -- Assign EXPR to TARGET. LOC is the location used to report errors. + -- FIXME: do the checks. + procedure Translate_Assign + (Target : Mnode; Expr : Iir; Target_Type : Iir); + procedure Translate_Assign + (Target : Mnode; + Val: O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir); + + -- Find the declaration of the predefined function IMP in type + -- definition BASE_TYPE. + function Find_Predefined_Function + (Base_Type : Iir; Imp : Iir_Predefined_Functions) + return Iir; + + function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) + return O_Enode; + private + type Implicit_Subprogram_Infos is record + Arr_Eq_Info : Subprg_Info_Acc; + Rec_Eq_Info : Subprg_Info_Acc; + Arr_Cmp_Info : Subprg_Info_Acc; + Arr_Concat_Info : Subprg_Info_Acc; + Arr_Shl_Info : Subprg_Info_Acc; + Arr_Sha_Info : Subprg_Info_Acc; + Arr_Rot_Info : Subprg_Info_Acc; + end record; + end Chap7; + + package Chap14 is + function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode; + + -- Read signal value FIELD of signal SIG. + function Get_Signal_Value_Field + (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) + return O_Lnode; + + function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) return O_Lnode; + + function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) + return O_Enode; + function Translate_Low_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_High_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Range_Array_Attribute (Expr : Iir) return O_Lnode; + function Translate_Right_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Left_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Ascending_Array_Attribute (Expr : Iir) return O_Enode; + + function Translate_High_Low_Type_Attribute + (Atype : Iir; Is_High : Boolean) return O_Enode; + + -- Return the value of the left bound/right bound/direction of scalar + -- type ATYPE. + function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode; + function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode; + function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode; + + function Translate_Val_Attribute (Attr : Iir) return O_Enode; + function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) + return O_Enode; + + function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode; + + function Translate_Image_Attribute (Attr : Iir) return O_Enode; + function Translate_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Event_Attribute (Attr : Iir) return O_Enode; + function Translate_Active_Attribute (Attr : Iir) return O_Enode; + function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) + return O_Enode; + + function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Driving_Attribute (Attr : Iir) return O_Enode; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode; + end Chap14; + + package Helpers is + -- Return the value of field FIELD of lnode L that is contains + -- a pointer to a record. + -- This is equivalent to: + -- new_value (new_selected_element (new_access_element (new_value (l)), + -- field)) + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode; + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode; + + -- Equivalent to new_access_element (new_value (l)) + function New_Acc_Value (L : O_Lnode) return O_Lnode; + + -- Copy a fat pointer. + -- D and S are stabilized fat pointers. + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); + + -- Generate code to initialize a ghdl_index_type variable V to 0. + procedure Init_Var (V : O_Dnode); + + -- Generate code to increment/decrement a ghdl_index_type variable V. + procedure Inc_Var (V : O_Dnode); + procedure Dec_Var (V : O_Dnode); + + -- Generate code to exit from loop LABEL iff COND is true. + procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode); + + -- Create a uniq identifier. + subtype Uniq_Identifier_String is String (1 .. 11); + function Create_Uniq_Identifier return Uniq_Identifier_String; + function Create_Uniq_Identifier return O_Ident; + + -- Create a region for temporary variables. + procedure Open_Temp; + -- Create a temporary variable. + function Create_Temp (Atype : O_Tnode) return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with VALUE. + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with the + -- address of NAME. + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode; + -- Create a mark in the temporary region for the stack2. + -- FIXME: maybe a flag must be added to CLOSE_TEMP where it is known + -- stack2 can be released. + procedure Create_Temp_Stack2_Mark; + -- Add ATYPE in the chain of types to be destroyed at the end of the + -- temp scope. + procedure Add_Transient_Type_In_Temp (Atype : Iir); + -- Close the temporary region. + procedure Close_Temp; + + -- Like Open_Temp, but will never create a declare region. To be used + -- only within a subprogram, to use the declare region of the + -- subprogram. + procedure Open_Local_Temp; + -- Destroy transient types created in a temporary region. + procedure Destroy_Local_Transient_Types; + procedure Close_Local_Temp; + + -- Return TRUE if stack2 will be released. Used for fine-tuning only + -- (return statement). + function Has_Stack2_Mark return Boolean; + -- Manually release stack2. Used for fine-tuning only. + procedure Stack2_Release; + + -- Free all old temp. + -- Used only to free memory. + procedure Free_Old_Temp; + + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode; + + -- Create a constant (of name ID) for string STR. + -- Append a NUL terminator (to make interfaces with C easier). + function Create_String (Str : String; Id : O_Ident) return O_Dnode; + + function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode; + + procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode); + + -- Allocate SIZE bytes aligned on the biggest alignment and return a + -- pointer of type PTYPE. + function Gen_Alloc + (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) + return O_Enode; + + -- Allocate on the heap LENGTH bytes aligned on the biggest alignment, + -- and returns a pointer of type PTYPE. + --function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode; + + -- Handle a composite type TARG/TARG_TYPE and apply DO_NON_COMPOSITE + -- on each non composite type. + -- There is a generic parameter DATA which may be updated + -- before indexing an array by UPDATE_DATA_ARRAY. + generic + type Data_Type is private; + type Composite_Data_Type is private; + with procedure Do_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- This function should extract the base of DATA. + with function Prepare_Data_Array (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should index DATA. + with function Update_Data_Array (Data : Composite_Data_Type; + Targ_Type : Iir; + Index : O_Dnode) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Array (Data : in out Composite_Data_Type); + + -- This function should stabilize DATA. + with function Prepare_Data_Record (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should extract field EL of DATA. + with function Update_Data_Record (Data : Composite_Data_Type; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Record (Data : in out Composite_Data_Type); + + procedure Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- Call a procedure (DATA_TYPE) for each signal of TARG. + procedure Register_Signal + (Targ : Mnode; Targ_Type : Iir; Proc : O_Dnode); + + -- Call PROC for each scalar signal of list LIST. + procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode); + + -- Often used subprograms for Foreach_non_composite + -- when DATA_TYPE is o_enode. + function Gen_Oenode_Prepare_Data_Composite + (Targ: Mnode; Targ_Type : Iir; Val : O_Enode) + return Mnode; + function Gen_Oenode_Update_Data_Array (Val : Mnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Enode; + function Gen_Oenode_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Enode; + procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode); + + type Hexstr_Type is array (Integer range 0 .. 15) of Character; + N2hex : constant Hexstr_Type := "0123456789abcdef"; + + function Get_Line_Number (Target: Iir) return Natural; + + procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; + Line : Natural); + private + end Helpers; + use Helpers; + + function Get_Type_Info (M : Mnode) return Type_Info_Acc is + begin + return M.M1.T; + end Get_Type_Info; + + function Get_Object_Kind (M : Mnode) return Object_Kind_Type is + begin + return M.M1.K; + end Get_Object_Kind; + + function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_E, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, E => E, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end E2M; + + function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lv2M; + + function Lv2M (L : O_Lnode; + Comp : Boolean; + Vtype : O_Tnode; + Ptype : O_Tnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => Comp, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lp2M; + + function Lp2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => Vtype, Ptype => Ptype)); + end Lp2M; + + function Lv2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => Vtype, + Ptype => Ptype)); + end Dv2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => Vtype, Ptype => Ptype)); + end Dp2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dp2M; + + function M2Lv (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + case Get_Type_Info (M).Type_Mode is + when Type_Mode_Thin => + -- Scalar to var is not possible. + -- FIXME: This is not coherent with the fact that this + -- conversion is possible when M is stabilized. + raise Internal_Error; + when Type_Mode_Fat => + return New_Access_Element (M.M1.E); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + when Mstate_Lp => + return New_Acc_Value (M.M1.Lp); + when Mstate_Lv => + return M.M1.Lv; + when Mstate_Dp => + return New_Acc_Value (New_Obj (M.M1.Dp)); + when Mstate_Dv => + return New_Obj (M.M1.Dv); + when Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lv; + + function M2Lp (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + raise Internal_Error; + when Mstate_Lp => + return M.M1.Lp; + when Mstate_Dp => + return New_Obj (M.M1.Dp); + when Mstate_Lv => + if Get_Type_Info (M).Type_Mode in Type_Mode_Fat then + return New_Obj + (Create_Temp_Init (M.M1.Ptype, + New_Address (M.M1.Lv, M.M1.Ptype))); + else + raise Internal_Error; + end if; + when Mstate_Dv + | Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lp; + + function M2Dp (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dp => + return M.M1.Dp; + when Mstate_Dv => + return Create_Temp_Init + (M.M1.Ptype, New_Address (New_Obj (M.M1.Dv), M.M1.Ptype)); + + when others => + raise Internal_Error; + end case; + end M2Dp; + + function M2Dv (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dv => + return M.M1.Dv; + when others => + raise Internal_Error; + end case; + end M2Dv; + + function T2M (Atype : Iir; Kind : Object_Kind_Type) return Mnode + is + T : Type_Info_Acc; + begin + T := Get_Info (Atype); + return Mnode'(M1 => (State => Mstate_Null, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end T2M; + + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode + is + D : O_Dnode; + K : Object_Kind_Type; + begin + K := M.M1.K; + case M.M1.State is + when Mstate_E => + if M.M1.Comp then + D := Create_Temp_Init (M.M1.Ptype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + else + D := Create_Temp_Init (M.M1.Vtype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Lp => + D := Create_Temp_Init (M.M1.Ptype, New_Value (M.M1.Lp)); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + when Mstate_Lv => + if M.M1.Ptype = O_Tnode_Null then + if not Can_Copy then + raise Internal_Error; + end if; + D := Create_Temp_Init (M.M1.Vtype, New_Value (M.M1.Lv)); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + + else + D := Create_Temp_Ptr (M.M1.Ptype, M.M1.Lv); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end Stabilize; + + procedure Stabilize (M : in out Mnode) is + begin + M := Stabilize (M); + end Stabilize; + + function Stabilize_Value (M : Mnode) return Mnode + is + D : O_Dnode; + E : O_Enode; + begin + -- M must be scalar or access. + if M.M1.Comp then + raise Internal_Error; + end if; + case M.M1.State is + when Mstate_E => + E := M.M1.E; + when Mstate_Lp => + E := New_Value (New_Acc_Value (M.M1.Lp)); + when Mstate_Lv => + E := New_Value (M.M1.Lv); + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + + D := Create_Temp_Init (M.M1.Vtype, E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => M.M1.K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end Stabilize_Value; + + function M2E (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_E => + return M.M1.E; + when Mstate_Lp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (M.M1.Lp)); + when Type_Mode_Fat => + return New_Value (M.M1.Lp); + end case; + when Mstate_Dp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (New_Obj (M.M1.Dp))); + when Type_Mode_Fat => + return New_Value (New_Obj (M.M1.Dp)); + end case; + when Mstate_Lv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (M.M1.Lv); + when Type_Mode_Fat => + return New_Address (M.M1.Lv, M.M1.Ptype); + end case; + when Mstate_Dv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Obj (M.M1.Dv)); + when Type_Mode_Fat => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + end case; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2E; + + function M2Addr (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_Lp => + return New_Value (M.M1.Lp); + when Mstate_Dp => + return New_Value (New_Obj (M.M1.Dp)); + when Mstate_Lv => + return New_Address (M.M1.Lv, M.M1.Ptype); + when Mstate_Dv => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + when Mstate_E => + if M.M1.Comp then + return M.M1.E; + else + raise Internal_Error; + end if; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2Addr; + +-- function Is_Null (M : Mnode) return Boolean is +-- begin +-- return M.M1.State = Mstate_Null; +-- end Is_Null; + + function Is_Stable (M : Mnode) return Boolean is + begin + case M.M1.State is + when Mstate_Dp + | Mstate_Dv => + return True; + when others => + return False; + end case; + end Is_Stable; + +-- function Varv2M +-- (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) +-- return Mnode is +-- begin +-- return Lv2M (Get_Var (Var), Vtype, Mode); +-- end Varv2M; + + function Varv2M (Var : Var_Type; + Var_Type : Type_Info_Acc; + Mode : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype); + end Varv2M; + + -- Convert a Lnode for a sub object to an MNODE. + function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Lv2M (L, Vtype, Mode); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + return Lp2M (L, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Dv2M (D, Vtype, Mode); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + return Dp2M (D, Vtype, Mode); + else + return Dv2M (D, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Get_Var + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode + is + L : O_Lnode; + D : O_Dnode; + Stable : Boolean; + begin + -- FIXME: there may be Vv2M and Vp2M. + Stable := Is_Var_Stable (Var); + if Stable then + D := Get_Var_Label (Var); + else + L := Get_Var (Var); + end if; + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + if Stable then + return Dp2M (D, Vtype, Mode); + else + return Lp2M (L, Vtype, Mode); + end if; + else + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Get_Var; + + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode is + begin + if Is_Complex_Type (Info) + and then Info.Type_Mode /= Type_Mode_Fat_Array + then + -- For a complex and constrained object, we just allocate + -- a pointer to the object. + return Dp2M (Create_Temp (Info.Ortho_Ptr_Type (Kind)), Info, Kind); + else + return Dv2M (Create_Temp (Info.Ortho_Type (Kind)), Info, Kind); + end if; + end Create_Temp; + + function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type + is + use Name_Table; + Attr : Iir_Attribute_Value; + Spec : Iir_Attribute_Specification; + Attr_Decl : Iir; + Expr : Iir; + begin + -- Look for 'FOREIGN. + Attr := Get_Attribute_Value_Chain (Decl); + while Attr /= Null_Iir loop + Spec := Get_Attribute_Specification (Attr); + Attr_Decl := Get_Attribute_Designator (Spec); + exit when Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign; + Attr := Get_Chain (Attr); + end loop; + if Attr = Null_Iir then + -- Not found. + raise Internal_Error; + end if; + Spec := Get_Attribute_Specification (Attr); + Expr := Get_Expression (Spec); + case Get_Kind (Expr) is + when Iir_Kind_String_Literal => + declare + Ptr : String_Fat_Acc; + begin + Ptr := Get_String_Fat_Acc (Expr); + Name_Length := Natural (Get_String_Length (Expr)); + for I in 1 .. Name_Length loop + Name_Buffer (I) := Ptr (Nat32 (I)); + end loop; + end; + when Iir_Kind_Simple_Aggregate => + declare + List : Iir_List; + El : Iir; + begin + List := Get_Simple_Aggregate_List (Expr); + Name_Length := 0; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Kind (El) /= Iir_Kind_Enumeration_Literal then + raise Internal_Error; + end if; + Name_Length := Name_Length + 1; + Name_Buffer (Name_Length) := + Character'Val (Get_Enum_Pos (El)); + end loop; + end; + when Iir_Kind_Bit_String_Literal => + Error_Msg_Sem + ("value of FOREIGN attribute cannot be a bit string", Expr); + Name_Length := 0; + when others => + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem + ("value of FOREIGN attribute must be locally static", Expr); + Name_Length := 0; + else + raise Internal_Error; + end if; + end case; + + if Name_Length = 0 then + return Foreign_Bad; + end if; + + -- Only 'VHPIDIRECT' is recognized. + if Name_Length >= 10 + and then Name_Buffer (1 .. 10) = "VHPIDIRECT" + then + declare + P : Natural; + Sf, Sl : Natural; + Lf, Ll : Natural; + begin + P := 11; + + -- Skip spaces. + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + if P > Name_Length then + Error_Msg_Sem + ("missing subprogram/library name after VHPIDIRECT", Spec); + end if; + -- Extract library. + Lf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Ll := P; + -- Extract subprogram. + P := P + 1; + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + Sf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Sl := P; + if P < Name_Length then + Error_Msg_Sem ("garbage at end of VHPIDIRECT", Spec); + end if; + + -- Accept empty library. + if Sf > Name_Length then + Sf := Lf; + Sl := Ll; + Lf := 0; + Ll := 0; + end if; + + return Foreign_Info_Type' + (Kind => Foreign_Vhpidirect, + Lib_First => Lf, + Lib_Last => Ll, + Subprg_First => Sf, + Subprg_Last => Sl); + end; + elsif Name_Length = 14 + and then Name_Buffer (1 .. 14) = "GHDL intrinsic" + then + return Foreign_Info_Type'(Kind => Foreign_Intrinsic); + else + Error_Msg_Sem + ("value of 'FOREIGN attribute does not begin with VHPIDIRECT", + Spec); + return Foreign_Bad; + end if; + end Translate_Foreign_Id; + + package body Helpers is + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode is + begin + return New_Value + (New_Selected_Element (New_Access_Element (New_Value (L)), Field)); + end New_Value_Selected_Acc_Value; + + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode is + begin + return New_Selected_Element + (New_Access_Element (New_Value (L)), Field); + end New_Selected_Acc_Value; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode + is + begin + return New_Indexed_Element (New_Access_Element (New_Value (L)), I); + end New_Indexed_Acc_Value; + + function New_Acc_Value (L : O_Lnode) return O_Lnode is + begin + return New_Access_Element (New_Value (L)); + end New_Acc_Value; + + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) + is + begin + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)), + M2Addr (Chap3.Get_Array_Base (S))); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (D)), + M2Addr (Chap3.Get_Array_Bounds (S))); + end Copy_Fat_Pointer; + + procedure Inc_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (V), + New_Lit (Ghdl_Index_1))); + end Inc_Var; + + procedure Dec_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (V), + New_Lit (Ghdl_Index_1))); + end Dec_Var; + + procedure Init_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), New_Lit (Ghdl_Index_0)); + end Init_Var; + + procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode) + is + If_Blk : O_If_Block; + begin + Start_If_Stmt (If_Blk, Cond); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk); + end Gen_Exit_When; + + Uniq_Id : Natural := 0; + + function Create_Uniq_Identifier return Uniq_Identifier_String + is + Str : Uniq_Identifier_String; + Val : Natural; + begin + Str (1 .. 3) := "_UI"; + Val := Uniq_Id; + Uniq_Id := Uniq_Id + 1; + for I in reverse 4 .. 11 loop + Str (I) := N2hex (Val mod 16); + Val := Val / 16; + end loop; + return Str; + end Create_Uniq_Identifier; + + function Create_Uniq_Identifier return O_Ident is + begin + return Get_Identifier (Create_Uniq_Identifier); + end Create_Uniq_Identifier; + + -- Create a temporary variable. + type Temp_Level_Type; + type Temp_Level_Acc is access Temp_Level_Type; + type Temp_Level_Type is record + Prev : Temp_Level_Acc; + Level : Natural; + Id : Natural; + Emitted : Boolean; + Stack2_Mark : O_Dnode; + Transient_Types : Iir; + end record; + -- Current level. + Temp_Level : Temp_Level_Acc := null; + + -- List of unused temp_level_type structures. To be faster, they are + -- never deallocated. + Old_Level : Temp_Level_Acc := null; + + -- If set, emit comments for open_temp/close_temp. + Flag_Debug_Temp : constant Boolean := False; + + procedure Open_Temp + is + L : Temp_Level_Acc; + begin + if Old_Level /= null then + L := Old_Level; + Old_Level := L.Prev; + else + L := new Temp_Level_Type; + end if; + L.all := (Prev => Temp_Level, + Level => 0, + Id => 0, + Emitted => False, + Stack2_Mark => O_Dnode_Null, + Transient_Types => Null_Iir); + if Temp_Level /= null then + L.Level := Temp_Level.Level + 1; + end if; + Temp_Level := L; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Open_Temp level " & Natural'Image (L.Level)); + end if; + end Open_Temp; + + procedure Open_Local_Temp is + begin + Open_Temp; + Temp_Level.Emitted := True; + end Open_Local_Temp; + + procedure Add_Transient_Type_In_Temp (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Type_Info.Type_Transient_Chain := Temp_Level.Transient_Types; + Temp_Level.Transient_Types := Atype; + end Add_Transient_Type_In_Temp; + + procedure Release_Transient_Types (Chain : in out Iir) is + N_Atype : Iir; + begin + while Chain /= Null_Iir loop + N_Atype := Get_Info (Chain).Type_Transient_Chain; + Chap3.Destroy_Type_Info (Chain); + Chain := N_Atype; + end loop; + end Release_Transient_Types; + + procedure Destroy_Local_Transient_Types is + begin + Release_Transient_Types (Temp_Level.Transient_Types); + end Destroy_Local_Transient_Types; + + function Has_Stack2_Mark return Boolean is + begin + return Temp_Level.Stack2_Mark /= O_Dnode_Null; + end Has_Stack2_Mark; + + procedure Stack2_Release + is + Constr : O_Assoc_List; + begin + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Stack2_Release); + New_Association (Constr, + New_Value (New_Obj (Temp_Level.Stack2_Mark))); + New_Procedure_Call (Constr); + Temp_Level.Stack2_Mark := O_Dnode_Null; + end if; + end Stack2_Release; + + procedure Close_Temp + is + L : Temp_Level_Acc; + begin + if Temp_Level = null then + -- OPEN_TEMP was not called. + raise Internal_Error; + end if; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Close_Temp level " & Natural'Image (Temp_Level.Level)); + end if; + + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + Stack2_Release; + end if; + if Temp_Level.Emitted then + Finish_Declare_Stmt; + end if; + + -- Destroy transcient types. + Release_Transient_Types (Temp_Level.Transient_Types); + + -- Unlink temp_level. + L := Temp_Level; + Temp_Level := L.Prev; + L.Prev := Old_Level; + Old_Level := L; + end Close_Temp; + + procedure Close_Local_Temp is + begin + Temp_Level.Emitted := False; + Close_Temp; + end Close_Local_Temp; + + procedure Free_Old_Temp + is + procedure Free is new Ada.Unchecked_Deallocation + (Temp_Level_Type, Temp_Level_Acc); + T : Temp_Level_Acc; + begin + if Temp_Level /= null then + raise Internal_Error; + end if; + loop + T := Old_Level; + exit when T = null; + Old_Level := Old_Level.Prev; + Free (T); + end loop; + end Free_Old_Temp; + + procedure Create_Temp_Stack2_Mark + is + Constr : O_Assoc_List; + begin + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + -- Only the first mark in a region is registred. + -- The release operation frees the memory allocated after the + -- first mark. + return; + end if; + Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type); + Start_Association (Constr, Ghdl_Stack2_Mark); + New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark), + New_Function_Call (Constr)); + end Create_Temp_Stack2_Mark; + + function Create_Temp (Atype : O_Tnode) return O_Dnode + is + Str : String (1 .. 12); + Val : Natural; + Res : O_Dnode; + P : Natural; + begin + if Temp_Level = null then + -- OPEN_TEMP was never called. + raise Internal_Error; + -- This is an hack, just to allow array subtype to array type + -- conversion. + --New_Var_Decl + -- (Res, Create_Uniq_Identifier, O_Storage_Private, Atype); + --return Res; + else + if not Temp_Level.Emitted then + Temp_Level.Emitted := True; + Start_Declare_Stmt; + end if; + end if; + Val := Temp_Level.Id; + Temp_Level.Id := Temp_Level.Id + 1; + P := Str'Last; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := '_'; + P := P - 1; + Val := Temp_Level.Level; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := 'T'; + --Str (12) := Nul; + New_Var_Decl + (Res, Get_Identifier (Str (P .. Str'Last)), O_Storage_Local, Atype); + return Res; + end Create_Temp; + + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode + is + Res : O_Dnode; + begin + Res := Create_Temp (Atype); + New_Assign_Stmt (New_Obj (Res), Value); + return Res; + end Create_Temp_Init; + + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode is + begin + return Create_Temp_Init (Atype, New_Address (Name, Atype)); + end Create_Temp_Ptr; + + -- Return a ghdl_index_type literal for NUM. + function New_Index_Lit (Num : Unsigned_64) return O_Cnode is + begin + return New_Unsigned_Literal (Ghdl_Index_Type, Num); + end New_Index_Lit; + + -- Convert NAME into a STRING_CST. + -- Append a NUL terminator (to make interfaces with C easier). + function Create_String_Type (Str : String) return O_Tnode is + begin + return New_Constrained_Array_Type + (Chararray_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Str'Length + 1))); + end Create_String_Type; + + procedure Create_String_Value + (Const : in out O_Dnode; Const_Type : O_Tnode; Str : String) + is + Res : O_Cnode; + List : O_Array_Aggr_List; + begin + Start_Const_Value (Const); + Start_Array_Aggr (List, Const_Type); + for I in Str'Range loop + New_Array_Aggr_El + (List, + New_Unsigned_Literal (Char_Type_Node, Character'Pos (Str (I)))); + end loop; + New_Array_Aggr_El (List, New_Unsigned_Literal (Char_Type_Node, 0)); + Finish_Array_Aggr (List, Res); + Finish_Const_Value (Const, Res); + end Create_String_Value; + + function Create_String (Str : String; Id : O_Ident) return O_Dnode + is + Atype : O_Tnode; + Const : O_Dnode; + begin + Atype := Create_String_Type (Str); + New_Const_Decl (Const, Id, O_Storage_Private, Atype); + Create_String_Value (Const, Atype, Str); + return Const; + end Create_String; + + function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) + return O_Dnode + is + Atype : O_Tnode; + Const : O_Dnode; + begin + Atype := Create_String_Type (Str); + New_Const_Decl (Const, Id, Storage, Atype); + if Storage /= O_Storage_External then + Create_String_Value (Const, Atype, Str); + end if; + return Const; + end Create_String; + + function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) + return O_Dnode + is + use Name_Table; + begin + if Name_Table.Is_Character (Str) then + raise Internal_Error; + end if; + Image (Str); + return Create_String (Name_Buffer (1 .. Name_Length), Id, Storage); + end Create_String; + + function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode + is + Str_Cst : O_Dnode; + Str_Len : O_Cnode; + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Str_Cst := Create_String (Str, Id); + Str_Len := New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Str'Length)); + Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node); + New_Record_Aggr_El (List, Str_Len); + New_Record_Aggr_El (List, New_Global_Address (Str_Cst, + Char_Ptr_Type)); + Finish_Record_Aggr (List, Res); + return Res; + end Create_String_Len; + + procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode) + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Memcpy); + New_Association (Constr, New_Convert_Ov (Dest, Ghdl_Ptr_Type)); + New_Association (Constr, New_Convert_Ov (Src, Ghdl_Ptr_Type)); + New_Association (Constr, Length); + New_Procedure_Call (Constr); + end Gen_Memcpy; + +-- function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode +-- is +-- Constr : O_Assoc_List; +-- begin +-- Start_Association (Constr, Ghdl_Malloc); +-- New_Association (Constr, Length); +-- return New_Convert_Ov (New_Function_Call (Constr), Ptype); +-- end Gen_Malloc; + + function Gen_Alloc + (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + case Kind is + when Alloc_Heap => + Start_Association (Constr, Ghdl_Malloc); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + when Alloc_System => + Start_Association (Constr, Ghdl_Malloc0); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + when Alloc_Stack => + return New_Alloca (Ptype, Size); + when Alloc_Return => + Start_Association (Constr, Ghdl_Stack2_Allocate); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + end case; + end Gen_Alloc; + + procedure Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_Scalar => + Do_Non_Composite (Targ, Targ_Type, Data); + when Type_Mode_Fat_Array + | Type_Mode_Array => + declare + Var_Array : Mnode; + Var_Base : Mnode; + Var_Length : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + Sub_Data : Data_Type; + Composite_Data : Composite_Data_Type; + begin + Open_Temp; + Var_Array := Stabilize (Targ); + Var_Length := Create_Temp (Ghdl_Index_Type); + Var_Base := Stabilize (Chap3.Get_Array_Base (Var_Array)); + New_Assign_Stmt + (New_Obj (Var_Length), + Chap3.Get_Array_Length (Var_Array, Targ_Type)); + Composite_Data := + Prepare_Data_Array (Var_Array, Targ_Type, Data); + if True then + Var_I := Create_Temp (Ghdl_Index_Type); + else + New_Var_Decl + (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + end if; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Ge, + New_Value (New_Obj (Var_I)), + New_Value (New_Obj (Var_Length)), + Ghdl_Bool_Type)); + Sub_Data := Update_Data_Array + (Composite_Data, Targ_Type, Var_I); + Foreach_Non_Composite + (Chap3.Index_Base (Var_Base, Targ_Type, + New_Value (New_Obj (Var_I))), + Get_Element_Subtype (Targ_Type), + Sub_Data); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Data_Array (Composite_Data); + Close_Temp; + end; + when Type_Mode_Record => + declare + Var_Record : Mnode; + Sub_Data : Data_Type; + Composite_Data : Composite_Data_Type; + List : Iir_List; + El : Iir_Element_Declaration; + begin + Open_Temp; + Var_Record := Stabilize (Targ); + Composite_Data := + Prepare_Data_Record (Var_Record, Targ_Type, Data); + List := Get_Elements_Declaration_List + (Get_Base_Type (Targ_Type)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Sub_Data := Update_Data_Record + (Composite_Data, Targ_Type, El); + Foreach_Non_Composite + (Chap6.Translate_Selected_Element (Var_Record, El), + Get_Type (El), + Sub_Data); + end loop; + Finish_Data_Record (Composite_Data); + Close_Temp; + end; + when others => + Error_Kind ("foreach_non_composite/" + & Type_Mode_Type'Image (Type_Info.Type_Mode), + Targ_Type); + end case; + end Foreach_Non_Composite; + + procedure Register_Non_Composite_Signal (Targ : Mnode; + Targ_Type : Iir; + Proc : O_Dnode) + is + pragma Unreferenced (Targ_Type); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Proc); + New_Association + (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end Register_Non_Composite_Signal; + + function Register_Update_Data_Array + (Data : O_Dnode; Targ_Type : Iir; Index : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ_Type); + pragma Unreferenced (Index); + begin + return Data; + end Register_Update_Data_Array; + + function Register_Prepare_Data_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ); + pragma Unreferenced (Targ_Type); + begin + return Data; + end Register_Prepare_Data_Composite; + + function Register_Update_Data_Record + (Data : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Dnode + is + pragma Unreferenced (Targ_Type); + pragma Unreferenced (El); + begin + return Data; + end Register_Update_Data_Record; + + procedure Register_Finish_Data_Composite (D : in out O_Dnode) + is + pragma Unreferenced (D); + begin + null; + end Register_Finish_Data_Composite; + + procedure Register_Signal_1 is new Foreach_Non_Composite + (Data_Type => O_Dnode, + Composite_Data_Type => O_Dnode, + Do_Non_Composite => Register_Non_Composite_Signal, + Prepare_Data_Array => Register_Prepare_Data_Composite, + Update_Data_Array => Register_Update_Data_Array, + Finish_Data_Array => Register_Finish_Data_Composite, + Prepare_Data_Record => Register_Prepare_Data_Composite, + Update_Data_Record => Register_Update_Data_Record, + Finish_Data_Record => Register_Finish_Data_Composite); + + procedure Register_Signal (Targ : Mnode; + Targ_Type : Iir; + Proc : O_Dnode) + renames Register_Signal_1; + + procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode) + is + El : Iir; + Sig : Mnode; + begin + if List = Null_Iir_List then + return; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Open_Temp; + Sig := Chap6.Translate_Name (El); + Register_Signal (Sig, Get_Type (El), Proc); + Close_Temp; + end loop; + end Register_Signal_List; + + function Gen_Oenode_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : O_Enode) + return Mnode + is + pragma Unreferenced (Targ); + Res : Mnode; + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Targ_Type); + Res := E2M (Val, Type_Info, Mode_Value); + case Type_Info.Type_Mode is + when Type_Mode_Array + | Type_Mode_Fat_Array => + Res := Chap3.Get_Array_Base (Res); + when Type_Mode_Record => + Res := Stabilize (Res); + when others => + -- Not a composite type! + raise Internal_Error; + end case; + return Res; + end Gen_Oenode_Prepare_Data_Composite; + + function Gen_Oenode_Update_Data_Array (Val : Mnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Enode + is + begin + return M2E (Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index))); + end Gen_Oenode_Update_Data_Array; + + function Gen_Oenode_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Enode + is + pragma Unreferenced (Targ_Type); + begin + return M2E (Chap6.Translate_Selected_Element (Val, El)); + end Gen_Oenode_Update_Data_Record; + + procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Oenode_Finish_Data_Composite; + + function Get_Line_Number (Target: Iir) return Natural + is + Line, Col: Natural; + Name : Name_Id; + begin + Files_Map.Location_To_Position + (Get_Location (Target), Name, Line, Col); + return Line; + end Get_Line_Number; + + procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; + Line : Natural) is + begin + New_Association (Assoc, + New_Lit (New_Global_Address (Current_Filename_Node, + Char_Ptr_Type))); + New_Association (Assoc, New_Lit (New_Signed_Literal + (Ghdl_I32_Type, Integer_64 (Line)))); + end Assoc_Filename_Line; + end Helpers; + + package body Chap1 is + procedure Start_Block_Decl (Blk : Iir) + is + Info : constant Block_Info_Acc := Get_Info (Blk); + begin + Chap2.Declare_Inst_Type_And_Ptr + (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type); + end Start_Block_Decl; + + procedure Translate_Entity_Init (Entity : Iir) + is + El : Iir; + El_Type : Iir; + begin + Push_Local_Factory; + + -- Generics. + El := Get_Generic_Chain (Entity); + while El /= Null_Iir loop + Open_Temp; + Chap4.Elab_Object_Value (El, Get_Default_Value (El)); + Close_Temp; + El := Get_Chain (El); + end loop; + + -- Ports. + El := Get_Port_Chain (Entity); + while El /= Null_Iir loop + Open_Temp; + El_Type := Get_Type (El); + if not Is_Fully_Constrained_Type (El_Type) then + Chap5.Elab_Unconstrained_Port (El, Get_Default_Value (El)); + end if; + Chap4.Elab_Signal_Declaration_Storage (El); + Chap4.Elab_Signal_Declaration_Object (El, Entity, False); + Close_Temp; + + El := Get_Chain (El); + end loop; + + Pop_Local_Factory; + end Translate_Entity_Init; + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration) + is + Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Instance : Chap2.Subprg_Instance_Type; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Info := Add_Info (Entity, Kind_Block); + Chap1.Start_Block_Decl (Entity); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Entity link (RTI and pointer to parent). + Info.Block_Link_Field := Add_Instance_Factory_Field + (Wki_Rti, Rtis.Ghdl_Entity_Link_Type); + + -- generics, ports. + Chap4.Translate_Generic_Chain (Entity); + Chap4.Translate_Port_Chain (Entity); + + Chap9.Translate_Block_Declarations (Entity, Entity); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + + -- Entity elaborator. + Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); + + -- Entity dependences elaborator. + Start_Procedure_Decl (Interface_List, Create_Identifier ("PKG_ELAB"), + Global_Storage); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Pkg_Subprg); + + -- Generate RTI. + if Flag_Rti then + Rtis.Generate_Unit (Entity); + end if; + + if Global_Storage = O_Storage_External then + -- Entity declaration subprograms. + Chap4.Translate_Declaration_Chain_Subprograms (Entity); + else + -- Entity declaration and process subprograms. + Chap9.Translate_Block_Subprograms (Entity, Entity); + + -- Package elaborator Body. + Start_Subprogram_Body (Info.Block_Elab_Pkg_Subprg); + Push_Local_Factory; + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + Chap2.Elab_Dependence (Get_Design_Unit (Entity)); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- Elaborator Body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Instance); + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + + Chap9.Elab_Block_Declarations (Entity, Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- Default value if any. + if False then --Is_Entity_Declaration_Top (Entity) then + declare + Init_Subprg : O_Dnode; + begin + Start_Procedure_Decl + (Interface_List, Create_Identifier ("_INIT"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Init_Subprg); + + Start_Subprogram_Body (Init_Subprg); + Chap2.Start_Subprg_Instance_Use (Instance); + Translate_Entity_Init (Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Finish_Subprogram_Body; + end; + end if; + end if; + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end Translate_Entity_Declaration; + + -- Push scope for architecture ARCH via INSTANCE, and for its + -- entity via the entity field of the instance. + procedure Push_Architecture_Scope (Arch : Iir; Instance : O_Dnode) + is + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + begin + Set_Scope_Via_Param_Ptr (Arch_Info.Block_Scope, Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Arch_Info.Block_Parent_Field, + Arch_Info.Block_Scope'Access); + end Push_Architecture_Scope; + + -- Pop scopes created by Push_Architecture_Scope. + procedure Pop_Architecture_Scope (Arch : Iir) + is + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + begin + Clear_Scope (Entity_Info.Block_Scope); + Clear_Scope (Arch_Info.Block_Scope); + end Pop_Architecture_Scope; + + procedure Translate_Architecture_Body (Arch : Iir) + is + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + Instance : O_Dnode; + Var_Arch_Instance : O_Dnode; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + if Get_Foreign_Flag (Arch) then + Error_Msg_Sem ("FOREIGN architectures are not yet handled", Arch); + end if; + + Info := Add_Info (Arch, Kind_Block); + Start_Block_Decl (Arch); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- We cannot use Add_Scope_Field here, because the entity is not a + -- child scope of the architecture. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Get_Identifier ("ENTITY"), + Get_Scope_Type (Entity_Info.Block_Scope)); + + Chap9.Translate_Block_Declarations (Arch, Arch); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + -- Declare the constant containing the size of the instance. + New_Const_Decl + (Info.Block_Instance_Size, Create_Identifier ("INSTSIZE"), + Global_Storage, Ghdl_Index_Type); + if Global_Storage /= O_Storage_External then + Start_Const_Value (Info.Block_Instance_Size); + Finish_Const_Value + (Info.Block_Instance_Size, Get_Scope_Size (Info.Block_Scope)); + end if; + + -- Elaborator. + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB"), Global_Storage); + New_Interface_Decl + (Interface_List, Instance, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); + + -- Generate RTI. + if Flag_Rti then + Rtis.Generate_Unit (Arch); + end if; + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Create process subprograms. + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Info.Block_Parent_Field, + Info.Block_Scope'Access); + + Chap9.Translate_Block_Subprograms (Arch, Arch); + + Clear_Scope (Entity_Info.Block_Scope); + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + + -- Elaborator body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + + -- Create a variable for the architecture instance (with the right + -- type, instead of the entity instance type). + New_Var_Decl (Var_Arch_Instance, Wki_Arch_Instance, + O_Storage_Local, Info.Block_Decls_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Arch_Instance), + New_Convert_Ov (New_Value (New_Obj (Instance)), + Info.Block_Decls_Ptr_Type)); + + -- Set RTI. + if Flag_Rti then + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Instance), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Rti), + New_Unchecked_Address (New_Obj (Info.Block_Rti_Const), + Rtis.Ghdl_Rti_Access)); + end if; + + -- Call entity elaborators. + Start_Association (Constr, Entity_Info.Block_Elab_Subprg); + New_Association (Constr, New_Value (New_Obj (Instance))); + New_Procedure_Call (Constr); + + Push_Architecture_Scope (Arch, Var_Arch_Instance); + + New_Debug_Line_Stmt (Get_Line_Number (Arch)); + Chap2.Elab_Dependence (Get_Design_Unit (Arch)); + + Chap9.Elab_Block_Declarations (Arch, Arch); + --Chap6.Leave_Simple_Name (Ghdl_Leave_Architecture); + + Pop_Architecture_Scope (Arch); + + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Architecture_Body; + + procedure Translate_Component_Configuration_Decl + (Cfg : Iir; Blk : Iir; Base_Block : Iir; Num : in out Iir_Int32) + is + Inter_List : O_Inter_List; + Comp : Iir_Component_Declaration; + Comp_Info : Comp_Info_Acc; + Info : Config_Info_Acc; + Instance : O_Dnode; + Mark, Mark2 : Id_Mark_Type; + + Base_Info : Block_Info_Acc; + Base_Instance : O_Dnode; + + Block : Iir_Block_Configuration; + Binding : Iir_Binding_Indication; + Entity_Aspect : Iir; + Conf_Override : Iir; + Conf_Info : Config_Info_Acc; + begin + -- Incremental binding. + if Get_Nbr_Elements (Get_Instantiation_List (Cfg)) = 0 then + -- This component configuration applies to no component + -- instantiation, so it is not translated. + return; + end if; + + Binding := Get_Binding_Indication (Cfg); + if Binding = Null_Iir then + -- This is an unbound component configuration, since this is a + -- no-op, it is not translated. + return; + end if; + + Entity_Aspect := Get_Entity_Aspect (Binding); + + Comp := Get_Named_Entity (Get_Component_Name (Cfg)); + Comp_Info := Get_Info (Comp); + + if Get_Kind (Cfg) = Iir_Kind_Component_Configuration then + Block := Get_Block_Configuration (Cfg); + else + Block := Null_Iir; + end if; + + Push_Identifier_Prefix (Mark, Get_Identifier (Comp), Num); + Num := Num + 1; + + if Block /= Null_Iir then + Push_Identifier_Prefix (Mark2, "CONFIG"); + Translate_Configuration_Declaration (Cfg); + Pop_Identifier_Prefix (Mark2); + Conf_Override := Cfg; + Conf_Info := Get_Info (Cfg); + Clear_Info (Cfg); + else + Conf_Info := null; + Conf_Override := Null_Iir; + end if; + Info := Add_Info (Cfg, Kind_Config); + + Base_Info := Get_Info (Base_Block); + + Chap4.Translate_Association_Subprograms + (Binding, Blk, Base_Block, + Get_Entity_From_Entity_Aspect (Entity_Aspect)); + + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Comp_Info.Comp_Ptr_Type); + New_Interface_Decl (Inter_List, Base_Instance, Get_Identifier ("BLK"), + Base_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Config_Subprg); + + -- Extract the entity/architecture. + + Start_Subprogram_Body (Info.Config_Subprg); + Push_Local_Factory; + + if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then + Push_Architecture_Scope (Base_Block, Base_Instance); + else + Set_Scope_Via_Param_Ptr (Base_Info.Block_Scope, Base_Instance); + end if; + + Set_Scope_Via_Param_Ptr (Comp_Info.Comp_Scope, Instance); + + if Conf_Info /= null then + Clear_Info (Cfg); + Set_Info (Cfg, Conf_Info); + end if; + Chap9.Translate_Entity_Instantiation + (Entity_Aspect, Binding, Comp, Conf_Override); + if Conf_Info /= null then + Clear_Info (Cfg); + Set_Info (Cfg, Info); + end if; + + Clear_Scope (Comp_Info.Comp_Scope); + + if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then + Pop_Architecture_Scope (Base_Block); + else + Clear_Scope (Base_Info.Block_Scope); + end if; + + Pop_Local_Factory; + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark); + end Translate_Component_Configuration_Decl; + + -- Create subprogram specifications for each configuration_specification + -- in BLOCK_CONFIG and its sub-blocks. + -- BLOCK is the block being configured (initially the architecture), + -- BASE_BLOCK is the root block giving the instance (initially the + -- architecture) + -- NUM is an integer used to generate uniq names. + procedure Translate_Block_Configuration_Decls + (Block_Config : Iir_Block_Configuration; + Block : Iir; + Base_Block : Iir; + Num : in out Iir_Int32) + is + El : Iir; + begin + El := Get_Configuration_Item_Chain (Block_Config); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + Translate_Component_Configuration_Decl + (El, Block, Base_Block, Num); + when Iir_Kind_Block_Configuration => + declare + Mark : Id_Mark_Type; + Base_Info : constant Block_Info_Acc := + Get_Info (Base_Block); + Blk : constant Iir := Get_Block_From_Block_Specification + (Get_Block_Specification (El)); + Blk_Info : constant Block_Info_Acc := Get_Info (Blk); + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Blk)); + case Get_Kind (Blk) is + when Iir_Kind_Generate_Statement => + Set_Scope_Via_Field_Ptr + (Base_Info.Block_Scope, + Blk_Info.Block_Origin_Field, + Blk_Info.Block_Scope'Access); + Translate_Block_Configuration_Decls + (El, Blk, Blk, Num); + Clear_Scope (Base_Info.Block_Scope); + when Iir_Kind_Block_Statement => + Translate_Block_Configuration_Decls + (El, Blk, Base_Block, Num); + when others => + Error_Kind + ("translate_block_configuration_decls(2)", Blk); + end case; + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("translate_block_configuration_decls(1)", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Configuration_Decls; + + procedure Translate_Component_Configuration_Call + (Cfg : Iir; Base_Block : Iir; Block_Info : Block_Info_Acc) + is + Cfg_Info : Config_Info_Acc; + Base_Info : Block_Info_Acc; + begin + if Get_Binding_Indication (Cfg) = Null_Iir then + -- Unbound component configuration, nothing to do. + return; + end if; + + Cfg_Info := Get_Info (Cfg); + Base_Info := Get_Info (Base_Block); + + -- Call the subprogram for the instantiation list. + declare + List : Iir_List; + El : Iir; + begin + List := Get_Instantiation_List (Cfg); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El := Get_Named_Entity (El); + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + declare + Assoc : O_Assoc_List; + Info : constant Block_Info_Acc := Get_Info (El); + Comp_Info : constant Comp_Info_Acc := + Get_Info (Get_Named_Entity + (Get_Instantiated_Unit (El))); + V : O_Lnode; + begin + -- The component is really a component and not a + -- direct instance. + Start_Association (Assoc, Cfg_Info.Config_Subprg); + V := Get_Instance_Ref (Block_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Link_Field); + New_Association + (Assoc, New_Address (V, Comp_Info.Comp_Ptr_Type)); + V := Get_Instance_Ref (Base_Info.Block_Scope); + New_Association + (Assoc, + New_Address (V, Base_Info.Block_Decls_Ptr_Type)); + New_Procedure_Call (Assoc); + end; + when others => + Error_Kind ("translate_component_configuration", El); + end case; + end loop; + end; + end Translate_Component_Configuration_Call; + + procedure Translate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Base_Block : Iir; + Base_Info : Block_Info_Acc); + + procedure Translate_Generate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Parent_Info : Block_Info_Acc) + is + Spec : constant Iir := Get_Block_Specification (Block_Config); + Block : constant Iir := Get_Block_From_Block_Specification (Spec); + Info : constant Block_Info_Acc := Get_Info (Block); + Scheme : constant Iir := Get_Generation_Scheme (Block); + + Type_Info : Type_Info_Acc; + Iter_Type : Iir; + + -- Generate a call for a iterative generate block whose index is + -- INDEX. + -- FAILS is true if it is an error if the block is already + -- configured. + procedure Gen_Subblock_Call (Index : O_Enode; Fails : Boolean) + is + Var_Inst : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + Var_Inst := Create_Temp (Info.Block_Decls_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Inst), + New_Address (New_Indexed_Element + (New_Acc_Value + (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Info.Block_Parent_Field)), + Index), + Info.Block_Decls_Ptr_Type)); + -- Configure only if not yet configured. + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Value_Selected_Acc_Value + (New_Obj (Var_Inst), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_False_Node), + Ghdl_Bool_Type)); + -- Mark the block as configured. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Inst), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_True_Node)); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var_Inst); + Translate_Block_Configuration_Calls (Block_Config, Block, Info); + Clear_Scope (Info.Block_Scope); + + if Fails then + New_Else_Stmt (If_Blk); + -- Already configured. + Chap6.Gen_Program_Error + (Block_Config, Chap6.Prg_Err_Block_Configured); + end if; + + Finish_If_Stmt (If_Blk); + Close_Temp; + end Gen_Subblock_Call; + + procedure Apply_To_All_Others_Blocks (Is_All : Boolean) + is + Var_I : O_Dnode; + Label : O_Snode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op + (ON_Eq, + New_Value (New_Obj (Var_I)), + New_Value + (New_Selected_Element + (Get_Var (Get_Info (Iter_Type).T.Range_Var), + Type_Info.T.Range_Length)), + Ghdl_Bool_Type)); + -- Selected_name is for default configurations, so + -- program should not fail if a block is already + -- configured but continue silently. + Gen_Subblock_Call (New_Value (New_Obj (Var_I)), Is_All); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + end Apply_To_All_Others_Blocks; + begin + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Type_Info := Get_Info (Get_Base_Type (Iter_Type)); + case Get_Kind (Spec) is + when Iir_Kind_Generate_Statement + | Iir_Kind_Simple_Name => + Apply_To_All_Others_Blocks (True); + when Iir_Kind_Indexed_Name => + declare + Index_List : constant Iir_List := Get_Index_List (Spec); + Rng : Mnode; + begin + if Index_List = Iir_List_Others then + Apply_To_All_Others_Blocks (False); + else + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); + Gen_Subblock_Call + (Chap6.Translate_Index_To_Offset + (Rng, + Chap7.Translate_Expression + (Get_Nth_Element (Index_List, 0), Iter_Type), + Scheme, Iter_Type, Spec), + True); + Close_Temp; + end if; + end; + when Iir_Kind_Slice_Name => + declare + Rng : Mnode; + Slice : O_Dnode; + Slice_Ptr : O_Dnode; + Left, Right : O_Dnode; + Index : O_Dnode; + High : O_Dnode; + If_Blk : O_If_Block; + Label : O_Snode; + begin + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); + Slice := Create_Temp (Type_Info.T.Range_Type); + Slice_Ptr := Create_Temp_Ptr + (Type_Info.T.Range_Ptr_Type, New_Obj (Slice)); + Chap7.Translate_Discrete_Range_Ptr + (Slice_Ptr, Get_Suffix (Spec)); + Left := Create_Temp_Init + (Ghdl_Index_Type, + Chap6.Translate_Index_To_Offset + (Rng, + New_Value (New_Selected_Element + (New_Obj (Slice), Type_Info.T.Range_Left)), + Spec, Iter_Type, Spec)); + Right := Create_Temp_Init + (Ghdl_Index_Type, + Chap6.Translate_Index_To_Offset + (Rng, + New_Value (New_Selected_Element + (New_Obj (Slice), + Type_Info.T.Range_Right)), + Spec, Iter_Type, Spec)); + Index := Create_Temp (Ghdl_Index_Type); + High := Create_Temp (Ghdl_Index_Type); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Value + (New_Selected_Element + (New_Obj (Slice), + Type_Info.T.Range_Dir)), + Ghdl_Bool_Type)); + -- Same direction, so left to right. + New_Assign_Stmt (New_Obj (Index), + New_Value (New_Obj (Left))); + New_Assign_Stmt (New_Obj (High), + New_Value (New_Obj (Right))); + New_Else_Stmt (If_Blk); + -- Opposite direction, so right to left. + New_Assign_Stmt (New_Obj (Index), + New_Value (New_Obj (Right))); + New_Assign_Stmt (New_Obj (High), + New_Value (New_Obj (Left))); + Finish_If_Stmt (If_Blk); + + -- Loop. + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Gt, + New_Value (New_Obj (Index)), + New_Value (New_Obj (High)), + Ghdl_Bool_Type)); + Open_Temp; + Gen_Subblock_Call (New_Value (New_Obj (Index)), True); + Close_Temp; + Inc_Var (Index); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + when others => + Error_Kind + ("translate_generate_block_configuration_calls", Spec); + end case; + else + -- Conditional generate statement. + declare + Var : O_Dnode; + If_Blk : O_If_Block; + begin + -- Configure the block only if it was created. + Open_Temp; + Var := Create_Temp_Init + (Info.Block_Decls_Ptr_Type, + New_Value (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Info.Block_Parent_Field))); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Neq, + New_Obj_Value (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), + Ghdl_Bool_Type)); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Translate_Block_Configuration_Calls (Block_Config, Block, Info); + Clear_Scope (Info.Block_Scope); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + end if; + end Translate_Generate_Block_Configuration_Calls; + + procedure Translate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Base_Block : Iir; + Base_Info : Block_Info_Acc) + is + El : Iir; + begin + El := Get_Configuration_Item_Chain (Block_Config); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + Translate_Component_Configuration_Call + (El, Base_Block, Base_Info); + when Iir_Kind_Block_Configuration => + declare + Block : constant Iir := Strip_Denoting_Name + (Get_Block_Specification (El)); + begin + if Get_Kind (Block) = Iir_Kind_Block_Statement then + Translate_Block_Configuration_Calls + (El, Base_Block, Get_Info (Block)); + else + Translate_Generate_Block_Configuration_Calls + (El, Base_Info); + end if; + end; + when others => + Error_Kind ("translate_block_configuration_calls(2)", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Configuration_Calls; + + procedure Translate_Configuration_Declaration (Config : Iir) + is + Block_Config : constant Iir_Block_Configuration := + Get_Block_Configuration (Config); + Arch : constant Iir_Architecture_Body := + Get_Block_Specification (Block_Config); + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Interface_List : O_Inter_List; + Config_Info : Config_Info_Acc; + Instance : O_Dnode; + Num : Iir_Int32; + Final : Boolean; + begin + if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then + Chap4.Translate_Declaration_Chain (Config); + end if; + + Config_Info := Add_Info (Config, Kind_Config); + + -- Configurator. + Start_Procedure_Decl + (Interface_List, Create_Identifier, Global_Storage); + New_Interface_Decl (Interface_List, Instance, Wki_Instance, + Arch_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, Config_Info.Config_Subprg); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Declare subprograms for configuration. + Num := 0; + Translate_Block_Configuration_Decls (Block_Config, Arch, Arch, Num); + + -- Body. + Start_Subprogram_Body (Config_Info.Config_Subprg); + Push_Local_Factory; + + Push_Architecture_Scope (Arch, Instance); + + if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then + Open_Temp; + Chap4.Elab_Declaration_Chain (Config, Final); + Close_Temp; + if Final then + raise Internal_Error; + end if; + end if; + + Translate_Block_Configuration_Calls (Block_Config, Arch, Arch_Info); + + Pop_Architecture_Scope (Arch); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Configuration_Declaration; + end Chap1; + + package body Chap2 is + procedure Elab_Package (Spec : Iir_Package_Declaration); + + type Name_String_Xlat_Array is array (Name_Id range <>) of + String (1 .. 4); + Operator_String_Xlat : constant + Name_String_Xlat_Array (Std_Names.Name_Id_Operators) := + (Std_Names.Name_Op_Equality => "OPEq", + Std_Names.Name_Op_Inequality => "OPNe", + Std_Names.Name_Op_Less => "OPLt", + Std_Names.Name_Op_Less_Equal => "OPLe", + Std_Names.Name_Op_Greater => "OPGt", + Std_Names.Name_Op_Greater_Equal => "OPGe", + Std_Names.Name_Op_Plus => "OPPl", + Std_Names.Name_Op_Minus => "OPMi", + Std_Names.Name_Op_Mul => "OPMu", + Std_Names.Name_Op_Div => "OPDi", + Std_Names.Name_Op_Exp => "OPEx", + Std_Names.Name_Op_Concatenation => "OPCc", + Std_Names.Name_Op_Condition => "OPCd", + Std_Names.Name_Op_Match_Equality => "OPQe", + Std_Names.Name_Op_Match_Inequality => "OPQi", + Std_Names.Name_Op_Match_Less => "OPQL", + Std_Names.Name_Op_Match_Less_Equal => "OPQl", + Std_Names.Name_Op_Match_Greater => "OPQG", + Std_Names.Name_Op_Match_Greater_Equal => "OPQg"); + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type) + is + Id : Name_Id; + begin + -- FIXME: name_shift_operators, name_logical_operators, + -- name_word_operators, name_mod, name_rem + Id := Get_Identifier (Spec); + if Id in Std_Names.Name_Id_Operators then + Push_Identifier_Prefix + (Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec)); + else + Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec)); + end if; + end Push_Subprg_Identifier; + + procedure Translate_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + Mark : Id_Mark_Type; + begin + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Translate_Object_Subtype (Inter); + Inter := Get_Chain (Inter); + end loop; + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Interfaces; + + procedure Elab_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + begin + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Elab_Object_Subtype (Get_Type (Inter)); + Inter := Get_Chain (Inter); + end loop; + end Elab_Subprogram_Interfaces; + + + -- Return the type of a subprogram interface. + -- Return O_Tnode_Null if the parameter is passed through the + -- interface record. + function Translate_Interface_Type (Inter : Iir) return O_Tnode + is + Mode : Object_Kind_Type; + Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); + begin + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_File_Declaration => + Mode := Mode_Value; + when Iir_Kind_Interface_Signal_Declaration => + Mode := Mode_Signal; + when others => + Error_Kind ("translate_interface_type", Inter); + end case; + case Tinfo.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Tinfo.Ortho_Type (Mode); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + return Tinfo.Ortho_Ptr_Type (Mode); + end case; + end Translate_Interface_Type; + + procedure Translate_Subprogram_Declaration (Spec : Iir) + is + Info : constant Subprg_Info_Acc := Get_Info (Spec); + Is_Func : constant Boolean := + Get_Kind (Spec) = Iir_Kind_Function_Declaration; + Inter : Iir; + Inter_Type : Iir; + Arg_Info : Ortho_Info_Acc; + Tinfo : Type_Info_Acc; + Interface_List : O_Inter_List; + Has_Result_Record : Boolean; + El_List : O_Element_List; + Mark : Id_Mark_Type; + Rtype : Iir; + Id : O_Ident; + Storage : O_Storage; + Foreign : Foreign_Info_Type := Foreign_Bad; + begin + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + if Get_Foreign_Flag (Spec) then + -- Special handling for foreign subprograms. + Foreign := Translate_Foreign_Id (Spec); + case Foreign.Kind is + when Foreign_Unknown => + Id := Create_Identifier; + when Foreign_Intrinsic => + Id := Create_Identifier; + when Foreign_Vhpidirect => + Id := Get_Identifier + (Name_Table.Name_Buffer (Foreign.Subprg_First + .. Foreign.Subprg_Last)); + end case; + Storage := O_Storage_External; + else + Id := Create_Identifier; + Storage := Global_Storage; + end if; + + if Is_Func then + -- If the result of a function is a composite type for ortho, + -- the result is allocated by the caller and an access to it is + -- given to the function. + Rtype := Get_Return_Type (Spec); + Info.Use_Stack2 := False; + Tinfo := Get_Info (Rtype); + + if Is_Composite (Tinfo) then + Start_Procedure_Decl (Interface_List, Id, Storage); + New_Interface_Decl + (Interface_List, Info.Res_Interface, + Get_Identifier ("RESULT"), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + -- Furthermore, if the result type is unconstrained, the + -- function will allocate it on a secondary stack. + if not Is_Fully_Constrained_Type (Rtype) then + Info.Use_Stack2 := True; + end if; + else + -- Normal function. + Start_Function_Decl + (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value)); + Info.Res_Interface := O_Dnode_Null; + end if; + else + -- Create info for each interface of the procedure. + -- For parameters passed via copy and that needs a copy-out, + -- gather them in a record. An access to the record is then + -- passed to the procedure. + Has_Result_Record := False; + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Arg_Info := Add_Info (Inter, Kind_Interface); + Inter_Type := Get_Type (Inter); + Tinfo := Get_Info (Inter_Type); + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Inter) in Iir_Out_Modes + and then Tinfo.Type_Mode not in Type_Mode_By_Ref + and then Tinfo.Type_Mode /= Type_Mode_File + then + -- This interface is done via the result record. + -- Note: file passed through variables are vhdl87 files, + -- which are initialized at elaboration and thus + -- behave like an IN parameter. + if not Has_Result_Record then + -- Create the record. + Start_Record_Type (El_List); + Has_Result_Record := True; + end if; + -- Add a field to the record. + New_Record_Field (El_List, Arg_Info.Interface_Field, + Create_Identifier_Without_Prefix (Inter), + Tinfo.Ortho_Type (Mode_Value)); + else + Arg_Info.Interface_Field := O_Fnode_Null; + end if; + Inter := Get_Chain (Inter); + end loop; + if Has_Result_Record then + -- Declare the record type and an access to the record. + Finish_Record_Type (El_List, Info.Res_Record_Type); + New_Type_Decl (Create_Identifier ("RESTYPE"), + Info.Res_Record_Type); + Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type); + New_Type_Decl (Create_Identifier ("RESPTR"), + Info.Res_Record_Ptr); + else + Info.Res_Interface := O_Dnode_Null; + end if; + + Start_Procedure_Decl (Interface_List, Id, Storage); + + if Has_Result_Record then + -- Add the record parameter. + New_Interface_Decl (Interface_List, Info.Res_Interface, + Get_Identifier ("RESULT"), + Info.Res_Record_Ptr); + end if; + end if; + + -- Instance parameter if any. + if not Get_Foreign_Flag (Spec) then + Chap2.Create_Subprg_Instance (Interface_List, Spec); + end if; + + -- Translate interfaces. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Is_Func then + -- Create the info. + Arg_Info := Add_Info (Inter, Kind_Interface); + Arg_Info.Interface_Field := O_Fnode_Null; + else + -- The info was already created (just above) + Arg_Info := Get_Info (Inter); + end if; + + if Arg_Info.Interface_Field = O_Fnode_Null then + -- Not via the RESULT parameter. + Arg_Info.Interface_Type := Translate_Interface_Type (Inter); + New_Interface_Decl + (Interface_List, Arg_Info.Interface_Node, + Create_Identifier_Without_Prefix (Inter), + Arg_Info.Interface_Type); + end if; + Inter := Get_Chain (Inter); + end loop; + Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); + + -- Call the hook for foreign subprograms. + if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then + Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func); + end if; + + Save_Local_Identifier (Info.Subprg_Local_Id); + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Declaration; + + -- Return TRUE iff subprogram specification SPEC is translated in an + -- ortho function. + function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean + is + begin + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + return False; + end if; + if Get_Info (Spec).Res_Interface /= O_Dnode_Null then + return False; + end if; + return True; + end Is_Subprogram_Ortho_Function; + + -- Return TRUE iif SUBPRG_BODY declares explicitely or implicitely + -- (or even implicitely by translation) a subprogram. + function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean + is + Decl : Iir; + Atype : Iir; + begin + Decl := Get_Declaration_Chain (Subprg_Body); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- The declaration preceed the body. + raise Internal_Error; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Atype := Get_Type_Definition (Decl); + case Iir_Kinds_Type_And_Subtype_Definition + (Get_Kind (Atype)) is + when Iir_Kinds_Scalar_Type_Definition => + null; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_File_Type_Definition => + return True; + when Iir_Kind_Protected_Type_Declaration => + raise Internal_Error; + when Iir_Kinds_Composite_Type_Definition => + -- At least for "=". + return True; + when Iir_Kind_Incomplete_Type_Definition => + null; + end case; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return False; + end Has_Nested_Subprograms; + + procedure Translate_Subprogram_Body (Subprg : Iir) + is + Spec : constant Iir := Get_Subprogram_Specification (Subprg); + Info : constant Ortho_Info_Acc := Get_Info (Spec); + + Old_Subprogram : Iir; + Mark : Id_Mark_Type; + Final : Boolean; + Is_Ortho_Func : Boolean; + + -- Set for a public method. In this case, the lock must be acquired + -- and retained. + Is_Prot : Boolean := False; + + -- True if the body has local (nested) subprograms. + Has_Nested : Boolean; + + Frame_Ptr_Type : O_Tnode; + Upframe_Field : O_Fnode; + + Frame : O_Dnode; + Frame_Ptr : O_Dnode; + + Has_Return : Boolean; + + Prev_Subprg_Instances : Chap2.Subprg_Instance_Stack; + begin + -- Do not translate body for foreign subprograms. + if Get_Foreign_Flag (Spec) then + return; + end if; + + -- Check if there are nested subprograms to unnest. In that case, + -- a frame record is created, which is less efficient than the + -- use of local variables. + if Flag_Unnest_Subprograms then + Has_Nested := Has_Nested_Subprograms (Subprg); + else + Has_Nested := False; + end if; + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + Restore_Local_Identifier (Info.Subprg_Local_Id); + + if Has_Nested then + -- Unnest subprograms. + -- Create an instance for the local declarations. + Push_Instance_Factory (Info.Subprg_Frame_Scope'Access); + Add_Subprg_Instance_Field (Upframe_Field); + + if Info.Res_Record_Ptr /= O_Tnode_Null then + Info.Res_Record_Var := + Create_Var (Create_Var_Identifier ("RESULT"), + Info.Res_Record_Ptr); + end if; + + -- Create fields for parameters. + -- FIXME: do it only if they are referenced in nested + -- subprograms. + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + Inter_Info.Interface_Field := + Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inter), + Inter_Info.Interface_Type); + end if; + Inter := Get_Chain (Inter); + end loop; + end; + + Chap4.Translate_Declaration_Chain (Subprg); + Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access); + + New_Type_Decl (Create_Identifier ("_FRAMETYPE"), + Get_Scope_Type (Info.Subprg_Frame_Scope)); + Declare_Scope_Acc + (Info.Subprg_Frame_Scope, + Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type); + + Rtis.Generate_Subprogram_Body (Subprg); + + -- Local frame + Chap2.Push_Subprg_Instance + (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, + Wki_Upframe, Prev_Subprg_Instances); + -- Link to previous frame + Chap2.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); + + -- Link to previous frame + Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + -- Local frame + Chap2.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances); + end if; + + -- Create the body + + Start_Subprogram_Body (Info.Ortho_Func); + + Start_Subprg_Instance_Use (Spec); + + -- Variables will be created on the stack. + Push_Local_Factory; + + -- Code has access to local (and outer) variables. + -- FIXME: this is not necessary if Has_Nested is set + Chap2.Clear_Subprg_Instance (Prev_Subprg_Instances); + + -- There is a local scope for temporaries. + Open_Local_Temp; + + if not Has_Nested then + Chap4.Translate_Declaration_Chain (Subprg); + Rtis.Generate_Subprogram_Body (Subprg); + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); + else + New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, + Get_Scope_Type (Info.Subprg_Frame_Scope)); + + New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"), + O_Storage_Local, Frame_Ptr_Type); + New_Assign_Stmt (New_Obj (Frame_Ptr), + New_Address (New_Obj (Frame), Frame_Ptr_Type)); + + -- FIXME: use direct reference (ie Frame instead of Frame_Ptr) + Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr); + + -- Set UPFRAME. + Chap2.Set_Subprg_Instance_Field + (Frame_Ptr, Upframe_Field, Info.Subprg_Instance); + + if Info.Res_Record_Type /= O_Tnode_Null then + -- Initialize the RESULT field + New_Assign_Stmt (Get_Var (Info.Res_Record_Var), + New_Obj_Value (Info.Res_Interface)); + -- Do not reference the RESULT field in the subprogram body, + -- directly reference the RESULT parameter. + -- FIXME: has a flag (see below for parameters). + Info.Res_Record_Var := Null_Var; + end if; + + -- Copy parameters to FRAME. + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + New_Assign_Stmt + (New_Selected_Element (New_Obj (Frame), + Inter_Info.Interface_Field), + New_Obj_Value (Inter_Info.Interface_Node)); + + -- Forget the reference to the field in FRAME, so that + -- this subprogram will directly reference the parameter + -- (and not its copy in the FRAME). + Inter_Info.Interface_Field := O_Fnode_Null; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + end if; + + -- Init out parameters passed by value/copy. + declare + Inter : Iir; + Inter_Type : Iir; + Type_Info : Type_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Inter) = Iir_Out_Mode + then + Inter_Type := Get_Type (Inter); + Type_Info := Get_Info (Inter_Type); + if (Type_Info.Type_Mode in Type_Mode_By_Value + or Type_Info.Type_Mode in Type_Mode_By_Copy) + and then Type_Info.Type_Mode /= Type_Mode_File + then + Chap4.Init_Object + (Chap6.Translate_Name (Inter), Inter_Type); + end if; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + + Chap4.Elab_Declaration_Chain (Subprg, Final); + + -- If finalization is required, create a dummy loop around the + -- body and convert returns into exit out of this loop. + -- If the subprogram is a function, also create a variable for the + -- result. + Is_Prot := Is_Subprogram_Method (Spec); + if Final or Is_Prot then + if Is_Prot then + -- Lock the object. + Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), + Ghdl_Protected_Enter); + end if; + Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec); + if Is_Ortho_Func then + New_Var_Decl + (Info.Subprg_Result, Get_Identifier ("RESULT"), + O_Storage_Local, + Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value)); + end if; + Start_Loop_Stmt (Info.Subprg_Exit); + end if; + + Old_Subprogram := Current_Subprogram; + Current_Subprogram := Spec; + Has_Return := Chap8.Translate_Statements_Chain_Has_Return + (Get_Sequential_Statement_Chain (Subprg)); + Current_Subprogram := Old_Subprogram; + + if Final or Is_Prot then + -- Create a barrier to catch missing return statement. + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + New_Exit_Stmt (Info.Subprg_Exit); + else + if not Has_Return then + -- Missing return + Chap6.Gen_Program_Error + (Subprg, Chap6.Prg_Err_Missing_Return); + end if; + end if; + Finish_Loop_Stmt (Info.Subprg_Exit); + Chap4.Final_Declaration_Chain (Subprg, False); + + if Is_Prot then + -- Unlock the object. + Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), + Ghdl_Protected_Leave); + end if; + if Is_Ortho_Func then + New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); + end if; + else + if Get_Kind (Spec) = Iir_Kind_Function_Declaration + and then not Has_Return + then + -- Missing return + Chap6.Gen_Program_Error + (Subprg, Chap6.Prg_Err_Missing_Return); + end if; + end if; + + if Has_Nested then + Clear_Scope (Info.Subprg_Frame_Scope); + end if; + + Chap2.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances); + Close_Local_Temp; + Pop_Local_Factory; + + Finish_Subprg_Instance_Use (Spec); + + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Body; + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) + is + Header : constant Iir := Get_Package_Header (Decl); + Info : Ortho_Info_Acc; + Interface_List : O_Inter_List; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Info := Add_Info (Decl, Kind_Package); + + -- Translate declarations. + if Is_Uninstantiated_Package (Decl) then + -- Create an instance for the spec. + Push_Instance_Factory (Info.Package_Spec_Scope'Access); + Chap4.Translate_Generic_Chain (Header); + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + Pop_Instance_Factory (Info.Package_Spec_Scope'Access); + + -- Name the spec instance and create a pointer. + New_Type_Decl (Create_Identifier ("SPECINSTTYPE"), + Get_Scope_Type (Info.Package_Spec_Scope)); + Declare_Scope_Acc (Info.Package_Spec_Scope, + Create_Identifier ("SPECINSTPTR"), + Info.Package_Spec_Ptr_Type); + + -- Create an instance and its pointer for the body. + Chap2.Declare_Inst_Type_And_Ptr + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type); + + -- Each subprogram has a body instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + else + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + end if; + + -- Translate subprograms declarations. + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + -- Declare elaborator for the body. + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Body_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Body_Subprg); + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + + -- The spec elaborator has a spec instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + end if; + + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Spec_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Spec_Subprg); + + if Flag_Rti then + -- Generate RTI. + Rtis.Generate_Unit (Decl); + end if; + + if Global_Storage = O_Storage_Public then + -- Create elaboration procedure for the spec + Elab_Package (Decl); + end if; + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; + Save_Local_Identifier (Info.Package_Local_Id); + end Translate_Package_Declaration; + + procedure Translate_Package_Body (Decl : Iir_Package_Body) + is + Spec : constant Iir_Package_Declaration := Get_Package (Decl); + Info : constant Ortho_Info_Acc := Get_Info (Spec); + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + -- Translate declarations. + if Is_Uninstantiated_Package (Spec) then + Push_Instance_Factory (Info.Package_Body_Scope'Access); + Info.Package_Spec_Field := Add_Instance_Factory_Field + (Get_Identifier ("SPEC"), + Get_Scope_Type (Info.Package_Spec_Scope)); + + Chap4.Translate_Declaration_Chain (Decl); + + Pop_Instance_Factory (Info.Package_Body_Scope'Access); + + if Global_Storage = O_Storage_External then + return; + end if; + else + -- May be called during elaboration to generate RTI. + if Global_Storage = O_Storage_External then + return; + end if; + + Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id); + + Chap4.Translate_Declaration_Chain (Decl); + end if; + + if Flag_Rti then + Rtis.Generate_Unit (Decl); + end if; + + if Is_Uninstantiated_Package (Spec) then + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; + + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; + + Elab_Package_Body (Spec, Decl); + end Translate_Package_Body; + + procedure Elab_Package (Spec : Iir_Package_Declaration) + is + Info : constant Ortho_Info_Acc := Get_Info (Spec); + Final : Boolean; + Constr : O_Assoc_List; + pragma Unreferenced (Final); + begin + Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); + + Elab_Dependence (Get_Design_Unit (Spec)); + + if not Is_Uninstantiated_Package (Spec) + and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit + then + -- Register the top level package. This is done dynamically, as + -- we know only during elaboration that the design depends on a + -- package (a package maybe referenced by an entity which is never + -- instantiated due to generate statements). + Start_Association (Constr, Ghdl_Rti_Add_Package); + New_Association + (Constr, + New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); + New_Procedure_Call (Constr); + end if; + + Open_Temp; + Chap4.Elab_Declaration_Chain (Spec, Final); + Close_Temp; + + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package; + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) + is + Info : constant Ortho_Info_Acc := Get_Info (Spec); + If_Blk : O_If_Block; + Constr : O_Assoc_List; + Final : Boolean; + begin + Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); + + if Is_Uninstantiated_Package (Spec) then + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; + + -- If the package was already elaborated, return now, + -- else mark the package as elaborated. + Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var))); + New_Return_Stmt; + New_Else_Stmt (If_Blk); + New_Assign_Stmt (Get_Var (Info.Package_Elab_Var), + New_Lit (Ghdl_Bool_True_Node)); + Finish_If_Stmt (If_Blk); + + -- Elab Spec. + Start_Association (Constr, Info.Package_Elab_Spec_Subprg); + Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance); + New_Procedure_Call (Constr); + + if Bod /= Null_Iir then + Elab_Dependence (Get_Design_Unit (Bod)); + Open_Temp; + Chap4.Elab_Declaration_Chain (Bod, Final); + Close_Temp; + end if; + + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + end if; + + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package_Body; + + procedure Instantiate_Iir_Info (N : Iir); + + procedure Instantiate_Iir_Chain_Info (Chain : Iir) + is + N : Iir; + begin + N := Chain; + while N /= Null_Iir loop + Instantiate_Iir_Info (N); + N := Get_Chain (N); + end loop; + end Instantiate_Iir_Chain_Info; + + procedure Instantiate_Iir_List_Info (L : Iir_List) + is + El : Iir; + begin + case L is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + return; + when others => + for I in Natural loop + El := Get_Nth_Element (L, I); + exit when El = Null_Iir; + Instantiate_Iir_Info (El); + end loop; + end case; + end Instantiate_Iir_List_Info; + + procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is + begin + case Src.Kind is + when Kind_Type => + Dest.all := (Kind => Kind_Type, + Type_Mode => Src.Type_Mode, + Type_Incomplete => Src.Type_Incomplete, + Type_Locally_Constrained => + Src.Type_Locally_Constrained, + C => null, + Ortho_Type => Src.Ortho_Type, + Ortho_Ptr_Type => Src.Ortho_Ptr_Type, + Type_Transient_Chain => Null_Iir, + T => Src.T, + Type_Rti => Src.Type_Rti); + pragma Assert (Src.C = null); + pragma Assert (Src.Type_Transient_Chain = Null_Iir); + when Kind_Object => + pragma Assert (Src.Object_Driver = Null_Var); + pragma Assert (Src.Object_Function = O_Dnode_Null); + Dest.all := + (Kind => Kind_Object, + Object_Static => Src.Object_Static, + Object_Var => Instantiate_Var (Src.Object_Var), + Object_Driver => Null_Var, + Object_Rti => Src.Object_Rti, + Object_Function => O_Dnode_Null); + when Kind_Subprg => + Dest.Subprg_Frame_Scope := + Instantiate_Var_Scope (Src.Subprg_Frame_Scope); + Dest.all := + (Kind => Kind_Subprg, + Use_Stack2 => Src.Use_Stack2, + Ortho_Func => Src.Ortho_Func, + Res_Interface => Src.Res_Interface, + Res_Record_Var => Instantiate_Var (Src.Res_Record_Var), + Res_Record_Type => Src.Res_Record_Type, + Res_Record_Ptr => Src.Res_Record_Ptr, + Subprg_Frame_Scope => Dest.Subprg_Frame_Scope, + Subprg_Instance => Instantiate_Subprg_Instance + (Src.Subprg_Instance), + Subprg_Resolv => null, + Subprg_Local_Id => Src.Subprg_Local_Id, + Subprg_Exit => Src.Subprg_Exit, + Subprg_Result => Src.Subprg_Result); + when Kind_Interface => + Dest.all := (Kind => Kind_Interface, + Interface_Node => Src.Interface_Node, + Interface_Field => Src.Interface_Field, + Interface_Type => Src.Interface_Type); + when Kind_Index => + Dest.all := (Kind => Kind_Index, + Index_Field => Src.Index_Field); + when Kind_Expr => + Dest.all := (Kind => Kind_Expr, + Expr_Node => Src.Expr_Node); + when others => + raise Internal_Error; + end case; + end Copy_Info; + + procedure Instantiate_Iir_Info (N : Iir) is + begin + -- Nothing to do for null node. + if N = Null_Iir then + return; + end if; + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + Orig : constant Iir := Sem_Inst.Get_Origin (N); + pragma Assert (Orig /= Null_Iir); + Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig); + Info : Ortho_Info_Acc; + begin + if Orig_Info /= null then + Info := Add_Info (N, Orig_Info.Kind); + + Copy_Info (Info, Orig_Info); + + case Info.Kind is + when Kind_Subprg => + Push_Instantiate_Var_Scope + (Info.Subprg_Frame_Scope'Access, + Orig_Info.Subprg_Frame_Scope'Access); + when others => + null; + end case; + end if; + + for I in Fields'Range loop + F := Fields (I); + case Get_Field_Type (F) is + when Type_Iir => + case Get_Field_Attribute (F) is + when Attr_None => + Instantiate_Iir_Info (Get_Iir (N, F)); + when Attr_Ref => + null; + when Attr_Maybe_Ref => + if not Get_Is_Ref (N) then + Instantiate_Iir_Info (Get_Iir (N, F)); + end if; + when Attr_Chain => + Instantiate_Iir_Chain_Info (Get_Iir (N, F)); + when Attr_Chain_Next => + null; + when Attr_Of_Ref => + raise Internal_Error; + end case; + when Type_Iir_List => + case Get_Field_Attribute (F) is + when Attr_None => + Instantiate_Iir_List_Info (Get_Iir_List (N, F)); + when Attr_Ref + | Attr_Of_Ref => + null; + when others => + raise Internal_Error; + end case; + when Type_PSL_NFA + | Type_PSL_Node => + -- TODO + raise Internal_Error; + when Type_Date_Type + | Type_Date_State_Type + | Type_Time_Stamp_Id => + -- Can this happen ? + raise Internal_Error; + when Type_String_Id + | Type_Source_Ptr + | Type_Base_Type + | Type_Iir_Constraint + | Type_Iir_Mode + | Type_Iir_Index32 + | Type_Iir_Int64 + | Type_Boolean + | Type_Iir_Staticness + | Type_Iir_All_Sensitized + | Type_Iir_Signal_Kind + | Type_Tri_State_Type + | Type_Iir_Pure_State + | Type_Iir_Delay_Mechanism + | Type_Iir_Lexical_Layout_Type + | Type_Iir_Predefined_Functions + | Type_Iir_Direction + | Type_Location_Type + | Type_Iir_Int32 + | Type_Int32 + | Type_Iir_Fp64 + | Type_Token_Type + | Type_Name_Id => + null; + end case; + end loop; + + if Info /= null then + case Info.Kind is + when Kind_Subprg => + Pop_Instantiate_Var_Scope + (Info.Subprg_Frame_Scope'Access); + when others => + null; + end case; + end if; + end; + end Instantiate_Iir_Info; + + procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir) + is + Inter : Iir; + Orig : Iir; + Orig_Info : Ortho_Info_Acc; + Info : Ortho_Info_Acc; + begin + Inter := Chain; + while Inter /= Null_Iir loop + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration => + Orig := Sem_Inst.Get_Origin (Inter); + Orig_Info := Get_Info (Orig); + + Info := Add_Info (Inter, Orig_Info.Kind); + Copy_Info (Info, Orig_Info); + + when Iir_Kind_Interface_Package_Declaration => + null; + + when others => + raise Internal_Error; + end case; + + Inter := Get_Chain (Inter); + end loop; + end Instantiate_Iir_Generic_Chain_Info; + + -- Add info for an interface_package_declaration or a + -- package_instantiation_declaration + procedure Instantiate_Info_Package (Inst : Iir) + is + Spec : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Inst, Kind_Package_Instance); + + -- Create the info instances. + Push_Instantiate_Var_Scope + (Info.Package_Instance_Spec_Scope'Access, + Pkg_Info.Package_Spec_Scope'Access); + Push_Instantiate_Var_Scope + (Info.Package_Instance_Body_Scope'Access, + Pkg_Info.Package_Body_Scope'Access); + Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst)); + Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst)); + Pop_Instantiate_Var_Scope + (Info.Package_Instance_Body_Scope'Access); + Pop_Instantiate_Var_Scope + (Info.Package_Instance_Spec_Scope'Access); + end Instantiate_Info_Package; + + procedure Translate_Package_Instantiation_Declaration (Inst : Iir) + is + Spec : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); + Info : Ortho_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + begin + Instantiate_Info_Package (Inst); + Info := Get_Info (Inst); + + -- FIXME: if the instantiation occurs within a package declaration, + -- the variable must be declared extern (and public in the body). + Info.Package_Instance_Body_Var := Create_Var + (Create_Var_Identifier (Inst), + Get_Scope_Type (Pkg_Info.Package_Body_Scope)); + + -- FIXME: this is correct only for global instantiation, and only if + -- there is only one. + Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope, + Pkg_Info.Package_Spec_Field, + Info.Package_Instance_Body_Scope'Access); + + -- Declare elaboration procedure + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB"), Global_Storage); + -- Chap2.Add_Subprg_Instance_Interfaces + -- (Interface_List, Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Instance_Elab_Subprg); + + if Global_Storage /= O_Storage_Public then + return; + end if; + + -- Elaborator: + Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg); + -- Chap2.Start_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + + Elab_Dependence (Get_Design_Unit (Inst)); + + Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope, + Pkg_Info.Package_Spec_Field, + Pkg_Info.Package_Body_Scope'Access); + Chap5.Elab_Generic_Map_Aspect (Inst); + Clear_Scope (Pkg_Info.Package_Spec_Scope); + Clear_Scope (Pkg_Info.Package_Body_Scope); + + -- Call the elaborator of the generic. The generic must be + -- temporary associated with the instance variable. + Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg); + Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Add_Subprg_Instance_Assoc + (Constr, Pkg_Info.Package_Elab_Body_Instance); + Clear_Scope (Pkg_Info.Package_Body_Scope); + New_Procedure_Call (Constr); + + -- Chap2.Finish_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Body; + end Translate_Package_Instantiation_Declaration; + + procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration) + is + Info : Ortho_Info_Acc; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + begin + -- Std.Standard is pre-elaborated. + if Pkg = Standard_Package then + return; + end if; + + -- Nothing to do for uninstantiated package. + if Is_Uninstantiated_Package (Pkg) then + return; + end if; + + -- Call the package elaborator only if not already elaborated. + Info := Get_Info (Pkg); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, + New_Value (Get_Var (Info.Package_Elab_Var)))); + -- Elaborates only non-elaborated packages. + Start_Association (Constr, Info.Package_Elab_Body_Subprg); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + end Elab_Dependence_Package; + + procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) + is + Info : constant Ortho_Info_Acc := Get_Info (Pkg); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Package_Instance_Elab_Subprg); + New_Procedure_Call (Constr); + end Elab_Dependence_Package_Instantiation; + + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) + is + Depend_List: Iir_Design_Unit_List; + Design: Iir; + Library_Unit: Iir; + begin + Depend_List := Get_Dependence_List (Design_Unit); + + for I in Natural loop + Design := Get_Nth_Element (Depend_List, I); + exit when Design = Null_Iir; + if Get_Kind (Design) = Iir_Kind_Design_Unit then + Library_Unit := Get_Library_Unit (Design); + case Get_Kind (Library_Unit) is + when Iir_Kind_Package_Declaration => + Elab_Dependence_Package (Library_Unit); + when Iir_Kind_Package_Instantiation_Declaration => + Elab_Dependence_Package_Instantiation (Library_Unit); + when Iir_Kind_Entity_Declaration => + -- FIXME: architecture already elaborates its entity. + null; + when Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_Package_Body => + -- A package instantiation depends on the body. + null; + when others => + Error_Kind ("elab_dependence", Library_Unit); + end case; + end if; + end loop; + end Elab_Dependence; + + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode) is + begin + Predeclare_Scope_Type (Scope, Create_Identifier ("INSTTYPE")); + Declare_Scope_Acc + (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type); + end Declare_Inst_Type_And_Ptr; + + procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack) is + begin + Prev := Current_Subprg_Instance; + Current_Subprg_Instance := Null_Subprg_Instance_Stack; + end Clear_Subprg_Instance; + + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + Prev : out Subprg_Instance_Stack) + is + begin + Prev := Current_Subprg_Instance; + Current_Subprg_Instance := (Scope => Scope, + Ptr_Type => Ptr_Type, + Ident => Ident); + end Push_Subprg_Instance; + + function Has_Current_Subprg_Instance return Boolean is + begin + return Current_Subprg_Instance.Ptr_Type /= O_Tnode_Null; + end Has_Current_Subprg_Instance; + + procedure Pop_Subprg_Instance (Ident : O_Ident; + Prev : Subprg_Instance_Stack) + is + begin + if Is_Equal (Current_Subprg_Instance.Ident, Ident) then + Current_Subprg_Instance := Prev; + else + -- POP does not match with a push. + raise Internal_Error; + end if; + end Pop_Subprg_Instance; + + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type) + is + begin + if Has_Current_Subprg_Instance then + Vars.Scope := Current_Subprg_Instance.Scope; + Vars.Inter_Type := Current_Subprg_Instance.Ptr_Type; + New_Interface_Decl + (Interfaces, Vars.Inter, + Current_Subprg_Instance.Ident, + Current_Subprg_Instance.Ptr_Type); + else + Vars := Null_Subprg_Instance; + end if; + end Add_Subprg_Instance_Interfaces; + + procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is + begin + if Has_Current_Subprg_Instance then + Field := Add_Instance_Factory_Field + (Current_Subprg_Instance.Ident, + Current_Subprg_Instance.Ptr_Type); + else + Field := O_Fnode_Null; + end if; + end Add_Subprg_Instance_Field; + + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean is + begin + return Vars.Inter /= O_Dnode_Null; + end Has_Subprg_Instance; + + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode is + begin + pragma Assert (Has_Subprg_Instance (Vars)); + return New_Address (Get_Instance_Ref (Vars.Scope.all), + Vars.Inter_Type); + end Get_Subprg_Instance; + + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + New_Association (Assocs, Get_Subprg_Instance (Vars)); + end if; + end Add_Subprg_Instance_Assoc; + + procedure Set_Subprg_Instance_Field + (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type) + is + begin + if Has_Subprg_Instance (Vars) then + New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field), + New_Obj_Value (Vars.Inter)); + end if; + end Set_Subprg_Instance_Field; + + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + Set_Scope_Via_Param_Ptr (Vars.Scope.all, Vars.Inter); + end if; + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + Clear_Scope (Vars.Scope.all); + end if; + end Finish_Subprg_Instance_Use; + + procedure Start_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode) is + begin + if Field /= O_Fnode_Null then + Set_Scope_Via_Field_Ptr (Prev.Scope.all, Field, + Current_Subprg_Instance.Scope); + end if; + end Start_Prev_Subprg_Instance_Use_Via_Field; + + procedure Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode) is + begin + if Field /= O_Fnode_Null then + Clear_Scope (Prev.Scope.all); + end if; + end Finish_Prev_Subprg_Instance_Use_Via_Field; + + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir) + is + begin + Add_Subprg_Instance_Interfaces + (Interfaces, Get_Info (Subprg).Subprg_Instance); + end Create_Subprg_Instance; + + procedure Start_Subprg_Instance_Use (Subprg : Iir) is + begin + Start_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Subprg : Iir) is + begin + Finish_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Finish_Subprg_Instance_Use; + + function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) + return Subprg_Instance_Type is + begin + return Subprg_Instance_Type' + (Inter => Inst.Inter, + Inter_Type => Inst.Inter_Type, + Scope => Instantiated_Var_Scope (Inst.Scope)); + end Instantiate_Subprg_Instance; + end Chap2; + + package body Chap3 is + function Create_Static_Type_Definition_Type_Range (Def : Iir) + return O_Cnode; + procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode); + + -- For scalar subtypes: creates info from the base type. + procedure Create_Subtype_Info_From_Type (Def : Iir; + Subtype_Info : Type_Info_Acc; + Base_Info : Type_Info_Acc); + + -- Finish a type definition: declare the type, define and declare a + -- pointer to the type. + procedure Finish_Type_Definition + (Info : Type_Info_Acc; Completion : Boolean := False) + is + begin + -- Declare the type. + if not Completion then + New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); + end if; + + -- Create an access to the type and declare it. + Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Info.Ortho_Ptr_Type (Mode_Value)); + + -- Signal type. + if Info.Type_Mode in Type_Mode_Scalar then + Info.Ortho_Type (Mode_Signal) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + end if; + if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then + New_Type_Decl (Create_Identifier ("SIG"), + Info.Ortho_Type (Mode_Signal)); + end if; + + -- Signal pointer type. + if Info.Type_Mode in Type_Mode_Composite + and then Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null + then + Info.Ortho_Ptr_Type (Mode_Signal) := + New_Access_Type (Info.Ortho_Type (Mode_Signal)); + New_Type_Decl (Create_Identifier ("SIGPTR"), + Info.Ortho_Ptr_Type (Mode_Signal)); + else + Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; + end if; + end Finish_Type_Definition; + + procedure Create_Size_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + begin + Info.C := new Complex_Type_Arr_Info; + Info.C (Mode_Value).Size_Var := Create_Var + (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); + if Get_Has_Signal_Flag (Def) then + Info.C (Mode_Signal).Size_Var := Create_Var + (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); + end if; + end Create_Size_Var; + + -- A builder set internal fields of object pointed by BASE_PTR, using + -- memory from BASE_PTR and returns a pointer to the next memory byte + -- to be used. + procedure Create_Builder_Subprogram_Decl (Info : Type_Info_Acc; + Name : Name_Id; + Kind : Object_Kind_Type) + is + Interface_List : O_Inter_List; + Ident : O_Ident; + Ptype : O_Tnode; + begin + case Kind is + when Mode_Value => + Ident := Create_Identifier (Name, "_BUILDER"); + when Mode_Signal => + Ident := Create_Identifier (Name, "_SIGBUILDER"); + end case; + -- FIXME: return the same type as its first parameter ??? + Start_Function_Decl + (Interface_List, Ident, Global_Storage, Ghdl_Index_Type); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.C (Kind).Builder_Instance); + case Info.Type_Mode is + when Type_Mode_Fat_Array => + Ptype := Info.T.Base_Ptr_Type (Kind); + when Type_Mode_Record => + Ptype := Info.Ortho_Ptr_Type (Kind); + when others => + raise Internal_Error; + end case; + New_Interface_Decl + (Interface_List, Info.C (Kind).Builder_Base_Param, + Get_Identifier ("base_ptr"), Ptype); + -- Add parameter for array bounds. + if Info.Type_Mode = Type_Mode_Fat_Array then + New_Interface_Decl + (Interface_List, Info.C (Kind).Builder_Bound_Param, + Get_Identifier ("bound"), Info.T.Bounds_Ptr_Type); + end if; + Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func); + end Create_Builder_Subprogram_Decl; + + function Gen_Call_Type_Builder (Var_Ptr : O_Dnode; + Var_Type : Iir; + Kind : Object_Kind_Type) + return O_Enode + is + Tinfo : constant Type_Info_Acc := Get_Info (Var_Type); + Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type)); + Assoc : O_Assoc_List; + begin + -- Build the field + Start_Association (Assoc, Binfo.C (Kind).Builder_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assoc, Binfo.C (Kind).Builder_Instance); + + case Tinfo.Type_Mode is + when Type_Mode_Record + | Type_Mode_Array => + New_Association (Assoc, New_Obj_Value (Var_Ptr)); + when Type_Mode_Fat_Array => + -- Note: a fat array can only be at the top of a complex type; + -- the bounds must have been set. + New_Association + (Assoc, New_Value_Selected_Acc_Value + (New_Obj (Var_Ptr), Tinfo.T.Base_Field (Kind))); + when others => + raise Internal_Error; + end case; + + if Tinfo.Type_Mode in Type_Mode_Arrays then + declare + Arr : Mnode; + begin + case Type_Mode_Arrays (Tinfo.Type_Mode) is + when Type_Mode_Array => + Arr := T2M (Var_Type, Kind); + when Type_Mode_Fat_Array => + Arr := Dp2M (Var_Ptr, Tinfo, Kind); + end case; + New_Association + (Assoc, M2Addr (Chap3.Get_Array_Bounds (Arr))); + end; + end if; + + return New_Function_Call (Assoc); + end Gen_Call_Type_Builder; + + procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) + is + Mem : O_Dnode; + V : Mnode; + begin + Open_Temp; + V := Stabilize (Var); + Mem := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Mem), + Gen_Call_Type_Builder (M2Dp (V), Var_Type, Get_Object_Kind (Var))); + Close_Temp; + end Gen_Call_Type_Builder; + + ------------------ + -- Enumeration -- + ------------------ + + function Translate_Enumeration_Literal (Lit : Iir_Enumeration_Literal) + return O_Ident + is + El_Str : String (1 .. 4); + Id : Name_Id; + N : Integer; + C : Character; + begin + Id := Get_Identifier (Lit); + if Name_Table.Is_Character (Id) then + C := Name_Table.Get_Character (Id); + El_Str (1) := 'C'; + case C is + when 'A' .. 'Z' + | 'a' .. 'z' + | '0' .. '9' => + El_Str (2) := '_'; + El_Str (3) := C; + when others => + N := Character'Pos (Name_Table.Get_Character (Id)); + El_Str (2) := N2hex (N / 16); + El_Str (3) := N2hex (N mod 16); + end case; + return Get_Identifier (El_Str (1 .. 3)); + else + return Create_Identifier_Without_Prefix (Lit); + end if; + end Translate_Enumeration_Literal; + + procedure Translate_Enumeration_Type + (Def : Iir_Enumeration_Type_Definition) + is + El_List : Iir_List; + El : Iir_Enumeration_Literal; + Constr : O_Enum_List; + Lit_Name : O_Ident; + Val : O_Cnode; + Info : Type_Info_Acc; + Nbr : Natural; + Size : Natural; + begin + El_List := Get_Enumeration_Literal_List (Def); + Nbr := Get_Nbr_Elements (El_List); + if Nbr <= 256 then + Size := 8; + else + Size := 32; + end if; + Start_Enum_Type (Constr, Size); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + + Lit_Name := Translate_Enumeration_Literal (El); + New_Enum_Literal (Constr, Lit_Name, Val); + Set_Ortho_Expr (El, Val); + end loop; + Info := Get_Info (Def); + Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value)); + if Nbr <= 256 then + Info.Type_Mode := Type_Mode_E8; + else + Info.Type_Mode := Type_Mode_E32; + end if; + -- Enumerations are always in their range. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + Finish_Type_Definition (Info); + end Translate_Enumeration_Type; + + procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition) + is + Info : Type_Info_Acc; + El_List : Iir_List; + True_Lit, False_Lit : Iir_Enumeration_Literal; + False_Node, True_Node : O_Cnode; + begin + Info := Get_Info (Def); + El_List := Get_Enumeration_Literal_List (Def); + if Get_Nbr_Elements (El_List) /= 2 then + raise Internal_Error; + end if; + False_Lit := Get_Nth_Element (El_List, 0); + True_Lit := Get_Nth_Element (El_List, 1); + New_Boolean_Type + (Info.Ortho_Type (Mode_Value), + Translate_Enumeration_Literal (False_Lit), False_Node, + Translate_Enumeration_Literal (True_Lit), True_Node); + Info.Type_Mode := Type_Mode_B1; + Set_Ortho_Expr (False_Lit, False_Node); + Set_Ortho_Expr (True_Lit, True_Node); + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + Finish_Type_Definition (Info); + end Translate_Bool_Type; + + --------------- + -- Integer -- + --------------- + + -- Return the number of bits (32 or 64) required to represent the + -- (integer or physical) type definition DEF. + type Type_Precision is (Precision_32, Precision_64); + function Get_Type_Precision (Def : Iir) return Type_Precision + is + St : Iir; + L, H : Iir; + Lv, Hv : Iir_Int64; + begin + St := Get_Subtype_Definition (Get_Type_Declarator (Def)); + Get_Low_High_Limit (Get_Range_Constraint (St), L, H); + Lv := Get_Value (L); + Hv := Get_Value (H); + if Lv >= -(2 ** 31) and then Hv <= (2 ** 31 - 1) then + return Precision_32; + else + if Flag_Only_32b then + Error_Msg_Sem + ("range of " & Disp_Node (Get_Type_Declarator (St)) + & " is too large", St); + return Precision_32; + end if; + return Precision_64; + end if; + end Get_Type_Precision; + + procedure Translate_Integer_Type + (Def : Iir_Integer_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + case Get_Type_Precision (Def) is + when Precision_32 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); + Info.Type_Mode := Type_Mode_I32; + when Precision_64 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); + Info.Type_Mode := Type_Mode_I64; + end case; + -- Integers are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Integer_Type; + + ---------------------- + -- Floating types -- + ---------------------- + + procedure Translate_Floating_Type (Def : Iir_Floating_Type_Definition) + is + Info : Type_Info_Acc; + begin + -- FIXME: should check precision + Info := Get_Info (Def); + Info.Type_Mode := Type_Mode_F64; + Info.Ortho_Type (Mode_Value) := New_Float_Type; + -- Reals are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Floating_Type; + + ---------------- + -- Physical -- + ---------------- + + procedure Translate_Physical_Type (Def : Iir_Physical_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + case Get_Type_Precision (Def) is + when Precision_32 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); + Info.Type_Mode := Type_Mode_P32; + when Precision_64 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); + Info.Type_Mode := Type_Mode_P64; + end case; + -- Phyiscals are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Physical_Type; + + procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition) + is + Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value); + Unit : Iir; + Info : Object_Info_Acc; + begin + Unit := Get_Unit_Chain (Def); + while Unit /= Null_Iir loop + Info := Add_Info (Unit, Kind_Object); + Info.Object_Var := + Create_Var (Create_Var_Identifier (Unit), Phy_Type); + Unit := Get_Chain (Unit); + end loop; + end Translate_Physical_Units; + + ------------ + -- File -- + ------------ + + procedure Translate_File_Type (Def : Iir_File_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type; + Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type; + Info.Type_Mode := Type_Mode_File; + end Translate_File_Type; + + function Get_File_Signature_Length (Def : Iir) return Natural is + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_Definition => + return 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + return 2 + + Get_File_Signature_Length (Get_Element_Subtype (Def)); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El : Iir; + Res : Natural; + List : Iir_List; + begin + Res := 2; + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Res := Res + Get_File_Signature_Length (Get_Type (El)); + end loop; + return Res; + end; + when others => + Error_Kind ("get_file_signature_length", Def); + end case; + end Get_File_Signature_Length; + + procedure Get_File_Signature (Def : Iir; + Res : in out String; + Off : in out Natural) + is + Scalar_Map : constant array (Type_Mode_Scalar) of Character + := "beEiIpPF"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_Definition => + Res (Off) := Scalar_Map (Get_Info (Def).Type_Mode); + Off := Off + 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + Res (Off) := '['; + Off := Off + 1; + Get_File_Signature (Get_Element_Subtype (Def), Res, Off); + Res (Off) := ']'; + Off := Off + 1; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El : Iir; + List : Iir_List; + begin + Res (Off) := '<'; + Off := Off + 1; + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Get_File_Signature (Get_Type (El), Res, Off); + end loop; + Res (Off) := '>'; + Off := Off + 1; + end; + when others => + Error_Kind ("get_file_signature", Def); + end case; + end Get_File_Signature; + + procedure Create_File_Type_Var (Def : Iir_File_Type_Definition) + is + Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); + Info : Type_Info_Acc; + begin + if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition then + return; + end if; + declare + Len : constant Natural := Get_File_Signature_Length (Type_Name); + Sig : String (1 .. Len + 2); + Off : Natural := Sig'First; + begin + Get_File_Signature (Type_Name, Sig, Off); + Sig (Len + 1) := '.'; + Sig (Len + 2) := Character'Val (10); + Info := Get_Info (Def); + Info.T.File_Signature := Create_String + (Sig, Create_Identifier ("FILESIG"), Global_Storage); + end; + end Create_File_Type_Var; + + ------------- + -- Array -- + ------------- + + function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is + begin + if Get_Has_Signal_Flag (Def) then + return Mode_Signal; + else + return Mode_Value; + end if; + end Type_To_Last_Object_Kind; + + procedure Create_Array_Fat_Pointer + (Info : Type_Info_Acc; Kind : Object_Kind_Type) + is + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field + (Constr, Info.T.Base_Field (Kind), Get_Identifier ("BASE"), + Info.T.Base_Ptr_Type (Kind)); + New_Record_Field + (Constr, Info.T.Bounds_Field (Kind), Get_Identifier ("BOUNDS"), + Info.T.Bounds_Ptr_Type); + Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); + end Create_Array_Fat_Pointer; + + procedure Translate_Incomplete_Array_Type + (Def : Iir_Array_Type_Definition) + is + Arr_Info : Incomplete_Type_Info_Acc; + Info : Type_Info_Acc; + begin + Arr_Info := Get_Info (Def); + if Arr_Info.Incomplete_Array /= null then + -- This (incomplete) array type was already translated. + -- This is the case for a second access type definition to this + -- still incomplete array type. + return; + end if; + Info := new Ortho_Info_Type (Kind_Type); + Info.Type_Mode := Type_Mode_Fat_Array; + Info.Type_Incomplete := True; + Arr_Info.Incomplete_Array := Info; + + Info.T := Ortho_Info_Type_Array_Init; + Info.T.Bounds_Type := O_Tnode_Null; + + Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUNDP"), + Info.T.Bounds_Ptr_Type); + + Info.T.Base_Ptr_Type (Mode_Value) := New_Access_Type (O_Tnode_Null); + New_Type_Decl (Create_Identifier ("BASEP"), + Info.T.Base_Ptr_Type (Mode_Value)); + + Create_Array_Fat_Pointer (Info, Mode_Value); + + New_Type_Decl + (Create_Identifier, Info.Ortho_Type (Mode_Value)); + end Translate_Incomplete_Array_Type; + + -- Declare the bounds types for DEF. + procedure Translate_Array_Type_Bounds + (Def : Iir_Array_Type_Definition; + Info : Type_Info_Acc; + Complete : Boolean) + is + Indexes_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Def); + Constr : O_Element_List; + Dim : String (1 .. 8); + N : Natural; + P : Natural; + Index : Iir; + Index_Info : Index_Info_Acc; + Index_Type_Mark : Iir; + begin + Start_Record_Type (Constr); + for I in Natural loop + Index_Type_Mark := Get_Nth_Element (Indexes_List, I); + exit when Index_Type_Mark = Null_Iir; + Index := Get_Index_Type (Index_Type_Mark); + + -- Index comes from a type mark. + pragma Assert (not Is_Anonymous_Type_Definition (Index)); + + Index_Info := Add_Info (Index_Type_Mark, Kind_Index); + + -- Build the name + N := I + 1; + P := Dim'Last; + loop + Dim (P) := Character'Val (Character'Pos ('0') + N mod 10); + P := P - 1; + N := N / 10; + exit when N = 0; + end loop; + P := P - 3; + Dim (P .. P + 3) := "dim_"; + + New_Record_Field (Constr, Index_Info.Index_Field, + Get_Identifier (Dim (P .. Dim'Last)), + Get_Info (Get_Base_Type (Index)).T.Range_Type); + end loop; + Finish_Record_Type (Constr, Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUND"), + Info.T.Bounds_Type); + if Complete then + Finish_Access_Type (Info.T.Bounds_Ptr_Type, Info.T.Bounds_Type); + else + Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUNDP"), + Info.T.Bounds_Ptr_Type); + end if; + end Translate_Array_Type_Bounds; + + procedure Translate_Array_Type_Base + (Def : Iir_Array_Type_Definition; + Info : Type_Info_Acc; + Complete : Boolean) + is + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Id, Idptr : O_Ident; + begin + El_Type := Get_Element_Subtype (Def); + Translate_Type_Definition (El_Type, True); + El_Tinfo := Get_Info (El_Type); + + if Is_Complex_Type (El_Tinfo) then + if El_Tinfo.Type_Mode = Type_Mode_Array then + Info.T.Base_Type := El_Tinfo.T.Base_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.T.Base_Ptr_Type; + else + Info.T.Base_Type := El_Tinfo.Ortho_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type; + end if; + else + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + case Kind is + when Mode_Value => + -- For the values. + Id := Create_Identifier ("BASE"); + if not Complete then + Idptr := Create_Identifier ("BASEP"); + else + Idptr := O_Ident_Nul; + end if; + when Mode_Signal => + -- For the signals + Id := Create_Identifier ("SIGBASE"); + Idptr := Create_Identifier ("SIGBASEP"); + end case; + Info.T.Base_Type (Kind) := + New_Array_Type (El_Tinfo.Ortho_Type (Kind), + Ghdl_Index_Type); + New_Type_Decl (Id, Info.T.Base_Type (Kind)); + if Is_Equal (Idptr, O_Ident_Nul) then + Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), + Info.T.Base_Type (Kind)); + else + Info.T.Base_Ptr_Type (Kind) := + New_Access_Type (Info.T.Base_Type (Kind)); + New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); + end if; + end loop; + end if; + end Translate_Array_Type_Base; + + -- For unidimensional arrays: create a constant bounds whose length + -- is 1, for concatenation with element. + procedure Translate_Static_Unidimensional_Array_Length_One + (Def : Iir_Array_Type_Definition) + is + Indexes : constant Iir_List := Get_Index_Subtype_List (Def); + Index_Type : Iir; + Index_Base_Type : Iir; + Constr : O_Record_Aggr_List; + Constr1 : O_Record_Aggr_List; + Arr_Info : Type_Info_Acc; + Tinfo : Type_Info_Acc; + Irange : Iir; + Res1 : O_Cnode; + Res : O_Cnode; + begin + if Get_Nbr_Elements (Indexes) /= 1 then + -- Not a one-dimensional array. + return; + end if; + Index_Type := Get_Index_Type (Indexes, 0); + Arr_Info := Get_Info (Def); + if Get_Type_Staticness (Index_Type) = Locally then + if Global_Storage /= O_Storage_External then + Index_Base_Type := Get_Base_Type (Index_Type); + Tinfo := Get_Info (Index_Base_Type); + Irange := Get_Range_Constraint (Index_Type); + Start_Record_Aggr (Constr, Arr_Info.T.Bounds_Type); + Start_Record_Aggr (Constr1, Tinfo.T.Range_Type); + New_Record_Aggr_El + (Constr1, + Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); + New_Record_Aggr_El + (Constr1, + Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); + New_Record_Aggr_El + (Constr1, Chap7.Translate_Static_Range_Dir (Irange)); + New_Record_Aggr_El + (Constr1, Ghdl_Index_1); + Finish_Record_Aggr (Constr1, Res1); + New_Record_Aggr_El (Constr, Res1); + Finish_Record_Aggr (Constr, Res); + else + Res := O_Cnode_Null; + end if; + Arr_Info.T.Array_1bound := Create_Global_Const + (Create_Identifier ("BR1"), + Arr_Info.T.Bounds_Type, Global_Storage, Res); + else + Arr_Info.T.Array_1bound := Create_Var + (Create_Var_Identifier ("BR1"), + Arr_Info.T.Bounds_Type, Global_Storage); + end if; + end Translate_Static_Unidimensional_Array_Length_One; + + procedure Translate_Dynamic_Unidimensional_Array_Length_One + (Def : Iir_Array_Type_Definition) + is + Indexes : constant Iir_List := Get_Index_Subtype_List (Def); + Index_Type : Iir; + Arr_Info : Type_Info_Acc; + Bound1, Rng : Mnode; + begin + if Get_Nbr_Elements (Indexes) /= 1 then + return; + end if; + Index_Type := Get_Index_Type (Indexes, 0); + if Get_Type_Staticness (Index_Type) = Locally then + return; + end if; + Arr_Info := Get_Info (Def); + Open_Temp; + Bound1 := Varv2M (Arr_Info.T.Array_1bound, Arr_Info, Mode_Value, + Arr_Info.T.Bounds_Type, Arr_Info.T.Bounds_Ptr_Type); + Bound1 := Bounds_To_Range (Bound1, Def, 1); + Stabilize (Bound1); + Rng := Type_To_Range (Index_Type); + Stabilize (Rng); + New_Assign_Stmt (M2Lv (Range_To_Dir (Bound1)), + M2E (Range_To_Dir (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Left (Bound1)), + M2E (Range_To_Left (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Bound1)), + M2E (Range_To_Left (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Length (Bound1)), + New_Lit (Ghdl_Index_1)); + Close_Temp; + end Translate_Dynamic_Unidimensional_Array_Length_One; + + procedure Translate_Array_Type_Definition + (Def : Iir_Array_Type_Definition) + is + Info : constant Type_Info_Acc := Get_Info (Def); + -- If true, INFO was already partially filled, by a previous access + -- type definition to this incomplete array type. + Completion : constant Boolean := Info.Type_Mode = Type_Mode_Fat_Array; + El_Tinfo : Type_Info_Acc; + begin + if not Completion then + Info.Type_Mode := Type_Mode_Fat_Array; + Info.T := Ortho_Info_Type_Array_Init; + end if; + Translate_Array_Type_Base (Def, Info, Completion); + Translate_Array_Type_Bounds (Def, Info, Completion); + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + if not Completion then + Create_Array_Fat_Pointer (Info, Mode_Value); + end if; + if Get_Has_Signal_Flag (Def) then + Create_Array_Fat_Pointer (Info, Mode_Signal); + end if; + Finish_Type_Definition (Info, Completion); + + Translate_Static_Unidimensional_Array_Length_One (Def); + + El_Tinfo := Get_Info (Get_Element_Subtype (Def)); + if Is_Complex_Type (El_Tinfo) then + -- This is a complex type. + Info.C := new Complex_Type_Arr_Info; + -- No size variable for unconstrained array type. + for Mode in Object_Kind_Type loop + Info.C (Mode).Size_Var := Null_Var; + Info.C (Mode).Builder_Need_Func := + El_Tinfo.C (Mode).Builder_Need_Func; + end loop; + end if; + Info.Type_Incomplete := False; + end Translate_Array_Type_Definition; + + -- Get the length of DEF, ie the number of elements. + -- If the length is not statically defined, returns -1. + function Get_Array_Subtype_Length (Def : Iir_Array_Subtype_Definition) + return Iir_Int64 + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Index : Iir; + Len : Iir_Int64; + begin + -- Check if the bounds of the array are locally static. + Len := 1; + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + + if Get_Type_Staticness (Index) /= Locally then + return -1; + end if; + Len := Len * Eval_Discrete_Type_Length (Index); + end loop; + return Len; + end Get_Array_Subtype_Length; + + procedure Translate_Array_Subtype_Definition + (Def : Iir_Array_Subtype_Definition) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Type : constant Iir := Get_Base_Type (Def); + Binfo : constant Type_Info_Acc := Get_Info (Base_Type); + + Len : Iir_Int64; + + Id : O_Ident; + begin + -- Note: info of indexes subtype are not created! + + Len := Get_Array_Subtype_Length (Def); + Info.Type_Mode := Type_Mode_Array; + Info.Type_Locally_Constrained := (Len >= 0); + if Is_Complex_Type (Binfo) + or else not Info.Type_Locally_Constrained + then + -- This is a complex type as the size is not known at compile + -- time. + Info.Ortho_Type := Binfo.T.Base_Ptr_Type; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + + Create_Size_Var (Def); + + for Mode in Object_Kind_Type loop + Info.C (Mode).Builder_Need_Func := + Is_Complex_Type (Binfo) + and then Binfo.C (Mode).Builder_Need_Func; + end loop; + else + -- Length is known. Create a constrained array. + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + case I is + when Mode_Value => + Id := Create_Identifier; + when Mode_Signal => + Id := Create_Identifier ("SIG"); + end case; + Info.Ortho_Type (I) := New_Constrained_Array_Type + (Binfo.T.Base_Type (I), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + New_Type_Decl (Id, Info.Ortho_Type (I)); + end loop; + end if; + end Translate_Array_Subtype_Definition; + + procedure Translate_Array_Subtype_Element_Subtype + (Def : Iir_Array_Subtype_Definition) + is + El_Type : constant Iir := Get_Element_Subtype (Def); + Type_Mark : constant Iir := Get_Denoted_Type_Mark (Def); + Tm_El_Type : Iir; + begin + if Type_Mark = Null_Iir then + -- Array subtype for constained array definition. Same element + -- subtype as the base type. + return; + end if; + + Tm_El_Type := Get_Element_Subtype (Type_Mark); + if El_Type = Tm_El_Type then + -- Same element subtype as the type mark. + return; + end if; + + case Get_Kind (El_Type) is + when Iir_Kinds_Scalar_Subtype_Definition => + declare + El_Info : Ortho_Info_Acc; + begin + El_Info := Add_Info (El_Type, Kind_Type); + Create_Subtype_Info_From_Type + (El_Type, El_Info, Get_Info (Tm_El_Type)); + end; + when others => + Error_Kind ("translate_array_subtype_element_subtype", El_Type); + end case; + end Translate_Array_Subtype_Element_Subtype; + + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Baseinfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def)); + Index : Iir; + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Start_Record_Aggr (List, Baseinfo.T.Bounds_Type); + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + New_Record_Aggr_El + (List, Create_Static_Type_Definition_Type_Range (Index)); + end loop; + Finish_Record_Aggr (List, Res); + return Res; + end Create_Static_Array_Subtype_Bounds; + + procedure Create_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition; Target : O_Lnode) + is + Base_Type : constant Iir := Get_Base_Type (Def); + Baseinfo : constant Type_Info_Acc := Get_Info (Base_Type); + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Indexes_Def_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Base_Type); + Index : Iir; + Targ : Mnode; + begin + Targ := Lv2M (Target, True, + Baseinfo.T.Bounds_Type, + Baseinfo.T.Bounds_Ptr_Type, + null, Mode_Value); + Open_Temp; + if Get_Nbr_Elements (Indexes_List) > 1 then + Targ := Stabilize (Targ); + end if; + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + declare + Index_Type : constant Iir := Get_Base_Type (Index); + Index_Info : constant Type_Info_Acc := Get_Info (Index_Type); + Base_Index_Info : constant Index_Info_Acc := + Get_Info (Get_Nth_Element (Indexes_Def_List, I)); + D : O_Dnode; + begin + Open_Temp; + D := Create_Temp_Ptr + (Index_Info.T.Range_Ptr_Type, + New_Selected_Element (M2Lv (Targ), + Base_Index_Info.Index_Field)); + Chap7.Translate_Discrete_Range_Ptr (D, Index); + Close_Temp; + end; + end loop; + Close_Temp; + end Create_Array_Subtype_Bounds; + + -- Get staticness of the array bounds. + function Get_Array_Bounds_Staticness (Def : Iir) return Iir_Staticness + is + List : constant Iir_List := Get_Index_Subtype_List (Def); + Idx_Type : Iir; + begin + for I in Natural loop + Idx_Type := Get_Index_Type (List, I); + exit when Idx_Type = Null_Iir; + if Get_Type_Staticness (Idx_Type) /= Locally then + return Globally; + end if; + end loop; + return Locally; + end Get_Array_Bounds_Staticness; + + -- Create a variable containing the bounds for array subtype DEF. + procedure Create_Array_Subtype_Bounds_Var + (Def : Iir; Elab_Now : Boolean) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Info : Type_Info_Acc; + Val : O_Cnode; + begin + if Info.T.Array_Bounds /= Null_Var then + return; + end if; + Base_Info := Get_Info (Get_Base_Type (Def)); + case Get_Array_Bounds_Staticness (Def) is + when None + | Globally => + Info.T.Static_Bounds := False; + Info.T.Array_Bounds := Create_Var + (Create_Var_Identifier ("STB"), Base_Info.T.Bounds_Type); + if Elab_Now then + Create_Array_Subtype_Bounds + (Def, Get_Var (Info.T.Array_Bounds)); + end if; + when Locally => + Info.T.Static_Bounds := True; + if Global_Storage = O_Storage_External then + -- Do not create the value of the type desc, since it + -- is never dereferenced in a static type desc. + Val := O_Cnode_Null; + else + Val := Create_Static_Array_Subtype_Bounds (Def); + end if; + Info.T.Array_Bounds := Create_Global_Const + (Create_Identifier ("STB"), + Base_Info.T.Bounds_Type, Global_Storage, Val); + + when Unknown => + raise Internal_Error; + end case; + end Create_Array_Subtype_Bounds_Var; + + procedure Create_Array_Type_Builder + (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; + Bound : constant O_Dnode := Info.C (Kind).Builder_Bound_Param; + Var_Off : O_Dnode; + Var_Mem : O_Dnode; + Var_Length : O_Dnode; + El_Type : Iir; + El_Info : Type_Info_Acc; + Label : O_Snode; + begin + Start_Subprogram_Body (Info.C (Kind).Builder_Func); + Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + + -- Compute length of the array. + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local, + Info.T.Base_Ptr_Type (Kind)); + New_Var_Decl (Var_Off, Get_Identifier ("off"), O_Storage_Local, + Ghdl_Index_Type); + + El_Type := Get_Element_Subtype (Def); + El_Info := Get_Info (El_Type); + + New_Assign_Stmt + (New_Obj (Var_Length), + New_Dyadic_Op (ON_Mul_Ov, + New_Value (Get_Var (El_Info.C (Kind).Size_Var)), + Get_Bounds_Length (Dp2M (Bound, Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type), + Def))); + + -- Find the innermost non-array element. + while El_Info.Type_Mode = Type_Mode_Array loop + El_Type := Get_Element_Subtype (El_Type); + El_Info := Get_Info (El_Type); + end loop; + + -- Set each index of the array. + Init_Var (Var_Off); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Off), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + + New_Assign_Stmt + (New_Obj (Var_Mem), + New_Unchecked_Address + (New_Slice (New_Access_Element + (New_Convert_Ov (New_Obj_Value (Base), + Char_Ptr_Type)), + Chararray_Type, + New_Obj_Value (Var_Off)), + Info.T.Base_Ptr_Type (Kind))); + + New_Assign_Stmt + (New_Obj (Var_Off), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Off), + Gen_Call_Type_Builder (Var_Mem, El_Type, Kind))); + Finish_Loop_Stmt (Label); + + New_Return_Stmt (New_Obj_Value (Var_Off)); + + Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Finish_Subprogram_Body; + end Create_Array_Type_Builder; + + -------------- + -- record -- + -------------- + + -- Get the alignment mask for *ortho* type ATYPE. + function Get_Type_Alignmask (Atype : O_Tnode) return O_Enode is + begin + return New_Dyadic_Op + (ON_Sub_Ov, + New_Lit (New_Alignof (Atype, Ghdl_Index_Type)), + New_Lit (Ghdl_Index_1)); + end Get_Type_Alignmask; + + -- Get the alignment mask for type INFO (Mode_Value). + function Get_Type_Alignmask (Info : Type_Info_Acc) return O_Enode is + begin + if Is_Complex_Type (Info) then + if Info.Type_Mode /= Type_Mode_Record then + raise Internal_Error; + end if; + return New_Value (Get_Var (Info.C (Mode_Value).Align_Var)); + else + return Get_Type_Alignmask (Info.Ortho_Type (Mode_Value)); + end if; + end Get_Type_Alignmask; + + -- Align VALUE (of unsigned type) for type ATYPE. + -- The formulae is: (V + (A - 1)) and not (A - 1), where A is the + -- alignment for ATYPE in bytes. + function Realign (Value : O_Enode; Atype : Iir) return O_Enode + is + Tinfo : constant Type_Info_Acc := Get_Info (Atype); + begin + return New_Dyadic_Op + (ON_And, + New_Dyadic_Op (ON_Add_Ov, Value, Get_Type_Alignmask (Tinfo)), + New_Monadic_Op (ON_Not, Get_Type_Alignmask (Tinfo))); + end Realign; + + function Realign (Value : O_Enode; Mask : O_Dnode) return O_Enode is + begin + return New_Dyadic_Op + (ON_And, + New_Dyadic_Op (ON_Add_Ov, Value, New_Obj_Value (Mask)), + New_Monadic_Op (ON_Not, New_Obj_Value (Mask))); + end Realign; + + -- Find the innermost non-array element. + function Get_Innermost_Non_Array_Element (Atype : Iir) return Iir + is + Res : Iir := Atype; + begin + while Get_Kind (Res) in Iir_Kinds_Array_Type_Definition loop + Res := Get_Element_Subtype (Res); + end loop; + return Res; + end Get_Innermost_Non_Array_Element; + + procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) + is + El_List : O_Element_List; + List : Iir_List; + El : Iir_Element_Declaration; + Info : Type_Info_Acc; + Field_Info : Ortho_Info_Acc; + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + El_Tnode : O_Tnode; + + -- True if a size variable will be created since the size of + -- the record is not known at compile-time. + Need_Size : Boolean; + + Mark : Id_Mark_Type; + begin + Info := Get_Info (Def); + Need_Size := False; + List := Get_Elements_Declaration_List (Def); + + -- First, translate the anonymous type of the elements. + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + if Get_Info (El_Type) = null then + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + Translate_Type_Definition (El_Type); + Pop_Identifier_Prefix (Mark); + end if; + if not Need_Size and then Is_Complex_Type (Get_Info (El_Type)) then + Need_Size := True; + end if; + Field_Info := Add_Info (El, Kind_Field); + end loop; + + -- Then create the record type. + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Start_Record_Type (El_List); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Field_Info := Get_Info (El); + El_Tinfo := Get_Info (Get_Type (El)); + if Is_Complex_Type (El_Tinfo) then + -- Always use an offset for a complex type. + El_Tnode := Ghdl_Index_Type; + else + El_Tnode := El_Tinfo.Ortho_Type (Kind); + end if; + + New_Record_Field (El_List, Field_Info.Field_Node (Kind), + Create_Identifier_Without_Prefix (El), + El_Tnode); + end loop; + Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); + end loop; + Info.Type_Mode := Type_Mode_Record; + Finish_Type_Definition (Info); + + if Need_Size then + Create_Size_Var (Def); + Info.C (Mode_Value).Align_Var := Create_Var + (Create_Var_Identifier ("ALIGNMSK"), Ghdl_Index_Type); + Info.C (Mode_Value).Builder_Need_Func := True; + Info.C (Mode_Signal).Builder_Need_Func := True; + end if; + end Translate_Record_Type; + + procedure Create_Record_Type_Builder + (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; + List : Iir_List; + El : Iir_Element_Declaration; + + Off_Var : O_Dnode; + Ptr_Var : O_Dnode; + Off_Val : O_Enode; + El_Type : Iir; + Inner_Type : Iir; + El_Tinfo : Type_Info_Acc; + begin + Start_Subprogram_Body (Info.C (Kind).Builder_Func); + Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + + New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local, + Ghdl_Index_Type); + + -- Reserve memory for the record, ie: + -- OFF = SIZEOF (record). + New_Assign_Stmt + (New_Obj (Off_Var), + New_Lit (New_Sizeof (Info.Ortho_Type (Kind), + Ghdl_Index_Type))); + + -- Set memory for each complex element. + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + El_Tinfo := Get_Info (El_Type); + if Is_Complex_Type (El_Tinfo) then + -- Complex type. + + -- Align on the innermost array element (which should be + -- a record) for Mode_Value. No need to align for signals, + -- as all non-composite elements are accesses. + Inner_Type := Get_Innermost_Non_Array_Element (El_Type); + Off_Val := New_Obj_Value (Off_Var); + if Kind = Mode_Value then + Off_Val := Realign (Off_Val, Inner_Type); + end if; + New_Assign_Stmt (New_Obj (Off_Var), Off_Val); + + -- Set the offset. + New_Assign_Stmt + (New_Selected_Element (New_Acc_Value (New_Obj (Base)), + Get_Info (El).Field_Node (Kind)), + New_Obj_Value (Off_Var)); + + if El_Tinfo.C (Kind).Builder_Need_Func then + -- This type needs a builder, call it. + Start_Declare_Stmt; + New_Var_Decl + (Ptr_Var, Get_Identifier ("var_ptr"), + O_Storage_Local, El_Tinfo.Ortho_Ptr_Type (Kind)); + + New_Assign_Stmt + (New_Obj (Ptr_Var), + M2E (Chap6.Translate_Selected_Element + (Dp2M (Base, Info, Kind), El))); + + New_Assign_Stmt + (New_Obj (Off_Var), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Off_Var), + Gen_Call_Type_Builder + (Ptr_Var, El_Type, Kind))); + + Finish_Declare_Stmt; + else + -- Allocate memory. + New_Assign_Stmt + (New_Obj (Off_Var), + New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Off_Var), + New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)))); + end if; + end if; + end loop; + New_Return_Stmt (New_Value (Get_Var (Info.C (Kind).Size_Var))); + Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Finish_Subprogram_Body; + end Create_Record_Type_Builder; + + -------------- + -- Access -- + -------------- + procedure Translate_Access_Type (Def : Iir_Access_Type_Definition) + is + D_Type : constant Iir := Get_Designated_Type (Def); + D_Info : constant Ortho_Info_Acc := Get_Info (D_Type); + Def_Info : constant Type_Info_Acc := Get_Info (Def); + Dtype : O_Tnode; + Arr_Info : Type_Info_Acc; + begin + if not Is_Fully_Constrained_Type (D_Type) then + -- An access type to an unconstrained type definition is a fat + -- pointer. + Def_Info.Type_Mode := Type_Mode_Fat_Acc; + if D_Info.Kind = Kind_Incomplete_Type then + Translate_Incomplete_Array_Type (D_Type); + Arr_Info := D_Info.Incomplete_Array; + Def_Info.Ortho_Type := Arr_Info.Ortho_Type; + Def_Info.T := Arr_Info.T; + else + Def_Info.Ortho_Type := D_Info.Ortho_Type; + Def_Info.T := D_Info.T; + end if; + Def_Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Def_Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Def_Info.Ortho_Ptr_Type (Mode_Value)); + else + -- Otherwise, it is a thin pointer. + Def_Info.Type_Mode := Type_Mode_Acc; + -- No access types for signals. + Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + + if D_Info.Kind = Kind_Incomplete_Type then + Dtype := O_Tnode_Null; + elsif Is_Complex_Type (D_Info) then + -- FIXME: clean here when the ortho_type of a array + -- complex_type is correctly set (not a pointer). + Def_Info.Ortho_Type (Mode_Value) := + D_Info.Ortho_Ptr_Type (Mode_Value); + Finish_Type_Definition (Def_Info, True); + return; + elsif D_Info.Type_Mode in Type_Mode_Arrays then + -- The designated type cannot be a sub array inside ortho. + -- FIXME: lift this restriction. + Dtype := D_Info.T.Base_Type (Mode_Value); + else + Dtype := D_Info.Ortho_Type (Mode_Value); + end if; + Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype); + Finish_Type_Definition (Def_Info); + end if; + end Translate_Access_Type; + + ------------------------ + -- Incomplete types -- + ------------------------ + procedure Translate_Incomplete_Type (Def : Iir) + is +-- Ftype : Iir; +-- Info : Type_Info_Acc; + Info : Incomplete_Type_Info_Acc; + Ctype : Iir; + begin + if Get_Nbr_Elements (Get_Incomplete_Type_List (Def)) = 0 then + -- FIXME: + -- This is a work-around for dummy incomplete type (ie incomplete + -- types not used before the full type declaration). + return; + end if; + Ctype := Get_Type (Get_Type_Declarator (Def)); + Info := Add_Info (Ctype, Kind_Incomplete_Type); + Info.Incomplete_Type := Def; + Info.Incomplete_Array := null; + end Translate_Incomplete_Type; + + -- CTYPE is the type which has been completed. + procedure Translate_Complete_Type + (Incomplete_Info : in out Incomplete_Type_Info_Acc; Ctype : Iir) + is + List : Iir_List; + Atype : Iir; + Def_Info : Type_Info_Acc; + C_Info : Type_Info_Acc; + Dtype : O_Tnode; + begin + C_Info := Get_Info (Ctype); + List := Get_Incomplete_Type_List (Incomplete_Info.Incomplete_Type); + for I in Natural loop + Atype := Get_Nth_Element (List, I); + exit when Atype = Null_Iir; + if Get_Kind (Atype) /= Iir_Kind_Access_Type_Definition then + raise Internal_Error; + end if; + Def_Info := Get_Info (Atype); + case C_Info.Type_Mode is + when Type_Mode_Arrays => + Dtype := C_Info.T.Base_Type (Mode_Value); + when others => + Dtype := C_Info.Ortho_Type (Mode_Value); + end case; + Finish_Access_Type (Def_Info.Ortho_Type (Mode_Value), Dtype); + end loop; + Unchecked_Deallocation (Incomplete_Info); + end Translate_Complete_Type; + + ----------------- + -- protected -- + ----------------- + + procedure Translate_Protected_Type (Def : Iir_Protected_Type_Declaration) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Mark : Id_Mark_Type; + begin + New_Uncomplete_Record_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); + + Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Info.Ortho_Ptr_Type (Mode_Value)); + + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; + + Info.Type_Mode := Type_Mode_Protected; + + -- A protected type is a complex type, as its size is not known + -- at definition point (will be known at body declaration). + Info.C := new Complex_Type_Arr_Info; + Info.C (Mode_Value).Builder_Need_Func := False; + + -- This is just use to set overload number on subprograms, and to + -- translate interfaces. + Push_Identifier_Prefix + (Mark, Get_Identifier (Get_Type_Declarator (Def))); + Chap4.Translate_Declaration_Chain (Def); + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type; + + procedure Translate_Protected_Type_Subprograms + (Def : Iir_Protected_Type_Declaration) + is + Info : constant Type_Info_Acc := Get_Info (Def); + El : Iir; + Inter_List : O_Inter_List; + Mark : Id_Mark_Type; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Push_Identifier_Prefix + (Mark, Get_Identifier (Get_Type_Declarator (Def))); + + -- Init. + Start_Function_Decl + (Inter_List, Create_Identifier ("INIT"), Global_Storage, + Info.Ortho_Ptr_Type (Mode_Value)); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Init_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Subprg); + + -- Use the object as instance. + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj, + Prev_Subprg_Instance); + + -- Final. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("FINI"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Final_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Final_Subprg); + + -- Methods. + El := Get_Declaration_Chain (Def); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- Translate only if used. + if Get_Info (El) /= null then + Chap2.Translate_Subprogram_Declaration (El); + end if; + when others => + Error_Kind ("translate_protected_type_subprograms", El); + end case; + El := Get_Chain (El); + end loop; + + Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Subprograms; + + procedure Translate_Protected_Type_Body (Bod : Iir) + is + Decl : constant Iir_Protected_Type_Declaration := + Get_Protected_Type_Declaration (Bod); + Info : constant Type_Info_Acc := Get_Info (Decl); + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + -- Create the object type + Push_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); + -- First, the previous instance. + Chap2.Add_Subprg_Instance_Field (Info.T.Prot_Subprg_Instance_Field); + -- Then the object lock + Info.T.Prot_Lock_Field := Add_Instance_Factory_Field + (Get_Identifier ("LOCK"), Ghdl_Ptr_Type); + + -- Translate declarations. + Chap4.Translate_Declaration_Chain (Bod); + + Pop_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); + Info.Ortho_Type (Mode_Value) := Get_Scope_Type (Info.T.Prot_Scope); + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Body; + + procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode) + is + Info : constant Type_Info_Acc := Get_Info (Type_Def); + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Proc); + New_Association + (Assoc, + New_Unchecked_Address + (New_Selected_Element + (Get_Instance_Ref (Info.T.Prot_Scope), + Info.T.Prot_Lock_Field), + Ghdl_Ptr_Type)); + New_Procedure_Call (Assoc); + end Call_Ghdl_Protected_Procedure; + + procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir) + is + Mark : Id_Mark_Type; + Decl : constant Iir := Get_Protected_Type_Declaration (Bod); + Info : constant Type_Info_Acc := Get_Info (Decl); + Final : Boolean; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + -- Subprograms of BOD. + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj, + Prev_Subprg_Instance); + Chap2.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Bod); + + Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); + + Pop_Identifier_Prefix (Mark); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Init subprogram + declare + Var_Obj : O_Dnode; + begin + Start_Subprogram_Body (Info.T.Prot_Init_Subprg); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + New_Var_Decl (Var_Obj, Wki_Obj, O_Storage_Local, + Info.Ortho_Ptr_Type (Mode_Value)); + + -- Allocate the object + New_Assign_Stmt + (New_Obj (Var_Obj), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Info.Ortho_Type (Mode_Value), + Ghdl_Index_Type)), + Info.Ortho_Ptr_Type (Mode_Value))); + + Chap2.Set_Subprg_Instance_Field + (Var_Obj, Info.T.Prot_Subprg_Instance_Field, + Info.T.Prot_Init_Instance); + + Set_Scope_Via_Param_Ptr (Info.T.Prot_Scope, Var_Obj); + + -- Create lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init); + + -- Elaborate fields. + Open_Temp; + Chap4.Elab_Declaration_Chain (Bod, Final); + Close_Temp; + + Clear_Scope (Info.T.Prot_Scope); + + New_Return_Stmt (New_Obj_Value (Var_Obj)); + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + + Finish_Subprogram_Body; + end; + + -- Fini subprogram + begin + Start_Subprogram_Body (Info.T.Prot_Final_Subprg); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + + -- Deallocate fields. + if Final or True then + Chap4.Final_Declaration_Chain (Bod, True); + end if; + + -- Destroy lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini); + + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + Finish_Subprogram_Body; + end; + end Translate_Protected_Type_Body_Subprograms; + + --------------- + -- Scalars -- + --------------- + + -- Create a type_range structure. + procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode) + is + T_Info : Type_Info_Acc; + Base_Type : Iir; + Expr : Iir; + V : O_Dnode; + begin + Base_Type := Get_Base_Type (Def); + T_Info := Get_Info (Base_Type); + Expr := Get_Range_Constraint (Def); + Open_Temp; + V := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, Target); + Chap7.Translate_Range_Ptr (V, Expr, Def); + Close_Temp; + end Create_Scalar_Type_Range; + + function Create_Static_Scalar_Type_Range (Def : Iir) return O_Cnode is + begin + return Chap7.Translate_Static_Range (Get_Range_Constraint (Def), + Get_Base_Type (Def)); + end Create_Static_Scalar_Type_Range; + + procedure Create_Scalar_Type_Range_Type + (Def : Iir; With_Length : Boolean) + is + Constr : O_Element_List; + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Def); + Start_Record_Type (Constr); + New_Record_Field + (Constr, Info.T.Range_Left, Wki_Left, + Info.Ortho_Type (Mode_Value)); + New_Record_Field + (Constr, Info.T.Range_Right, Wki_Right, + Info.Ortho_Type (Mode_Value)); + New_Record_Field + (Constr, Info.T.Range_Dir, Wki_Dir, Ghdl_Dir_Type_Node); + if With_Length then + New_Record_Field + (Constr, Info.T.Range_Length, Wki_Length, Ghdl_Index_Type); + else + Info.T.Range_Length := O_Fnode_Null; + end if; + Finish_Record_Type (Constr, Info.T.Range_Type); + New_Type_Decl (Create_Identifier ("TRT"), Info.T.Range_Type); + Info.T.Range_Ptr_Type := New_Access_Type (Info.T.Range_Type); + New_Type_Decl (Create_Identifier ("TRPTR"), + Info.T.Range_Ptr_Type); + end Create_Scalar_Type_Range_Type; + + function Create_Static_Type_Definition_Type_Range (Def : Iir) + return O_Cnode + is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kinds_Scalar_Subtype_Definition => + return Create_Static_Scalar_Type_Range (Def); + + when Iir_Kind_Array_Subtype_Definition => + return Create_Static_Array_Subtype_Bounds (Def); + + when Iir_Kind_Array_Type_Definition => + return O_Cnode_Null; + + when others => + Error_Kind ("create_static_type_definition_type_range", Def); + end case; + end Create_Static_Type_Definition_Type_Range; + + procedure Create_Type_Definition_Type_Range (Def : Iir) + is + Target : O_Lnode; + Info : Type_Info_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kinds_Scalar_Subtype_Definition => + Target := Get_Var (Get_Info (Def).T.Range_Var); + Create_Scalar_Type_Range (Def, Target); + + when Iir_Kind_Array_Subtype_Definition => + if Get_Constraint_State (Def) = Fully_Constrained then + Info := Get_Info (Def); + if not Info.T.Static_Bounds then + Target := Get_Var (Info.T.Array_Bounds); + Create_Array_Subtype_Bounds (Def, Target); + end if; + end if; + + when Iir_Kind_Array_Type_Definition => + declare + Index_List : constant Iir_List := + Get_Index_Subtype_List (Def); + Index : Iir; + begin + for I in Natural loop + Index := Get_Index_Type (Index_List, I); + exit when Index = Null_Iir; + if Is_Anonymous_Type_Definition (Index) then + Create_Type_Definition_Type_Range (Index); + end if; + end loop; + end; + Translate_Dynamic_Unidimensional_Array_Length_One (Def); + return; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Protected_Type_Declaration => + return; + + when others => + Error_Kind ("create_type_definition_type_range", Def); + end case; + end Create_Type_Definition_Type_Range; + + -- Return TRUE iff LIT is equal to the high (IS_HI=TRUE) or low + -- (IS_HI=false) limit of the base type of DEF. MODE is the mode of + -- DEF. + function Is_Equal_Limit (Lit : Iir; + Is_Hi : Boolean; + Def : Iir; + Mode : Type_Mode_Type) return Boolean + is + begin + case Mode is + when Type_Mode_B1 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Eval_Pos (Lit)); + if Is_Hi then + return V = 1; + else + return V = 0; + end if; + end; + when Type_Mode_E8 => + declare + V : Iir_Int32; + Base_Type : Iir; + begin + V := Iir_Int32 (Eval_Pos (Lit)); + if Is_Hi then + Base_Type := Get_Base_Type (Def); + return V = Iir_Int32 + (Get_Nbr_Elements + (Get_Enumeration_Literal_List (Base_Type))) - 1; + else + return V = 0; + end if; + end; + when Type_Mode_I32 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Get_Value (Lit)); + if Is_Hi then + return V = Iir_Int32'Last; + else + return V = Iir_Int32'First; + end if; + end; + when Type_Mode_P32 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Get_Physical_Value (Lit)); + if Is_Hi then + return V = Iir_Int32'Last; + else + return V = Iir_Int32'First; + end if; + end; + when Type_Mode_I64 => + declare + V : Iir_Int64; + begin + V := Get_Value (Lit); + if Is_Hi then + return V = Iir_Int64'Last; + else + return V = Iir_Int64'First; + end if; + end; + when Type_Mode_P64 => + declare + V : Iir_Int64; + begin + V := Get_Physical_Value (Lit); + if Is_Hi then + return V = Iir_Int64'Last; + else + return V = Iir_Int64'First; + end if; + end; + when Type_Mode_F64 => + declare + V : Iir_Fp64; + begin + V := Get_Fp_Value (Lit); + if Is_Hi then + return V = Iir_Fp64'Last; + else + return V = Iir_Fp64'First; + end if; + end; + when others => + Error_Kind ("is_equal_limit " & Type_Mode_Type'Image (Mode), + Lit); + end case; + end Is_Equal_Limit; + + -- For scalar subtypes: creates info from the base type. + procedure Create_Subtype_Info_From_Type (Def : Iir; + Subtype_Info : Type_Info_Acc; + Base_Info : Type_Info_Acc) + is + Rng : Iir; + Lo, Hi : Iir; + begin + Subtype_Info.Ortho_Type := Base_Info.Ortho_Type; + Subtype_Info.Ortho_Ptr_Type := Base_Info.Ortho_Ptr_Type; + Subtype_Info.Type_Mode := Base_Info.Type_Mode; + Subtype_Info.T := Base_Info.T; + + Rng := Get_Range_Constraint (Def); + if Get_Expr_Staticness (Rng) /= Locally then + -- Bounds are not known. + -- Do the checks. + Subtype_Info.T.Nocheck_Hi := False; + Subtype_Info.T.Nocheck_Low := False; + else + -- Bounds are locally static. + Get_Low_High_Limit (Rng, Lo, Hi); + Subtype_Info.T.Nocheck_Hi := + Is_Equal_Limit (Hi, True, Def, Base_Info.Type_Mode); + Subtype_Info.T.Nocheck_Low := + Is_Equal_Limit (Lo, False, Def, Base_Info.Type_Mode); + end if; + end Create_Subtype_Info_From_Type; + + procedure Create_Record_Size_Var (Def : Iir; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Def)); + El : Iir_Element_Declaration; + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Inner_Type : Iir; + Inner_Tinfo : Type_Info_Acc; + Res : O_Enode; + Align_Var : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + + -- Start with the size of the 'base' record, that + -- contains all non-complex types and an offset for + -- each complex types. + Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type)); + + -- Start with alignment of the record. + -- ALIGN = ALIGNOF (record) + if Kind = Mode_Value then + Align_Var := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Align_Var), + Get_Type_Alignmask (Info.Ortho_Type (Kind))); + end if; + + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + El_Tinfo := Get_Info (El_Type); + if Is_Complex_Type (El_Tinfo) then + Inner_Type := Get_Innermost_Non_Array_Element (El_Type); + + -- Align (only for Mode_Value) the size, + -- and add the size of the element. + if Kind = Mode_Value then + Inner_Tinfo := Get_Info (Inner_Type); + -- If alignmask (Inner_Type) > alignmask then + -- alignmask = alignmask (Inner_type); + -- end if; + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Gt, + Get_Type_Alignmask (Inner_Tinfo), + New_Obj_Value (Align_Var), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Align_Var), Get_Type_Alignmask (Inner_Tinfo)); + Finish_If_Stmt (If_Blk); + Res := Realign (Res, Inner_Type); + end if; + Res := New_Dyadic_Op + (ON_Add_Ov, + New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Res); + end if; + end loop; + if Kind = Mode_Value then + Res := Realign (Res, Align_Var); + end if; + New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); + Close_Temp; + end Create_Record_Size_Var; + + procedure Create_Array_Size_Var (Def : Iir; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + El_Type : constant Iir := Get_Element_Subtype (Def); + Res : O_Enode; + begin + Res := New_Dyadic_Op + (ON_Mul_Ov, + Get_Array_Type_Length (Def), + Chap3.Get_Object_Size (T2M (El_Type, Kind), El_Type)); + New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); + end Create_Array_Size_Var; + + procedure Create_Type_Definition_Size_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + begin + if not Is_Complex_Type (Info) then + return; + end if; + + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + if Info.C (Kind).Size_Var /= Null_Var then + case Info.Type_Mode is + when Type_Mode_Non_Composite + | Type_Mode_Fat_Array + | Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + when Type_Mode_Record => + Create_Record_Size_Var (Def, Kind); + when Type_Mode_Array => + Create_Array_Size_Var (Def, Kind); + end case; + end if; + end loop; + end Create_Type_Definition_Size_Var; + + procedure Create_Type_Range_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Info : Type_Info_Acc; + Val : O_Cnode; + Suffix : String (1 .. 3) := "xTR"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Subtype_Definition => + Suffix (1) := 'S'; -- "STR"; + when Iir_Kind_Enumeration_Type_Definition => + Suffix (1) := 'B'; -- "BTR"; + when others => + raise Internal_Error; + end case; + Base_Info := Get_Info (Get_Base_Type (Def)); + case Get_Type_Staticness (Def) is + when None + | Globally => + Info.T.Range_Var := Create_Var + (Create_Var_Identifier (Suffix), Base_Info.T.Range_Type); + when Locally => + if Global_Storage = O_Storage_External then + -- Do not create the value of the type desc, since it + -- is never dereferenced in a static type desc. + Val := O_Cnode_Null; + else + Val := Create_Static_Type_Definition_Type_Range (Def); + end if; + Info.T.Range_Var := Create_Global_Const + (Create_Identifier (Suffix), + Base_Info.T.Range_Type, Global_Storage, Val); + when Unknown => + raise Internal_Error; + end case; + end Create_Type_Range_Var; + + + -- Call HANDLE_A_SUBTYPE for all type/subtypes declared with DEF + -- (of course, this is a noop if DEF is not a composite type). + generic + with procedure Handle_A_Subtype (Atype : Iir); + procedure Handle_Anonymous_Subtypes (Def : Iir); + + procedure Handle_Anonymous_Subtypes (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Asub : Iir; + begin + Asub := Get_Element_Subtype (Def); + if Is_Anonymous_Type_Definition (Asub) then + Handle_A_Subtype (Asub); + end if; + end; + when Iir_Kind_Record_Type_Definition => + declare + El : Iir; + Asub : Iir; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Asub := Get_Type (El); + if Is_Anonymous_Type_Definition (Asub) then + Handle_A_Subtype (Asub); + end if; + end loop; + end; + when others => + null; + end case; + end Handle_Anonymous_Subtypes; + + -- Note: boolean types are translated by translate_bool_type_definition! + procedure Translate_Type_Definition + (Def : Iir; With_Vars : Boolean := True) + is + Info : Ortho_Info_Acc; + Base_Info : Type_Info_Acc; + Base_Type : Iir; + Complete_Info : Incomplete_Type_Info_Acc; + begin + -- Handle the special case of incomplete type. + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + Translate_Incomplete_Type (Def); + return; + end if; + + -- If the definition is already translated, return now. + Info := Get_Info (Def); + if Info /= null then + if Info.Kind = Kind_Type then + -- The subtype was already translated. + return; + end if; + if Info.Kind = Kind_Incomplete_Type then + -- Type is being completed. + Complete_Info := Info; + Clear_Info (Def); + if Complete_Info.Incomplete_Array /= null then + Info := Complete_Info.Incomplete_Array; + Set_Info (Def, Info); + Unchecked_Deallocation (Complete_Info); + else + Info := Add_Info (Def, Kind_Type); + end if; + else + raise Internal_Error; + end if; + else + Complete_Info := null; + Info := Add_Info (Def, Kind_Type); + end if; + + Base_Type := Get_Base_Type (Def); + Base_Info := Get_Info (Base_Type); + + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + Translate_Enumeration_Type (Def); + Create_Scalar_Type_Range_Type (Def, True); + Create_Type_Range_Var (Def); + --Create_Type_Desc_Var (Def); + + when Iir_Kind_Integer_Type_Definition => + Translate_Integer_Type (Def); + Create_Scalar_Type_Range_Type (Def, True); + + when Iir_Kind_Physical_Type_Definition => + Translate_Physical_Type (Def); + Create_Scalar_Type_Range_Type (Def, False); + if With_Vars and Get_Type_Staticness (Def) /= Locally then + Translate_Physical_Units (Def); + else + Info.T.Range_Var := Null_Var; + end if; + + when Iir_Kind_Floating_Type_Definition => + Translate_Floating_Type (Def); + Create_Scalar_Type_Range_Type (Def, False); + + when Iir_Kinds_Scalar_Subtype_Definition => + Create_Subtype_Info_From_Type (Def, Info, Base_Info); + if With_Vars then + Create_Type_Range_Var (Def); + else + Info.T.Range_Var := Null_Var; + end if; + + when Iir_Kind_Array_Type_Definition => + declare + El_Type : Iir; + Mark : Id_Mark_Type; + begin + El_Type := Get_Element_Subtype (Def); + if Get_Info (El_Type) = null then + Push_Identifier_Prefix (Mark, "ET"); + Translate_Type_Definition (El_Type); + Pop_Identifier_Prefix (Mark); + end if; + end; + Translate_Array_Type_Definition (Def); + + when Iir_Kind_Array_Subtype_Definition => + if Get_Index_Constraint_Flag (Def) then + if Base_Info = null or else Base_Info.Type_Incomplete then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "BT"); + Translate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + Base_Info := Get_Info (Base_Type); + end; + end if; + Translate_Array_Subtype_Definition (Def); + Info.T := Base_Info.T; + --Info.Type_Range_Type := Base_Info.Type_Range_Type; + if With_Vars then + Create_Array_Subtype_Bounds_Var (Def, False); + end if; + else + -- An unconstrained array subtype. Use same infos as base + -- type. + Free_Info (Def); + Set_Info (Def, Base_Info); + end if; + Translate_Array_Subtype_Element_Subtype (Def); + + when Iir_Kind_Record_Type_Definition => + Translate_Record_Type (Def); + Info.T := Ortho_Info_Type_Record_Init; + + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + Free_Info (Def); + Set_Info (Def, Base_Info); + + when Iir_Kind_Access_Type_Definition => + declare + Dtype : constant Iir := Get_Designated_Type (Def); + begin + -- Translate the subtype + if Is_Anonymous_Type_Definition (Dtype) then + Translate_Type_Definition (Dtype); + end if; + Translate_Access_Type (Def); + end; + + when Iir_Kind_File_Type_Definition => + Translate_File_Type (Def); + Info.T := Ortho_Info_Type_File_Init; + if With_Vars then + Create_File_Type_Var (Def); + end if; + + when Iir_Kind_Protected_Type_Declaration => + Translate_Protected_Type (Def); + Info.T := Ortho_Info_Type_Prot_Init; + + when others => + Error_Kind ("translate_type_definition", Def); + end case; + + if Complete_Info /= null then + Translate_Complete_Type (Complete_Info, Def); + end if; + end Translate_Type_Definition; + + procedure Translate_Bool_Type_Definition (Def : Iir) + is + Info : Type_Info_Acc; + begin + -- If the definition is already translated, return now. + Info := Get_Info (Def); + if Info /= null then + raise Internal_Error; + end if; + + Info := Add_Info (Def, Kind_Type); + + if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then + raise Internal_Error; + end if; + Translate_Bool_Type (Def); + + -- This is usually done in translate_type_definition, but boolean + -- types are not handled by translate_type_definition. + Create_Scalar_Type_Range_Type (Def, True); + end Translate_Bool_Type_Definition; + + procedure Translate_Type_Subprograms (Decl : Iir) + is + Def : Iir; + Tinfo : Type_Info_Acc; + Id : Name_Id; + begin + Def := Get_Type_Definition (Decl); + + if Get_Kind (Def) in Iir_Kinds_Subtype_Definition then + -- Also elaborate the base type, iff DEF and its BASE_TYPE have + -- been declared by the same type declarator. This avoids several + -- elaboration of the same type. + Def := Get_Base_Type (Def); + if Get_Type_Declarator (Def) /= Decl then + -- Can this happen ?? + raise Internal_Error; + end if; + elsif Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + return; + end if; + + if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then + Translate_Protected_Type_Subprograms (Def); + end if; + + Tinfo := Get_Info (Def); + if not Is_Complex_Type (Tinfo) + or else Tinfo.C (Mode_Value).Builder_Need_Func = False + then + return; + end if; + + -- Declare subprograms. + Id := Get_Identifier (Decl); + Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal); + end if; + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Define subprograms. + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition => + Create_Array_Type_Builder (Def, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Array_Type_Builder (Def, Mode_Signal); + end if; + when Iir_Kind_Record_Type_Definition => + Create_Record_Type_Builder (Def, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Record_Type_Builder (Def, Mode_Signal); + end if; + when others => + Error_Kind ("translate_type_subprograms", Def); + end case; + end Translate_Type_Subprograms; + + -- Initialize the objects related to a type (type range and type + -- descriptor). + procedure Elab_Type_Definition (Def : Iir); + procedure Elab_Type_Definition_Depend is new Handle_Anonymous_Subtypes + (Handle_A_Subtype => Elab_Type_Definition); + procedure Elab_Type_Definition (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Incomplete_Type_Definition => + -- Nothing to do. + return; + when Iir_Kind_Protected_Type_Declaration => + -- Elaboration subprograms interfaces. + declare + Final : Boolean; + begin + Chap4.Elab_Declaration_Chain (Def, Final); + if Final then + raise Internal_Error; + end if; + end; + return; + when others => + null; + end case; + + if Get_Type_Staticness (Def) = Locally then + return; + end if; + + Elab_Type_Definition_Depend (Def); + + Create_Type_Definition_Type_Range (Def); + Create_Type_Definition_Size_Var (Def); + end Elab_Type_Definition; + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Id); + Chap3.Translate_Type_Definition (Def); + Pop_Identifier_Prefix (Mark); + end Translate_Named_Type_Definition; + + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean) + is + Mark : Id_Mark_Type; + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Def); + if Type_Info /= null then + return; + end if; + Push_Identifier_Prefix_Uniq (Mark); + Chap3.Translate_Type_Definition (Def, False); + if Transient then + Add_Transient_Type_In_Temp (Def); + end if; + Pop_Identifier_Prefix (Mark); + end Translate_Anonymous_Type_Definition; + + procedure Destroy_Type_Info (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Free_Type_Info (Type_Info); + Clear_Info (Atype); + end Destroy_Type_Info; + + procedure Translate_Object_Subtype (Decl : Iir; + With_Vars : Boolean := True) + is + Mark : Id_Mark_Type; + Mark2 : Id_Mark_Type; + Def : Iir; + begin + Def := Get_Type (Decl); + if Is_Anonymous_Type_Definition (Def) then + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark2, "OT"); + Chap3.Translate_Type_Definition (Def, With_Vars); + Pop_Identifier_Prefix (Mark2); + Pop_Identifier_Prefix (Mark); + end if; + end Translate_Object_Subtype; + + procedure Elab_Object_Subtype (Def : Iir) is + begin + if Is_Anonymous_Type_Definition (Def) then + Elab_Type_Definition (Def); + end if; + end Elab_Object_Subtype; + + procedure Elab_Type_Declaration (Decl : Iir) + is + begin + Elab_Type_Definition (Get_Type_Definition (Decl)); + end Elab_Type_Declaration; + + procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration) + is + begin + Elab_Type_Definition (Get_Type (Decl)); + end Elab_Subtype_Declaration; + + function Get_Thin_Array_Length (Atype : Iir) return O_Cnode + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Indexes_List); + Index : Iir; + Val : Iir_Int64; + Rng : Iir; + begin + Val := 1; + for I in 0 .. Nbr_Dim - 1 loop + Index := Get_Index_Type (Indexes_List, I); + Rng := Get_Range_Constraint (Index); + Val := Val * Eval_Discrete_Range_Length (Rng); + end loop; + return New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Val)); + end Get_Thin_Array_Length; + + function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) + return Mnode + is + Indexes_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Get_Base_Type (Atype)); + Index_Type_Mark : constant Iir := + Get_Nth_Element (Indexes_List, Dim - 1); + Index_Type : constant Iir := Get_Index_Type (Index_Type_Mark); + Base_Index_Info : constant Index_Info_Acc := + Get_Info (Index_Type_Mark); + Iinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Index_Type)); + begin + return Lv2M (New_Selected_Element (M2Lv (B), + Base_Index_Info.Index_Field), + Iinfo, + Get_Object_Kind (B), + Iinfo.T.Range_Type, + Iinfo.T.Range_Ptr_Type); + end Bounds_To_Range; + + function Type_To_Range (Atype : Iir) return Mnode + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + return Varv2M (Info.T.Range_Var, Info, Mode_Value, + Info.T.Range_Type, Info.T.Range_Ptr_Type); + end Type_To_Range; + + function Range_To_Length (R : Mnode) return Mnode + is + Tinfo : constant Type_Info_Acc := Get_Type_Info (R); + begin + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Length), + Tinfo, + Mode_Value); + end Range_To_Length; + + function Range_To_Dir (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Dir), + Tinfo, + Mode_Value); + end Range_To_Dir; + + function Range_To_Left (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Left), + Tinfo, + Mode_Value); + end Range_To_Left; + + function Range_To_Right (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Right), + Tinfo, + Mode_Value); + end Range_To_Right; + + function Get_Array_Type_Bounds (Info : Type_Info_Acc) return Mnode + is + begin + case Info.Type_Mode is + when Type_Mode_Fat_Array => + raise Internal_Error; + when Type_Mode_Array => + return Varv2M (Info.T.Array_Bounds, + Info, Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type); + when others => + raise Internal_Error; + end case; + end Get_Array_Type_Bounds; + + function Get_Array_Type_Bounds (Atype : Iir) return Mnode is + begin + return Get_Array_Type_Bounds (Get_Info (Atype)); + end Get_Array_Type_Bounds; + + function Get_Array_Bounds (Arr : Mnode) return Mnode + is + Info : constant Type_Info_Acc := Get_Type_Info (Arr); + begin + case Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + declare + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Arr); + return Lp2M + (New_Selected_Element (M2Lv (Arr), + Info.T.Bounds_Field (Kind)), + Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type); + end; + when Type_Mode_Array => + return Get_Array_Type_Bounds (Info); + when others => + raise Internal_Error; + end case; + end Get_Array_Bounds; + + function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) + return Mnode is + begin + return Bounds_To_Range (Get_Array_Bounds (Arr), Atype, Dim); + end Get_Array_Range; + + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + Index_List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Dim_Length : O_Enode; + Res : O_Enode; + Bounds_Stable : Mnode; + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + end if; + + if Nbr_Dim > 1 then + Bounds_Stable := Stabilize (Bounds); + else + Bounds_Stable := Bounds; + end if; + + for Dim in 1 .. Nbr_Dim loop + Dim_Length := + M2E (Range_To_Length + (Bounds_To_Range (Bounds_Stable, Atype, Dim))); + if Dim = 1 then + Res := Dim_Length; + else + Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); + end if; + end loop; + return Res; + end Get_Bounds_Length; + + function Get_Array_Type_Length (Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype); + end if; + end Get_Array_Type_Length; + + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Bounds (Arr), Atype); + end if; + end Get_Array_Length; + + function Get_Array_Base (Arr : Mnode) return Mnode + is + Info : Type_Info_Acc; + begin + Info := Get_Type_Info (Arr); + case Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + declare + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Arr); + return Lp2M + (New_Selected_Element (M2Lv (Arr), + Info.T.Base_Field (Kind)), + Info, + Get_Object_Kind (Arr), + Info.T.Base_Type (Kind), + Info.T.Base_Ptr_Type (Kind)); + end; + when Type_Mode_Array => + return Arr; + when others => + raise Internal_Error; + end case; + end Get_Array_Base; + + function Reindex_Complex_Array + (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc) + return Mnode + is + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + pragma Assert (Is_Complex_Type (El_Tinfo)); + return + E2M + (New_Unchecked_Address + (New_Slice + (New_Access_Element + (New_Convert_Ov (M2E (Base), Char_Ptr_Type)), + Chararray_Type, + New_Dyadic_Op (ON_Mul_Ov, + New_Value + (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Index)), + El_Tinfo.Ortho_Ptr_Type (Kind)), + Res_Info, Kind); + end Reindex_Complex_Array; + + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, El_Tinfo); + else + return Lv2M (New_Indexed_Element (M2Lv (Base), Index), + El_Tinfo, Kind); + end if; + end Index_Base; + + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + T_Info : constant Type_Info_Acc := Get_Info (Atype); + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, T_Info); + else + return Lv2M (New_Slice (M2Lv (Base), + T_Info.T.Base_Type (Kind), + Index), + False, + T_Info.T.Base_Type (Kind), + T_Info.T.Base_Ptr_Type (Kind), + T_Info, Kind); + end if; + end Slice_Base; + + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; + Res : Mnode; + Arr_Type : Iir) + is + Dinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Arr_Type)); + Kind : constant Object_Kind_Type := Get_Object_Kind (Res); + Length : O_Enode; + begin + -- Compute array size. + Length := Get_Object_Size (Res, Arr_Type); + -- Allocate the storage for the elements. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + Gen_Alloc (Alloc_Kind, Length, Dinfo.T.Base_Ptr_Type (Kind))); + + if Is_Complex_Type (Dinfo) + and then Dinfo.C (Kind).Builder_Need_Func + then + Open_Temp; + -- Build the type. + Chap3.Gen_Call_Type_Builder (Res, Arr_Type); + Close_Temp; + end if; + end Allocate_Fat_Array_Base; + + procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix_Uniq (Mark); + if Get_Info (Sub_Type) = null then + -- Minimal subtype creation. + Translate_Type_Definition (Sub_Type, False); + if Transient then + Add_Transient_Type_In_Temp (Sub_Type); + end if; + end if; + -- Force creation of variables. + Chap3.Create_Array_Subtype_Bounds_Var (Sub_Type, True); + Chap3.Create_Type_Definition_Size_Var (Sub_Type); + Pop_Identifier_Prefix (Mark); + end Create_Array_Subtype; + + -- Copy SRC to DEST. + -- Both have the same type, OTYPE. + procedure Translate_Object_Copy (Dest : Mnode; + Src : O_Enode; + Obj_Type : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Obj_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Dest); + D : Mnode; + begin + case Info.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File => + -- Scalar or thin pointer. + New_Assign_Stmt (M2Lv (Dest), Src); + when Type_Mode_Fat_Acc => + -- a fat pointer. + D := Stabilize (Dest); + Copy_Fat_Pointer (D, Stabilize (E2M (Src, Info, Kind))); + when Type_Mode_Fat_Array => + -- a fat array. + D := Stabilize (Dest); + Gen_Memcpy (M2Addr (Get_Array_Base (D)), + M2Addr (Get_Array_Base (E2M (Src, Info, Kind))), + Get_Object_Size (D, Obj_Type)); + when Type_Mode_Array + | Type_Mode_Record => + D := Stabilize (Dest); + Gen_Memcpy (M2Addr (D), Src, Get_Object_Size (D, Obj_Type)); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Object_Copy; + + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) + return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); + begin + if Is_Complex_Type (Type_Info) + and then Type_Info.C (Kind).Size_Var /= Null_Var + then + return New_Value (Get_Var (Type_Info.C (Kind).Size_Var)); + end if; + case Type_Info.Type_Mode is + when Type_Mode_Non_Composite + | Type_Mode_Array + | Type_Mode_Record => + return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind), + Ghdl_Index_Type)); + when Type_Mode_Fat_Array => + declare + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Obj_Bt : Iir; + Sz : O_Enode; + begin + Obj_Bt := Get_Base_Type (Obj_Type); + El_Type := Get_Element_Subtype (Obj_Bt); + El_Tinfo := Get_Info (El_Type); + -- See create_type_definition_size_var. + Sz := Get_Object_Size (T2M (El_Type, Kind), El_Type); + if Is_Complex_Type (El_Tinfo) then + Sz := New_Dyadic_Op + (ON_Add_Ov, + Sz, + New_Lit (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind), + Ghdl_Index_Type))); + end if; + return New_Dyadic_Op + (ON_Mul_Ov, Chap3.Get_Array_Length (Obj, Obj_Bt), Sz); + end; + when others => + raise Internal_Error; + end case; + end Get_Object_Size; + + procedure Translate_Object_Allocation + (Res : in out Mnode; + Alloc_Kind : Allocation_Kind; + Obj_Type : Iir; + Bounds : Mnode) + is + Dinfo : constant Type_Info_Acc := Get_Info (Obj_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Res); + begin + if Dinfo.Type_Mode = Type_Mode_Fat_Array then + -- Allocate memory for bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + Gen_Alloc (Alloc_Kind, + New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Dinfo.T.Bounds_Ptr_Type)); + + -- Copy bounds to the allocated area. + Gen_Memcpy + (M2Addr (Chap3.Get_Array_Bounds (Res)), + M2Addr (Bounds), + New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, Ghdl_Index_Type))); + + -- Allocate base. + Allocate_Fat_Array_Base (Alloc_Kind, Res, Obj_Type); + else + New_Assign_Stmt + (M2Lp (Res), + Gen_Alloc + (Alloc_Kind, + Chap3.Get_Object_Size (T2M (Obj_Type, Kind), + Obj_Type), + Dinfo.Ortho_Ptr_Type (Kind))); + + if Is_Complex_Type (Dinfo) + and then Dinfo.C (Kind).Builder_Need_Func + then + Open_Temp; + -- Build the type. + Chap3.Gen_Call_Type_Builder (Res, Obj_Type); + Close_Temp; + end if; + + end if; + end Translate_Object_Allocation; + + procedure Gen_Deallocate (Obj : O_Enode) + is + Assocs : O_Assoc_List; + begin + Start_Association (Assocs, Ghdl_Deallocate); + New_Association (Assocs, New_Convert_Ov (Obj, Ghdl_Ptr_Type)); + New_Procedure_Call (Assocs); + end Gen_Deallocate; + + -- Performs deallocation of PARAM (the parameter of a deallocate call). + procedure Translate_Object_Deallocation (Param : Iir) + is + -- Performs deallocation of field FIELD of type FTYPE of PTR. + -- If FIELD is O_FNODE_NULL, deallocate PTR (of type FTYPE). + -- Here, deallocate means freeing memory and clearing to null. + procedure Deallocate_1 + (Ptr : Mnode; Field : O_Fnode; Ftype : O_Tnode) + is + L : O_Lnode; + begin + for I in 0 .. 1 loop + L := M2Lv (Ptr); + if Field /= O_Fnode_Null then + L := New_Selected_Element (L, Field); + end if; + case I is + when 0 => + -- Call deallocator. + Gen_Deallocate (New_Value (L)); + when 1 => + -- set the value to 0. + New_Assign_Stmt (L, New_Lit (New_Null_Access (Ftype))); + end case; + end loop; + end Deallocate_1; + + Param_Type : Iir; + Val : Mnode; + Info : Type_Info_Acc; + Binfo : Type_Info_Acc; + begin + -- Compute parameter + Val := Chap6.Translate_Name (Param); + if Get_Object_Kind (Val) = Mode_Signal then + raise Internal_Error; + end if; + Stabilize (Val); + Param_Type := Get_Type (Param); + Info := Get_Info (Param_Type); + case Info.Type_Mode is + when Type_Mode_Fat_Acc => + -- This is a fat pointer. + -- Deallocate base and bounds. + Binfo := Get_Info (Get_Designated_Type (Param_Type)); + Deallocate_1 (Val, Binfo.T.Base_Field (Mode_Value), + Binfo.T.Base_Ptr_Type (Mode_Value)); + Deallocate_1 (Val, Binfo.T.Bounds_Field (Mode_Value), + Binfo.T.Bounds_Ptr_Type); + when Type_Mode_Acc => + -- This is a thin pointer. + Deallocate_1 (Val, O_Fnode_Null, + Info.Ortho_Type (Mode_Value)); + when others => + raise Internal_Error; + end case; + end Translate_Object_Deallocation; + + function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode + is + Constr : Iir; + Info : Type_Info_Acc; + + function Gen_Compare (Low : O_Enode; Hi : O_Enode) return O_Enode + is + L, H : O_Enode; + begin + if not Info.T.Nocheck_Low then + L := New_Compare_Op + (ON_Lt, New_Obj_Value (Value), Low, Ghdl_Bool_Type); + end if; + if not Info.T.Nocheck_Hi then + H := New_Compare_Op + (ON_Gt, New_Obj_Value (Value), Hi, Ghdl_Bool_Type); + end if; + if Info.T.Nocheck_Hi then + if Info.T.Nocheck_Low then + -- Should not happen! + return New_Lit (Ghdl_Bool_False_Node); + else + return L; + end if; + else + if Info.T.Nocheck_Low then + return H; + else + return New_Dyadic_Op (ON_Or, L, H); + end if; + end if; + end Gen_Compare; + + function Gen_Compare_To return O_Enode is + begin + return Gen_Compare + (Chap14.Translate_Left_Type_Attribute (Atype), + Chap14.Translate_Right_Type_Attribute (Atype)); + end Gen_Compare_To; + + function Gen_Compare_Downto return O_Enode is + begin + return Gen_Compare + (Chap14.Translate_Right_Type_Attribute (Atype), + Chap14.Translate_Left_Type_Attribute (Atype)); + end Gen_Compare_Downto; + + --Low, High : Iir; + Var_Res : O_Dnode; + If_Blk : O_If_Block; + begin + Constr := Get_Range_Constraint (Atype); + Info := Get_Info (Atype); + + if Get_Kind (Constr) = Iir_Kind_Range_Expression then + -- Constraint is a range expression, therefore, direction is + -- known. + if Get_Expr_Staticness (Constr) = Locally then + -- Range constraint is locally static + -- FIXME: check low and high if they are not limits... + --Low := Get_Low_Limit (Constr); + --High := Get_High_Limit (Constr); + null; + end if; + case Get_Direction (Constr) is + when Iir_To => + return Gen_Compare_To; + when Iir_Downto => + return Gen_Compare_Downto; + end case; + end if; + + -- Range constraint is not static + -- full check (lot's of code ?). + Var_Res := Create_Temp (Ghdl_Bool_Type); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + Chap14.Translate_Dir_Type_Attribute (Atype), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + -- To. + New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_To); + New_Else_Stmt (If_Blk); + -- Downto + New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_Downto); + Finish_If_Stmt (If_Blk); + return New_Obj_Value (Var_Res); + end Not_In_Range; + + function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Info.T.Nocheck_Low and Info.T.Nocheck_Hi then + return False; + end if; + if Expr /= Null_Iir and then Get_Type (Expr) = Atype then + return False; + end if; + return True; + end Need_Range_Check; + + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir) + is + If_Blk : O_If_Block; + begin + if not Need_Range_Check (Expr, Atype) then + return; + end if; + + if Expr /= Null_Iir + and then Get_Expr_Staticness (Expr) = Locally + and then Get_Type_Staticness (Atype) = Locally + then + if not Eval_Is_In_Bound (Eval_Static_Expr (Expr), Atype) then + Chap6.Gen_Bound_Error (Loc); + end if; + else + Open_Temp; + Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype)); + Chap6.Gen_Bound_Error (Loc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end if; + end Check_Range; + + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode + is + Var : O_Dnode; + begin + Var := Create_Temp_Init + (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value); + Check_Range (Var, Expr, Atype, Loc); + return New_Obj_Value (Var); + end Insert_Scalar_Check; + + function Maybe_Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir) + return O_Enode + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + -- pragma Assert (Base_Type = Get_Base_Type (Atype)); + if Get_Kind (Expr_Type) in Iir_Kinds_Scalar_Type_Definition + and then Need_Range_Check (Expr, Atype) + then + return Insert_Scalar_Check (Value, Expr, Atype, Expr); + else + return Value; + end if; + end Maybe_Insert_Scalar_Check; + + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean + is + L_Indexes : constant Iir_List := Get_Index_Subtype_List (L_Type); + R_Indexes : constant Iir_List := Get_Index_Subtype_List (R_Type); + L_El : Iir; + R_El : Iir; + begin + for I in Natural loop + L_El := Get_Index_Type (L_Indexes, I); + R_El := Get_Index_Type (R_Indexes, I); + exit when L_El = Null_Iir and R_El = Null_Iir; + if Eval_Discrete_Type_Length (L_El) + /= Eval_Discrete_Type_Length (R_El) + then + return False; + end if; + end loop; + return True; + end Locally_Array_Match; + + procedure Check_Array_Match (L_Type : Iir; + L_Node : Mnode; + R_Type : Iir; + R_Node : Mnode; + Loc : Iir) + is + L_Tinfo, R_Tinfo : Type_Info_Acc; + begin + L_Tinfo := Get_Info (L_Type); + R_Tinfo := Get_Info (R_Type); + -- FIXME: optimize for a statically bounded array of a complex type. + if L_Tinfo.Type_Mode = Type_Mode_Array + and then L_Tinfo.Type_Locally_Constrained + and then R_Tinfo.Type_Mode = Type_Mode_Array + and then R_Tinfo.Type_Locally_Constrained + then + -- Both left and right are thin array. + -- Check here the length are the same. + if not Locally_Array_Match (L_Type, R_Type) then + Chap6.Gen_Bound_Error (Loc); + end if; + else + -- Check length match. + declare + Index_List : constant Iir_List := + Get_Index_Subtype_List (L_Type); + Index : Iir; + Cond : O_Enode; + Sub_Cond : O_Enode; + begin + for I in Natural loop + Index := Get_Nth_Element (Index_List, I); + exit when Index = Null_Iir; + Sub_Cond := New_Compare_Op + (ON_Neq, + M2E (Range_To_Length + (Get_Array_Range (L_Node, L_Type, I + 1))), + M2E (Range_To_Length + (Get_Array_Range (R_Node, R_Type, I + 1))), + Ghdl_Bool_Type); + if I = 0 then + Cond := Sub_Cond; + else + Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); + end if; + end loop; + Chap6.Check_Bound_Error (Cond, Loc, 0); + end; + end if; + end Check_Array_Match; + + procedure Create_Range_From_Array_Attribute_And_Length + (Array_Attr : Iir; Length : O_Dnode; Range_Ptr : O_Dnode) + is + Attr_Kind : Iir_Kind; + Arr_Rng : Mnode; + Iinfo : Type_Info_Acc; + + Res : Mnode; + + Dir : O_Enode; + Diff : O_Dnode; + Left_Bound : Mnode; + If_Blk : O_If_Block; + If_Blk1 : O_If_Block; + begin + Open_Temp; + Arr_Rng := Chap14.Translate_Array_Attribute_To_Range (Array_Attr); + Iinfo := Get_Type_Info (Arr_Rng); + Stabilize (Arr_Rng); + + Res := Dp2M (Range_Ptr, Iinfo, Mode_Value); + + -- Length. + New_Assign_Stmt (M2Lv (Range_To_Length (Arr_Rng)), + New_Obj_Value (Length)); + + -- Direction. + Attr_Kind := Get_Kind (Array_Attr); + Dir := M2E (Range_To_Dir (Arr_Rng)); + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Dir (Res)), Dir); + when Iir_Kind_Reverse_Range_Array_Attribute => + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, + Dir, + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt + (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_Downto_Node)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_To_Node)); + Finish_If_Stmt (If_Blk); + when others => + Error_Kind ("Create_Range_From_Array_Attribute_And_Length", + Array_Attr); + end case; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + -- Null range. + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), + M2E (Range_To_Right (Arr_Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + M2E (Range_To_Left (Arr_Rng))); + when Iir_Kind_Reverse_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), + M2E (Range_To_Left (Arr_Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + M2E (Range_To_Right (Arr_Rng))); + when others => + raise Internal_Error; + end case; + + New_Else_Stmt (If_Blk); + + -- LEFT. + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + Left_Bound := Range_To_Left (Arr_Rng); + when Iir_Kind_Reverse_Range_Array_Attribute => + Left_Bound := Range_To_Right (Arr_Rng); + when others => + raise Internal_Error; + end case; + Stabilize (Left_Bound); + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), M2E (Left_Bound)); + + -- RIGHT. + Diff := Create_Temp_Init + (Iinfo.Ortho_Type (Mode_Value), + New_Convert_Ov + (New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_1)), + Iinfo.Ortho_Type (Mode_Value))); + + Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, + M2E (Range_To_Dir (Res)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + New_Dyadic_Op (ON_Add_Ov, + M2E (Left_Bound), + New_Obj_Value (Diff))); + New_Else_Stmt (If_Blk1); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Left_Bound), + New_Obj_Value (Diff))); + Finish_If_Stmt (If_Blk1); + + -- FIXME: check right bounds is inside bounds. + Finish_If_Stmt (If_Blk); + Close_Temp; + end Create_Range_From_Array_Attribute_And_Length; + + procedure Create_Range_From_Length + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir) + is + Iinfo : constant Type_Info_Acc := Get_Info (Index_Type); + Range_Constr : constant Iir := Get_Range_Constraint (Index_Type); + Op : ON_Op_Kind; + Diff : O_Enode; + Left_Bound : O_Enode; + Var_Right : O_Dnode; + If_Blk : O_If_Block; + begin + if Get_Kind (Range_Constr) /= Iir_Kind_Range_Expression then + Create_Range_From_Array_Attribute_And_Length + (Range_Constr, Length, Range_Ptr); + return; + end if; + + Start_Declare_Stmt; + New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), + O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Length), + New_Obj_Value (Length)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Dir), + New_Lit (Chap7.Translate_Static_Range_Dir (Range_Constr))); + + case Get_Direction (Range_Constr) is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + -- Null range. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), + Chap7.Translate_Range_Expression_Right (Range_Constr, Index_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), + Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); + + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), + Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); + Left_Bound := Chap7.Translate_Range_Expression_Left + (Range_Constr, Index_Type); + Diff := New_Convert_Ov + (New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_1)), + Iinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (Var_Right), + New_Dyadic_Op (Op, Left_Bound, Diff)); + + -- Check the right bounds is inside the bounds of the index type. + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Loc); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), + New_Obj_Value (Var_Right)); + Finish_If_Stmt (If_Blk); + Finish_Declare_Stmt; + end Create_Range_From_Length; + end Chap3; + + package body Chap4 is + -- Get the ortho type for an object of mode MODE. + function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) + return O_Tnode is + begin + if Is_Complex_Type (Tinfo) then + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + return Tinfo.Ortho_Type (Kind); + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Protected => + -- For a complex type, use a pointer. + return Tinfo.Ortho_Ptr_Type (Kind); + when others => + raise Internal_Error; + end case; + else + return Tinfo.Ortho_Type (Kind); + end if; + end Get_Object_Type; + + procedure Create_Object (El : Iir) + is + Obj_Type : O_Tnode; + Info : Object_Info_Acc; + Tinfo : Type_Info_Acc; + Def : Iir; + Val : Iir; + Storage : O_Storage; + Deferred : Iir; + begin + Def := Get_Type (El); + Val := Get_Default_Value (El); + + -- Be sure the object type was translated. + if Get_Kind (El) = Iir_Kind_Constant_Declaration + and then Get_Deferred_Declaration_Flag (El) = False + and then Get_Deferred_Declaration (El) /= Null_Iir + then + -- This is a full constant declaration which complete a previous + -- incomplete constant declaration. + -- + -- Do not create the subtype of this full constant declaration, + -- since it was already created by the deferred declaration. + -- Use the type of the deferred declaration. + Deferred := Get_Deferred_Declaration (El); + Def := Get_Type (Deferred); + Info := Get_Info (Deferred); + Set_Info (El, Info); + else + Chap3.Translate_Object_Subtype (El); + Info := Add_Info (El, Kind_Object); + end if; + + Tinfo := Get_Info (Def); + Obj_Type := Get_Object_Type (Tinfo, Mode_Value); + + case Get_Kind (El) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration => + Info.Object_Var := + Create_Var (Create_Var_Identifier (El), Obj_Type); + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration (El) /= Null_Iir then + -- This is a full constant declaration (in a body) of a + -- deferred constant declaration (in a package). + Storage := O_Storage_Public; + else + Storage := Global_Storage; + end if; + if Info.Object_Var = Null_Var then + -- Not a full constant declaration (ie a value for an + -- already declared constant). + -- Must create the declaration. + if Chap7.Is_Static_Constant (El) then + Info.Object_Static := True; + Info.Object_Var := Create_Global_Const + (Create_Identifier (El), Obj_Type, Global_Storage, + O_Cnode_Null); + else + Info.Object_Static := False; + Info.Object_Var := Create_Var + (Create_Var_Identifier (El), + Obj_Type, Global_Storage); + end if; + end if; + if Get_Deferred_Declaration (El) = Null_Iir + and then Info.Object_Static + and then Storage /= O_Storage_External + then + -- Deferred constant are never considered as locally static. + -- FIXME: to be improved ? + + -- open_temp/close_temp only required for transient types. + Open_Temp; + Define_Global_Const + (Info.Object_Var, + Chap7.Translate_Static_Expression (Val, Def)); + Close_Temp; + end if; + when others => + Error_Kind ("create_objet", El); + end case; + end Create_Object; + + procedure Create_Signal (Decl : Iir) + is + Sig_Type_Def : constant Iir := Get_Type (Decl); + Sig_Type : O_Tnode; + Type_Info : Type_Info_Acc; + Info : Ortho_Info_Acc; + begin + Chap3.Translate_Object_Subtype (Decl); + + Type_Info := Get_Info (Sig_Type_Def); + Sig_Type := Get_Object_Type (Type_Info, Mode_Signal); + pragma Assert (Sig_Type /= O_Tnode_Null); + + Info := Add_Info (Decl, Kind_Object); + + Info.Object_Var := + Create_Var (Create_Var_Identifier (Decl), Sig_Type); + + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Rtis.Generate_Signal_Rti (Decl); + when Iir_Kind_Guard_Signal_Declaration => + -- No name created for guard signal. + null; + when others => + Error_Kind ("create_signal", Decl); + end case; + end Create_Signal; + + procedure Create_Implicit_Signal (Decl : Iir) + is + Sig_Type : O_Tnode; + Type_Info : Type_Info_Acc; + Info : Ortho_Info_Acc; + Sig_Type_Def : Iir; + begin + Sig_Type_Def := Get_Type (Decl); + -- This has been disabled since DECL can have an anonymous subtype, + -- and DECL has no identifiers, which causes translate_object_subtype + -- to crash. + -- Note: DECL can only be a iir_kind_delayed_attribute. + --Chap3.Translate_Object_Subtype (Decl); + Type_Info := Get_Info (Sig_Type_Def); + Sig_Type := Type_Info.Ortho_Type (Mode_Signal); + if Sig_Type = O_Tnode_Null then + raise Internal_Error; + end if; + + Info := Add_Info (Decl, Kind_Object); + + Info.Object_Var := Create_Var (Create_Uniq_Identifier, Sig_Type); + end Create_Implicit_Signal; + + procedure Create_File_Object (El : Iir_File_Declaration) + is + Obj_Type : O_Tnode; + Info : Ortho_Info_Acc; + Obj_Type_Def : Iir; + begin + Obj_Type_Def := Get_Type (El); + Obj_Type := Get_Ortho_Type (Obj_Type_Def, Mode_Value); + + Info := Add_Info (El, Kind_Object); + + Info.Object_Var := Create_Var (Create_Var_Identifier (El), Obj_Type); + end Create_File_Object; + + procedure Create_Package_Interface (Inter : Iir) + is + Info : Ortho_Info_Acc; + Pkg : constant Iir := Get_Named_Entity + (Get_Uninstantiated_Package_Name (Inter)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Pkg); + begin + Chap2.Instantiate_Info_Package (Inter); + Info := Get_Info (Inter); + + -- The spec + Info.Package_Instance_Spec_Var := + Create_Var (Create_Var_Identifier (Inter, "SPEC", 0), + Pkg_Info.Package_Spec_Ptr_Type); + Set_Scope_Via_Var_Ptr + (Info.Package_Instance_Spec_Scope, + Info.Package_Instance_Spec_Var); + + -- The body + Info.Package_Instance_Body_Var := + Create_Var (Create_Var_Identifier (Inter, "BODY", 0), + Pkg_Info.Package_Body_Ptr_Type); + Set_Scope_Via_Var_Ptr + (Info.Package_Instance_Body_Scope, + Info.Package_Instance_Body_Var); + end Create_Package_Interface; + + procedure Allocate_Complex_Object (Obj_Type : Iir; + Alloc_Kind : Allocation_Kind; + Var : in out Mnode) + is + Type_Info : constant Type_Info_Acc := Get_Type_Info (Var); + Kind : constant Object_Kind_Type := Get_Object_Kind (Var); + Targ : Mnode; + begin + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Cannot allocate unconstrained object (since size is unknown). + raise Internal_Error; + end if; + + if not Is_Complex_Type (Type_Info) then + -- Object is not complex. + return; + end if; + + if Type_Info.C (Kind).Builder_Need_Func + and then not Is_Stable (Var) + then + Targ := Create_Temp (Type_Info, Kind); + else + Targ := Var; + end if; + + -- Allocate variable. + New_Assign_Stmt + (M2Lp (Targ), + Gen_Alloc (Alloc_Kind, + Chap3.Get_Object_Size (Var, Obj_Type), + Type_Info.Ortho_Ptr_Type (Kind))); + + if Type_Info.C (Kind).Builder_Need_Func then + -- Build the type. + Chap3.Gen_Call_Type_Builder (Targ, Obj_Type); + if not Is_Stable (Var) then + New_Assign_Stmt (M2Lp (Var), M2Addr (Targ)); + Var := Targ; + end if; + end if; + end Allocate_Complex_Object; + + -- Note : OBJ can be a tree. + -- FIXME: should use translate_aggregate_others. + procedure Init_Array_Object (Obj : Mnode; Obj_Type : Iir) + is + Sobj : Mnode; + + -- Type of the object. + Type_Info : Type_Info_Acc; + + -- Iterator for the elements. + Index : O_Dnode; + + Upper_Limit : O_Enode; + Upper_Var : O_Dnode; + + Label : O_Snode; + begin + Type_Info := Get_Info (Obj_Type); + + -- Iterate on all elements of the object. + Open_Temp; + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Sobj := Stabilize (Obj); + else + Sobj := Obj; + end if; + Upper_Limit := Chap3.Get_Array_Length (Sobj, Obj_Type); + + if Type_Info.Type_Mode /= Type_Mode_Array then + Upper_Var := Create_Temp_Init (Ghdl_Index_Type, Upper_Limit); + else + Upper_Var := O_Dnode_Null; + end if; + + Index := Create_Temp (Ghdl_Index_Type); + Init_Var (Index); + Start_Loop_Stmt (Label); + if Upper_Var /= O_Dnode_Null then + Upper_Limit := New_Obj_Value (Upper_Var); + end if; + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Index), Upper_Limit, + Ghdl_Bool_Type)); + Init_Object (Chap3.Index_Base (Chap3.Get_Array_Base (Sobj), + Obj_Type, + New_Obj_Value (Index)), + Get_Element_Subtype (Obj_Type)); + Inc_Var (Index); + Finish_Loop_Stmt (Label); + + Close_Temp; + end Init_Array_Object; + + procedure Init_Protected_Object (Obj : Mnode; Obj_Type : Iir) + is + Assoc : O_Assoc_List; + Info : Type_Info_Acc; + begin + Info := Get_Info (Obj_Type); + + -- Call the initializer. + Start_Association (Assoc, Info.T.Prot_Init_Subprg); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance); + -- Use of M2Lp is a little bit fragile (not sure we get the + -- variable, but should work: we didn't stabilize it). + New_Assign_Stmt (M2Lp (Obj), New_Function_Call (Assoc)); + end Init_Protected_Object; + + procedure Fini_Protected_Object (Decl : Iir) + is + Obj : Mnode; + Assoc : O_Assoc_List; + Info : Type_Info_Acc; + begin + Info := Get_Info (Get_Type (Decl)); + + Obj := Chap6.Translate_Name (Decl); + -- Call the Finalizator. + Start_Association (Assoc, Info.T.Prot_Final_Subprg); + New_Association (Assoc, M2E (Obj)); + New_Procedure_Call (Assoc); + end Fini_Protected_Object; + + procedure Init_Object (Obj : Mnode; Obj_Type : Iir) + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (Obj); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + New_Assign_Stmt + (M2Lv (Obj), Chap14.Translate_Left_Type_Attribute (Obj_Type)); + when Type_Mode_Acc => + New_Assign_Stmt + (M2Lv (Obj), + New_Lit (New_Null_Access (Tinfo.Ortho_Type (Mode_Value)))); + when Type_Mode_Fat_Acc => + declare + Dinfo : Type_Info_Acc; + Sobj : Mnode; + begin + Open_Temp; + Sobj := Stabilize (Obj); + Dinfo := Get_Info (Get_Designated_Type (Obj_Type)); + New_Assign_Stmt + (New_Selected_Element (M2Lv (Sobj), + Dinfo.T.Bounds_Field (Mode_Value)), + New_Lit (New_Null_Access (Dinfo.T.Bounds_Ptr_Type))); + New_Assign_Stmt + (New_Selected_Element (M2Lv (Sobj), + Dinfo.T.Base_Field (Mode_Value)), + New_Lit (New_Null_Access + (Dinfo.T.Base_Ptr_Type (Mode_Value)))); + Close_Temp; + end; + when Type_Mode_Arrays => + Init_Array_Object (Obj, Obj_Type); + when Type_Mode_Record => + declare + Sobj : Mnode; + El : Iir_Element_Declaration; + List : Iir_List; + begin + Open_Temp; + Sobj := Stabilize (Obj); + List := Get_Elements_Declaration_List + (Get_Base_Type (Obj_Type)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Init_Object (Chap6.Translate_Selected_Element (Sobj, El), + Get_Type (El)); + end loop; + Close_Temp; + end; + when Type_Mode_Protected => + Init_Protected_Object (Obj, Obj_Type); + when Type_Mode_Unknown + | Type_Mode_File => + raise Internal_Error; + end case; + end Init_Object; + + procedure Elab_Object_Storage (Obj : Iir) + is + Obj_Type : constant Iir := Get_Type (Obj); + Obj_Info : constant Object_Info_Acc := Get_Info (Obj); + + Name_Node : Mnode; + + Type_Info : Type_Info_Acc; + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Chap3.Elab_Object_Subtype (Obj_Type); + + Type_Info := Get_Info (Obj_Type); + + -- FIXME: the object type may be a fat array! + -- FIXME: fat array + aggregate ? + + if Type_Info.Type_Mode = Type_Mode_Protected then + -- Protected object will be created by its INIT function. + return; + end if; + + if Is_Complex_Type (Type_Info) + and then Type_Info.Type_Mode /= Type_Mode_Fat_Array + then + -- FIXME: avoid allocation if the value is a string and + -- the object is a constant + Name_Node := Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value); + Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); + Allocate_Complex_Object (Obj_Type, Alloc_Kind, Name_Node); + end if; + end Elab_Object_Storage; + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir) + is + Obj_Type : constant Iir := Get_Type (Obj); + Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type); + Obj_Info : constant Object_Info_Acc := Get_Info (Obj); + + Name_Node : Mnode; + Value_Node : O_Enode; + + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); + + -- Note: no temporary variable region is created, as the allocation + -- may be performed on the stack. + + if Value = Null_Iir then + -- Performs default initialization. + Open_Temp; + Init_Object (Name, Obj_Type); + Close_Temp; + elsif Get_Kind (Value) = Iir_Kind_Aggregate then + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Allocate. + declare + Aggr_Type : Iir; + begin + Aggr_Type := Get_Type (Value); + Chap3.Create_Array_Subtype (Aggr_Type, True); + Name_Node := Stabilize (Name); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), + M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type))); + Chap3.Allocate_Fat_Array_Base + (Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type)); + end; + else + Name_Node := Name; + end if; + Chap7.Translate_Aggregate (Name_Node, Obj_Type, Value); + else + Value_Node := Chap7.Translate_Expression (Value, Obj_Type); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + declare + S : Mnode; + begin + Name_Node := Stabilize (Name); + S := Stabilize (E2M (Value_Node, Type_Info, Mode_Value)); + + if Get_Kind (Value) = Iir_Kind_String_Literal + and then Get_Kind (Obj) = Iir_Kind_Constant_Declaration + then + -- No need to allocate space for the object. + Copy_Fat_Pointer (Name_Node, S); + else + Chap3.Translate_Object_Allocation + (Name_Node, Alloc_Kind, Obj_Type, + Chap3.Get_Array_Bounds (S)); + Chap3.Translate_Object_Copy + (Name_Node, M2Addr (S), Obj_Type); + end if; + end; + else + Chap3.Translate_Object_Copy (Name, Value_Node, Obj_Type); + end if; + Destroy_Local_Transient_Types; + end if; + end Elab_Object_Init; + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Value (Obj : Iir; Value : Iir) + is + Name : Mnode; + begin + Elab_Object_Storage (Obj); + Name := Get_Var (Get_Info (Obj).Object_Var, + Get_Info (Get_Type (Obj)), Mode_Value); + Elab_Object_Init (Name, Obj, Value); + end Elab_Object_Value; + + -- Create code to elaborate OBJ. + procedure Elab_Object (Obj : Iir) + is + Value : Iir; + Obj1 : Iir; + begin + -- A locally static constant is pre-elaborated. + -- (only constant can be locally static). + if Get_Expr_Staticness (Obj) = Locally + and then Get_Deferred_Declaration (Obj) = Null_Iir + then + return; + end if; + + -- Set default value. + if Get_Kind (Obj) = Iir_Kind_Constant_Declaration then + if Get_Info (Obj).Object_Static then + return; + end if; + if Get_Deferred_Declaration_Flag (Obj) then + -- No code generation for a deferred constant. + return; + end if; + Obj1 := Get_Deferred_Declaration (Obj); + if Obj1 = Null_Iir then + Obj1 := Obj; + end if; + else + Obj1 := Obj; + end if; + + New_Debug_Line_Stmt (Get_Line_Number (Obj)); + + -- Still use the default value of the not deferred constant. + -- FIXME: what about composite types. + Value := Get_Default_Value (Obj); + Elab_Object_Value (Obj1, Value); + end Elab_Object; + + procedure Fini_Object (Obj : Iir) + is + Obj_Type : Iir; + Type_Info : Type_Info_Acc; + begin + Obj_Type := Get_Type (Obj); + Type_Info := Get_Info (Obj_Type); + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + declare + V : Mnode; + begin + Open_Temp; + V := Chap6.Translate_Name (Obj); + Stabilize (V); + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap3.Get_Array_Bounds (V)))); + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap3.Get_Array_Base (V)))); + Close_Temp; + end; + elsif Is_Complex_Type (Type_Info) then + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap6.Translate_Name (Obj)))); + end if; + end Fini_Object; + + function Get_Nbr_Signals (Sig : Mnode; Sig_Type : Iir) return O_Enode + is + Info : constant Type_Info_Acc := Get_Info (Sig_Type); + begin + case Info.Type_Mode is + when Type_Mode_Scalar => + -- Note: here we discard SIG... + return New_Lit (Ghdl_Index_1); + when Type_Mode_Arrays => + declare + Len : O_Dnode; + If_Blk : O_If_Block; + Ssig : Mnode; + begin + Ssig := Stabilize (Sig); + Len := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Array_Length (Ssig, Sig_Type)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Neq, + New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Len), + New_Dyadic_Op + (ON_Mul_Ov, + New_Obj_Value (Len), + Get_Nbr_Signals + (Chap3.Index_Base + (Chap3.Get_Array_Base (Ssig), Sig_Type, + New_Lit (Ghdl_Index_0)), + Get_Element_Subtype (Sig_Type)))); + Finish_If_Stmt (If_Blk); + + return New_Obj_Value (Len); + end; + when Type_Mode_Record => + declare + List : Iir_List; + El : Iir; + Res : O_Enode; + E : O_Enode; + Sig_El : Mnode; + Ssig : Mnode; + begin + List := + Get_Elements_Declaration_List (Get_Base_Type (Sig_Type)); + Ssig := Stabilize (Sig); + Res := O_Enode_Null; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Sig_El := Chap6.Translate_Selected_Element (Ssig, El); + E := Get_Nbr_Signals (Sig_El, Get_Type (El)); + if Res /= O_Enode_Null then + Res := New_Dyadic_Op (ON_Add_Ov, Res, E); + else + Res := E; + end if; + end loop; + if Res = O_Enode_Null then + -- Empty records. + Res := New_Lit (Ghdl_Index_0); + end if; + return Res; + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Get_Nbr_Signals; + + -- Get the leftest signal of SIG. + -- The leftest signal of + -- a scalar signal is itself, + -- an array signal is the leftest, + -- a record signal is the first element. + function Get_Leftest_Signal (Sig: Mnode; Sig_Type : Iir) + return Mnode + is + Res : Mnode; + Res_Type : Iir; + Info : Type_Info_Acc; + begin + Res := Sig; + Res_Type := Sig_Type; + loop + Info := Get_Type_Info (Res); + case Info.Type_Mode is + when Type_Mode_Scalar => + return Res; + when Type_Mode_Arrays => + Res := Chap3.Index_Base + (Chap3.Get_Array_Base (Res), Res_Type, + New_Lit (Ghdl_Index_0)); + Res_Type := Get_Element_Subtype (Res_Type); + when Type_Mode_Record => + declare + Element : Iir; + begin + Element := Get_First_Element + (Get_Elements_Declaration_List + (Get_Base_Type (Res_Type))); + Res := Chap6.Translate_Selected_Element (Res, Element); + Res_Type := Get_Type (Element); + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end loop; + end Get_Leftest_Signal; + + -- Add func and instance. + procedure Add_Associations_For_Resolver + (Assoc : in out O_Assoc_List; Func_Decl : Iir) + is + Func_Info : constant Subprg_Info_Acc := Get_Info (Func_Decl); + Resolv_Info : constant Subprg_Resolv_Info_Acc := + Func_Info.Subprg_Resolv; + Val : O_Enode; + begin + New_Association + (Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func, + Ghdl_Ptr_Type))); + if Chap2.Has_Subprg_Instance (Resolv_Info.Var_Instance) then + Val := New_Convert_Ov + (Chap2.Get_Subprg_Instance (Resolv_Info.Var_Instance), + Ghdl_Ptr_Type); + else + Val := New_Lit (New_Null_Access (Ghdl_Ptr_Type)); + end if; + New_Association (Assoc, Val); + end Add_Associations_For_Resolver; + + type O_If_Block_Acc is access O_If_Block; + + type Elab_Signal_Data is record + -- Default value of the signal. + Val : Mnode; + -- If statement for a block of signals. + If_Stmt : O_If_Block_Acc; + -- True if the default value is set. + Has_Val : Boolean; + -- True if a resolution function was already attached. + Already_Resolved : Boolean; + -- True if the signal may already have been created. + Check_Null : Boolean; + end record; + + procedure Elab_Signal_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Elab_Signal_Data) + is + Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type); + Create_Subprg : O_Dnode; + Conv : O_Tnode; + Res : O_Enode; + Assoc : O_Assoc_List; + Init_Val : O_Enode; + -- For the resolution function (if any). + Func : Iir; + If_Stmt : O_If_Block; + Targ_Ptr : O_Dnode; + begin + if Data.Check_Null then + Targ_Ptr := Create_Temp_Init + (Ghdl_Signal_Ptr_Ptr, + New_Unchecked_Address (M2Lv (Targ), Ghdl_Signal_Ptr_Ptr)); + Start_If_Stmt + (If_Stmt, + New_Compare_Op (ON_Eq, + New_Value (New_Acc_Value (New_Obj (Targ_Ptr))), + New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), + Ghdl_Bool_Type)); + end if; + + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Create_Subprg := Ghdl_Create_Signal_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Create_Subprg := Ghdl_Create_Signal_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Create_Subprg := Ghdl_Create_Signal_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Create_Subprg := Ghdl_Create_Signal_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Create_Subprg := Ghdl_Create_Signal_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Create_Subprg := Ghdl_Create_Signal_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("elab_signal_non_composite", Targ_Type); + end case; + + if Data.Has_Val then + Init_Val := M2E (Data.Val); + else + Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); + end if; + + Start_Association (Assoc, Create_Subprg); + New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); + + if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then + Func := Has_Resolution_Function (Targ_Type); + else + Func := Null_Iir; + end if; + if Func /= Null_Iir and then not Data.Already_Resolved then + Add_Associations_For_Resolver (Assoc, Func); + else + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end if; + + Res := New_Function_Call (Assoc); + + if Data.Check_Null then + New_Assign_Stmt (New_Acc_Value (New_Obj (Targ_Ptr)), Res); + Finish_If_Stmt (If_Stmt); + else + New_Assign_Stmt + (M2Lv (Targ), + New_Convert_Ov (Res, Type_Info.Ortho_Type (Mode_Signal))); + end if; + end Elab_Signal_Non_Composite; + + function Elab_Signal_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Elab_Signal_Data) + return Elab_Signal_Data + is + Assoc : O_Assoc_List; + Func : Iir; + Res : Elab_Signal_Data; + begin + Res := Data; + if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then + Func := Has_Resolution_Function (Targ_Type); + if Func /= Null_Iir and then not Data.Already_Resolved then + if Data.Check_Null then + Res.If_Stmt := new O_If_Block; + Start_If_Stmt + (Res.If_Stmt.all, + New_Compare_Op + (ON_Eq, + New_Convert_Ov (M2E (Get_Leftest_Signal (Targ, + Targ_Type)), + Ghdl_Signal_Ptr), + New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), + Ghdl_Bool_Type)); + --Res.Check_Null := False; + end if; + -- Add resolver. + Start_Association (Assoc, Ghdl_Signal_Create_Resolution); + Add_Associations_For_Resolver (Assoc, Func); + New_Association + (Assoc, New_Convert_Ov (M2Addr (Targ), Ghdl_Ptr_Type)); + New_Association (Assoc, Get_Nbr_Signals (Targ, Targ_Type)); + New_Procedure_Call (Assoc); + Res.Already_Resolved := True; + end if; + end if; + if Data.Has_Val then + if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then + Res.Val := Stabilize (Data.Val); + else + Res.Val := Chap3.Get_Array_Base (Data.Val); + end if; + end if; + return Res; + end Elab_Signal_Prepare_Composite; + + procedure Elab_Signal_Finish_Composite (Data : in out Elab_Signal_Data) + is + procedure Free is new Ada.Unchecked_Deallocation + (Object => O_If_Block, Name => O_If_Block_Acc); + begin + if Data.If_Stmt /= null then + Finish_If_Stmt (Data.If_Stmt.all); + Free (Data.If_Stmt); + end if; + end Elab_Signal_Finish_Composite; + + function Elab_Signal_Update_Array (Data : Elab_Signal_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Elab_Signal_Data + is + begin + if not Data.Has_Val then + return Data; + else + return Elab_Signal_Data' + (Val => Chap3.Index_Base (Data.Val, Targ_Type, + New_Obj_Value (Index)), + Has_Val => True, + If_Stmt => null, + Already_Resolved => Data.Already_Resolved, + Check_Null => Data.Check_Null); + end if; + end Elab_Signal_Update_Array; + + function Elab_Signal_Update_Record (Data : Elab_Signal_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Elab_Signal_Data + is + pragma Unreferenced (Targ_Type); + begin + if not Data.Has_Val then + return Data; + else + return Elab_Signal_Data' + (Val => Chap6.Translate_Selected_Element (Data.Val, El), + Has_Val => True, + If_Stmt => null, + Already_Resolved => Data.Already_Resolved, + Check_Null => Data.Check_Null); + end if; + end Elab_Signal_Update_Record; + + procedure Elab_Signal is new Foreach_Non_Composite + (Data_Type => Elab_Signal_Data, + Composite_Data_Type => Elab_Signal_Data, + Do_Non_Composite => Elab_Signal_Non_Composite, + Prepare_Data_Array => Elab_Signal_Prepare_Composite, + Update_Data_Array => Elab_Signal_Update_Array, + Finish_Data_Array => Elab_Signal_Finish_Composite, + Prepare_Data_Record => Elab_Signal_Prepare_Composite, + Update_Data_Record => Elab_Signal_Update_Record, + Finish_Data_Record => Elab_Signal_Finish_Composite); + + -- Elaborate signal subtypes and allocate the storage for the object. + procedure Elab_Signal_Declaration_Storage (Decl : Iir) + is + Sig_Type : Iir; + Type_Info : Type_Info_Acc; + Name_Node : Mnode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Open_Temp; + + Sig_Type := Get_Type (Decl); + Chap3.Elab_Object_Subtype (Sig_Type); + Type_Info := Get_Info (Sig_Type); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Name_Node := Chap6.Translate_Name (Decl); + Name_Node := Stabilize (Name_Node); + Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); + elsif Is_Complex_Type (Type_Info) then + Name_Node := Chap6.Translate_Name (Decl); + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + end if; + + Close_Temp; + end Elab_Signal_Declaration_Storage; + + function Has_Direct_Driver (Sig : Iir) return Boolean + is + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Get_Object_Prefix (Sig)); + return Info.Kind = Kind_Object + and then Info.Object_Driver /= Null_Var; + end Has_Direct_Driver; + + procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir) + is + Sig_Type : constant Iir := Get_Type (Decl); + Sig_Info : constant Ortho_Info_Acc := Get_Info (Decl); + Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type); + Name_Node : Mnode; + begin + Open_Temp; + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Name_Node := Get_Var (Sig_Info.Object_Driver, + Type_Info, Mode_Value); + Name_Node := Stabilize (Name_Node); + -- Copy bounds from signal. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), + M2Addr (Chap3.Get_Array_Bounds (Chap6.Translate_Name (Decl)))); + -- Allocate base. + Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); + elsif Is_Complex_Type (Type_Info) then + Name_Node := Get_Var (Sig_Info.Object_Driver, + Type_Info, Mode_Value); + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + end if; + + Close_Temp; + end Elab_Direct_Driver_Declaration_Storage; + + -- Create signal object. + -- Note: SIG can be a signal sub-element (used when signals are + -- collapsed). + -- If CHECK_NULL is TRUE, create the signal only if it was not yet + -- created. + procedure Elab_Signal_Declaration_Object + (Sig : Iir; Parent : Iir; Check_Null : Boolean) + is + Decl : constant Iir := Strip_Denoting_Name (Sig); + Sig_Type : constant Iir := Get_Type (Sig); + Base_Decl : constant Iir := Get_Object_Prefix (Sig); + Name_Node : Mnode; + Val : Iir; + Data : Elab_Signal_Data; + begin + New_Debug_Line_Stmt (Get_Line_Number (Sig)); + + Open_Temp; + + -- Set the name of the signal. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Name_Rti); + New_Association + (Assoc, + New_Lit (New_Global_Unchecked_Address + (Get_Info (Base_Decl).Object_Rti, + Rtis.Ghdl_Rti_Access))); + Rtis.Associate_Rti_Context (Assoc, Parent); + New_Procedure_Call (Assoc); + end; + + Name_Node := Chap6.Translate_Name (Decl); + if Get_Object_Kind (Name_Node) /= Mode_Signal then + raise Internal_Error; + end if; + + if Decl = Base_Decl then + Data.Already_Resolved := False; + Data.Check_Null := Check_Null; + Val := Get_Default_Value (Base_Decl); + if Val = Null_Iir then + Data.Has_Val := False; + else + Data.Has_Val := True; + Data.Val := E2M (Chap7.Translate_Expression (Val, Sig_Type), + Get_Info (Sig_Type), + Mode_Value); + end if; + else + -- Sub signal. + -- Do not add resolver. + -- Do not use default value. + Data.Already_Resolved := True; + Data.Has_Val := False; + Data.Check_Null := False; + end if; + Elab_Signal (Name_Node, Sig_Type, Data); + + Close_Temp; + end Elab_Signal_Declaration_Object; + + procedure Elab_Signal_Declaration + (Decl : Iir; Parent : Iir; Check_Null : Boolean) + is + begin + Elab_Signal_Declaration_Storage (Decl); + Elab_Signal_Declaration_Object (Decl, Parent, Check_Null); + end Elab_Signal_Declaration; + + procedure Elab_Signal_Attribute (Decl : Iir) + is + Assoc : O_Assoc_List; + Dtype : Iir; + Type_Info : Type_Info_Acc; + Info : Object_Info_Acc; + Prefix : Iir; + Prefix_Node : Mnode; + Res : O_Enode; + Val : O_Enode; + Param : Iir; + Subprg : O_Dnode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Info := Get_Info (Decl); + Dtype := Get_Type (Decl); + Type_Info := Get_Info (Dtype); + -- Create the signal (with the time) + case Get_Kind (Decl) is + when Iir_Kind_Stable_Attribute => + Subprg := Ghdl_Create_Stable_Signal; + when Iir_Kind_Quiet_Attribute => + Subprg := Ghdl_Create_Quiet_Signal; + when Iir_Kind_Transaction_Attribute => + Subprg := Ghdl_Create_Transaction_Signal; + when others => + Error_Kind ("elab_signal_attribute", Decl); + end case; + Start_Association (Assoc, Subprg); + case Get_Kind (Decl) is + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute => + Param := Get_Parameter (Decl); + if Param = Null_Iir then + Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); + else + Val := Chap7.Translate_Expression (Param); + end if; + New_Association (Assoc, Val); + when others => + null; + end case; + Res := New_Convert_Ov (New_Function_Call (Assoc), + Type_Info.Ortho_Type (Mode_Signal)); + New_Assign_Stmt (Get_Var (Info.Object_Var), Res); + + -- Register all signals this depends on. + Prefix := Get_Prefix (Decl); + Prefix_Node := Chap6.Translate_Name (Prefix); + Register_Signal (Prefix_Node, Get_Type (Prefix), + Ghdl_Signal_Attribute_Register_Prefix); + end Elab_Signal_Attribute; + + type Delayed_Signal_Data is record + Pfx : Mnode; + Param : Iir; + end record; + + procedure Create_Delayed_Signal_Noncomposite + (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) + is + pragma Unreferenced (Targ_Type); + Assoc : O_Assoc_List; + Type_Info : Type_Info_Acc; + Val : O_Enode; + begin + Start_Association (Assoc, Ghdl_Create_Delayed_Signal); + New_Association + (Assoc, + New_Convert_Ov (New_Value (M2Lv (Data.Pfx)), Ghdl_Signal_Ptr)); + if Data.Param = Null_Iir then + Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); + else + Val := Chap7.Translate_Expression (Data.Param); + end if; + New_Association (Assoc, Val); + Type_Info := Get_Type_Info (Targ); + New_Assign_Stmt + (M2Lv (Targ), + New_Convert_Ov (New_Function_Call (Assoc), + Type_Info.Ortho_Type (Mode_Signal))); + end Create_Delayed_Signal_Noncomposite; + + function Create_Delayed_Signal_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) + return Delayed_Signal_Data + is + pragma Unreferenced (Targ_Type); + Res : Delayed_Signal_Data; + begin + Res.Param := Data.Param; + if Get_Type_Info (Targ).Type_Mode = Type_Mode_Record then + Res.Pfx := Stabilize (Data.Pfx); + else + Res.Pfx := Chap3.Get_Array_Base (Data.Pfx); + end if; + return Res; + end Create_Delayed_Signal_Prepare_Composite; + + function Create_Delayed_Signal_Update_Data_Array + (Data : Delayed_Signal_Data; Targ_Type : Iir; Index : O_Dnode) + return Delayed_Signal_Data + is + begin + return Delayed_Signal_Data' + (Pfx => Chap3.Index_Base (Data.Pfx, Targ_Type, + New_Obj_Value (Index)), + Param => Data.Param); + end Create_Delayed_Signal_Update_Data_Array; + + function Create_Delayed_Signal_Update_Data_Record + (Data : Delayed_Signal_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Delayed_Signal_Data + is + pragma Unreferenced (Targ_Type); + begin + return Delayed_Signal_Data' + (Pfx => Chap6.Translate_Selected_Element (Data.Pfx, El), + Param => Data.Param); + end Create_Delayed_Signal_Update_Data_Record; + + procedure Create_Delayed_Signal_Finish_Data_Composite + (Data : in out Delayed_Signal_Data) + is + pragma Unreferenced (Data); + begin + null; + end Create_Delayed_Signal_Finish_Data_Composite; + + procedure Create_Delayed_Signal is new Foreach_Non_Composite + (Data_Type => Delayed_Signal_Data, + Composite_Data_Type => Delayed_Signal_Data, + Do_Non_Composite => Create_Delayed_Signal_Noncomposite, + Prepare_Data_Array => Create_Delayed_Signal_Prepare_Composite, + Update_Data_Array => Create_Delayed_Signal_Update_Data_Array, + Finish_Data_Array => Create_Delayed_Signal_Finish_Data_Composite, + Prepare_Data_Record => Create_Delayed_Signal_Prepare_Composite, + Update_Data_Record => Create_Delayed_Signal_Update_Data_Record, + Finish_Data_Record => Create_Delayed_Signal_Finish_Data_Composite); + + procedure Elab_Signal_Delayed_Attribute (Decl : Iir) + is + Name_Node : Mnode; + Sig_Type : Iir; + Type_Info : Type_Info_Acc; + Pfx_Node : Mnode; + Data: Delayed_Signal_Data; + begin + Name_Node := Chap6.Translate_Name (Decl); + Sig_Type := Get_Type (Decl); + Type_Info := Get_Info (Sig_Type); + + if Is_Complex_Type (Type_Info) then + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + -- We cannot stabilize NAME_NODE, since Allocate_Complex_Object + -- assign it. + Name_Node := Chap6.Translate_Name (Decl); + end if; + + Pfx_Node := Chap6.Translate_Name (Get_Prefix (Decl)); + Data := Delayed_Signal_Data'(Pfx => Pfx_Node, + Param => Get_Parameter (Decl)); + + Create_Delayed_Signal (Name_Node, Get_Type (Decl), Data); + end Elab_Signal_Delayed_Attribute; + + procedure Elab_File_Declaration (Decl : Iir_File_Declaration) + is + Constr : O_Assoc_List; + Name : Mnode; + File_Name : Iir; + Open_Kind : Iir; + Mode_Val : O_Enode; + Str : O_Enode; + Is_Text : Boolean; + Info : Type_Info_Acc; + begin + -- Elaborate the file. + Name := Chap6.Translate_Name (Decl); + if Get_Object_Kind (Name) /= Mode_Value then + raise Internal_Error; + end if; + Is_Text := Get_Text_File_Flag (Get_Type (Decl)); + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Elaborate); + else + Start_Association (Constr, Ghdl_File_Elaborate); + Info := Get_Info (Get_Type (Decl)); + if Info.T.File_Signature /= O_Dnode_Null then + New_Association + (Constr, New_Address (New_Obj (Info.T.File_Signature), + Char_Ptr_Type)); + else + New_Association (Constr, + New_Lit (New_Null_Access (Char_Ptr_Type))); + end if; + end if; + New_Assign_Stmt (M2Lv (Name), New_Function_Call (Constr)); + + -- If file_open_information is present, open the file. + File_Name := Get_File_Logical_Name (Decl); + if File_Name = Null_Iir then + return; + end if; + Open_Temp; + Name := Chap6.Translate_Name (Decl); + Open_Kind := Get_File_Open_Kind (Decl); + if Open_Kind /= Null_Iir then + Mode_Val := New_Convert_Ov + (Chap7.Translate_Expression (Open_Kind), Ghdl_I32_Type); + else + case Get_Mode (Decl) is + when Iir_In_Mode => + Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0)); + when Iir_Out_Mode => + Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1)); + when others => + raise Internal_Error; + end case; + end if; + Str := Chap7.Translate_Expression (File_Name, String_Type_Definition); + + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Open); + else + Start_Association (Constr, Ghdl_File_Open); + end if; + New_Association (Constr, M2E (Name)); + New_Association (Constr, Mode_Val); + New_Association (Constr, Str); + New_Procedure_Call (Constr); + Close_Temp; + end Elab_File_Declaration; + + procedure Final_File_Declaration (Decl : Iir_File_Declaration) + is + Constr : O_Assoc_List; + Name : Mnode; + Is_Text : Boolean; + begin + Is_Text := Get_Text_File_Flag (Get_Type (Decl)); + + Open_Temp; + Name := Chap6.Translate_Name (Decl); + Stabilize (Name); + + -- LRM 3.4.1 File Operations + -- An implicit call to FILE_CLOSE exists in a subprogram body for + -- every file object declared in the corresponding subprogram + -- declarative part. Each such call associates a unique file object + -- with the formal parameter F and is called whenever the + -- corresponding subprogram completes its execution. + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Close); + else + Start_Association (Constr, Ghdl_File_Close); + end if; + New_Association (Constr, M2E (Name)); + New_Procedure_Call (Constr); + + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Finalize); + else + Start_Association (Constr, Ghdl_File_Finalize); + end if; + New_Association (Constr, M2E (Name)); + New_Procedure_Call (Constr); + + Close_Temp; + end Final_File_Declaration; + + procedure Translate_Type_Declaration (Decl : Iir) + is + begin + Chap3.Translate_Named_Type_Definition (Get_Type_Definition (Decl), + Get_Identifier (Decl)); + end Translate_Type_Declaration; + + procedure Translate_Anonymous_Type_Declaration (Decl : Iir) + is + Mark : Id_Mark_Type; + Mark1 : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark1, "BT"); + Chap3.Translate_Type_Definition (Get_Type_Definition (Decl)); + Pop_Identifier_Prefix (Mark1); + Pop_Identifier_Prefix (Mark); + end Translate_Anonymous_Type_Declaration; + + procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration) + is + begin + Chap3.Translate_Named_Type_Definition (Get_Type (Decl), + Get_Identifier (Decl)); + end Translate_Subtype_Declaration; + + procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Chap3.Translate_Bool_Type_Definition (Get_Type_Definition (Decl)); + Pop_Identifier_Prefix (Mark); + end Translate_Bool_Type_Declaration; + + procedure Translate_Object_Alias_Declaration + (Decl : Iir_Object_Alias_Declaration) + is + Decl_Type : Iir; + Info : Alias_Info_Acc; + Tinfo : Type_Info_Acc; + Atype : O_Tnode; + begin + Decl_Type := Get_Type (Decl); + + Chap3.Translate_Named_Type_Definition + (Decl_Type, Get_Identifier (Decl)); + + Info := Add_Info (Decl, Kind_Alias); + case Get_Kind (Get_Object_Prefix (Decl)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + Info.Alias_Kind := Mode_Signal; + when others => + Info.Alias_Kind := Mode_Value; + end case; + + Tinfo := Get_Info (Decl_Type); + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + -- create an object. + -- At elaboration: copy base from name, copy bounds from type, + -- check for matching bounds. + Atype := Get_Ortho_Type (Decl_Type, Info.Alias_Kind); + when Type_Mode_Array + | Type_Mode_Acc + | Type_Mode_Fat_Acc => + -- Create an object pointer. + -- At elaboration: copy base from name. + Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); + when Type_Mode_Scalar => + case Info.Alias_Kind is + when Mode_Signal => + Atype := Tinfo.Ortho_Type (Mode_Signal); + when Mode_Value => + Atype := Tinfo.Ortho_Ptr_Type (Mode_Value); + end case; + when Type_Mode_Record => + -- Create an object pointer. + -- At elaboration: copy base from name. + Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); + when others => + raise Internal_Error; + end case; + Info.Alias_Var := Create_Var (Create_Var_Identifier (Decl), Atype); + end Translate_Object_Alias_Declaration; + + procedure Elab_Object_Alias_Declaration + (Decl : Iir_Object_Alias_Declaration) + is + Decl_Type : Iir; + Name : Iir; + Name_Node : Mnode; + Alias_Node : Mnode; + Alias_Info : Alias_Info_Acc; + Name_Type : Iir; + Tinfo : Type_Info_Acc; + Kind : Object_Kind_Type; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Decl_Type := Get_Type (Decl); + Tinfo := Get_Info (Decl_Type); + + Alias_Info := Get_Info (Decl); + Chap3.Elab_Object_Subtype (Decl_Type); + Name := Get_Name (Decl); + Name_Type := Get_Type (Name); + Name_Node := Chap6.Translate_Name (Name); + Kind := Get_Object_Kind (Name_Node); + + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + Open_Temp; + Stabilize (Name_Node); + Alias_Node := Stabilize + (Get_Var (Alias_Info.Alias_Var, + Tinfo, Alias_Info.Alias_Kind)); + Copy_Fat_Pointer (Alias_Node, Name_Node); + Close_Temp; + when Type_Mode_Array => + Open_Temp; + Stabilize (Name_Node); + New_Assign_Stmt + (Get_Var (Alias_Info.Alias_Var), + M2E (Chap3.Get_Array_Base (Name_Node))); + Chap3.Check_Array_Match (Decl_Type, T2M (Decl_Type, Kind), + Name_Type, Name_Node, + Decl); + Close_Temp; + when Type_Mode_Acc + | Type_Mode_Fat_Acc => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + when Type_Mode_Scalar => + case Alias_Info.Alias_Kind is + when Mode_Value => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + when Mode_Signal => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2E (Name_Node)); + end case; + when Type_Mode_Record => + Open_Temp; + Stabilize (Name_Node); + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + Close_Temp; + when others => + raise Internal_Error; + end case; + end Elab_Object_Alias_Declaration; + + procedure Translate_Port_Chain (Parent : Iir) + is + Port : Iir; + begin + Port := Get_Port_Chain (Parent); + while Port /= Null_Iir loop + Create_Signal (Port); + Port := Get_Chain (Port); + end loop; + end Translate_Port_Chain; + + procedure Translate_Generic_Chain (Parent : Iir) + is + Decl : Iir; + begin + Decl := Get_Generic_Chain (Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kinds_Interface_Object_Declaration => + Create_Object (Decl); + when Iir_Kind_Interface_Package_Declaration => + Create_Package_Interface (Decl); + when others => + Error_Kind ("translate_generic_chain", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Translate_Generic_Chain; + + -- Create instance record for a component. + procedure Translate_Component_Declaration (Decl : Iir) + is + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Decl, Kind_Component); + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Instance_Factory (Info.Comp_Scope'Access); + + Info.Comp_Link := Add_Instance_Factory_Field + (Wki_Instance, Rtis.Ghdl_Component_Link_Type); + + -- Generic and ports. + Translate_Generic_Chain (Decl); + Translate_Port_Chain (Decl); + + Pop_Instance_Factory (Info.Comp_Scope'Access); + New_Type_Decl (Create_Identifier ("_COMPTYPE"), + Get_Scope_Type (Info.Comp_Scope)); + Info.Comp_Ptr_Type := New_Access_Type + (Get_Scope_Type (Info.Comp_Scope)); + New_Type_Decl (Create_Identifier ("_COMPPTR"), Info.Comp_Ptr_Type); + Pop_Identifier_Prefix (Mark); + end Translate_Component_Declaration; + + procedure Translate_Declaration (Decl : Iir) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + null; + + when Iir_Kind_Component_Declaration => + Chap4.Translate_Component_Declaration (Decl); + when Iir_Kind_Type_Declaration => + Chap4.Translate_Type_Declaration (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Chap4.Translate_Anonymous_Type_Declaration (Decl); + when Iir_Kind_Subtype_Declaration => + Chap4.Translate_Subtype_Declaration (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + raise Internal_Error; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + + when Iir_Kind_Protected_Type_Body => + null; + + --when Iir_Kind_Implicit_Function_Declaration => + --when Iir_Kind_Signal_Declaration + -- | Iir_Kind_Interface_Signal_Declaration => + -- Chap4.Create_Object (Decl); + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration => + Create_Object (Decl); + + when Iir_Kind_Signal_Declaration => + Create_Signal (Decl); + + when Iir_Kind_Object_Alias_Declaration => + Translate_Object_Alias_Declaration (Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_File_Declaration => + Create_File_Object (Decl); + + when Iir_Kind_Attribute_Declaration => + -- Useless as attribute declarations have a type mark. + Chap3.Translate_Object_Subtype (Decl); + + when Iir_Kind_Attribute_Specification => + Chap5.Translate_Attribute_Specification (Decl); + + when Iir_Kinds_Signal_Attribute => + Chap4.Create_Implicit_Signal (Decl); + + when Iir_Kind_Guard_Signal_Declaration => + Create_Signal (Decl); + + when Iir_Kind_Group_Template_Declaration => + null; + when Iir_Kind_Group_Declaration => + null; + + when others => + Error_Kind ("translate_declaration", Decl); + end case; + end Translate_Declaration; + + procedure Translate_Resolution_Function (Func : Iir) + is + -- Type of the resolution function parameter. + El_Type : Iir; + El_Info : Type_Info_Acc; + Finfo : constant Subprg_Info_Acc := Get_Info (Func); + Interface_List : O_Inter_List; + Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; + Id : O_Ident; + Itype : O_Tnode; + Unused_Instance : O_Dnode; + begin + if Rinfo = null then + -- Not a resolution function + return; + end if; + + -- Declare the procedure. + Id := Create_Identifier (Func, Get_Overload_Number (Func), "_RESOLV"); + Start_Procedure_Decl (Interface_List, Id, Global_Storage); + + -- The instance. + if Chap2.Has_Current_Subprg_Instance then + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, + Rinfo.Var_Instance); + else + -- Create a dummy instance parameter + New_Interface_Decl (Interface_List, Unused_Instance, + Wki_Instance, Ghdl_Ptr_Type); + Rinfo.Var_Instance := Chap2.Null_Subprg_Instance; + end if; + + -- The signal. + El_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + El_Type := Get_Element_Subtype (El_Type); + El_Info := Get_Info (El_Type); + -- FIXME: create a function for getting the type of an interface. + case El_Info.Type_Mode is + when Type_Mode_Thin => + Itype := El_Info.Ortho_Type (Mode_Signal); + when Type_Mode_Fat => + Itype := El_Info.Ortho_Ptr_Type (Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + New_Interface_Decl + (Interface_List, Rinfo.Var_Vals, Get_Identifier ("VALS"), Itype); + + New_Interface_Decl + (Interface_List, Rinfo.Var_Vec, Get_Identifier ("bool_vec"), + Ghdl_Bool_Array_Ptr); + New_Interface_Decl + (Interface_List, Rinfo.Var_Vlen, Get_Identifier ("vec_len"), + Ghdl_Index_Type); + New_Interface_Decl + (Interface_List, Rinfo.Var_Nbr_Drv, Get_Identifier ("nbr_drv"), + Ghdl_Index_Type); + New_Interface_Decl + (Interface_List, Rinfo.Var_Nbr_Ports, Get_Identifier ("nbr_ports"), + Ghdl_Index_Type); + + Finish_Subprogram_Decl (Interface_List, Rinfo.Resolv_Func); + end Translate_Resolution_Function; + + type Read_Source_Kind is (Read_Port, Read_Driver); + type Read_Source_Data is record + Sig : Mnode; + Drv_Index : O_Dnode; + Kind : Read_Source_Kind; + end record; + + procedure Read_Source_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) + is + Assoc : O_Assoc_List; + Targ_Info : Type_Info_Acc; + E : O_Enode; + begin + Targ_Info := Get_Info (Targ_Type); + case Data.Kind is + when Read_Port => + Start_Association (Assoc, Ghdl_Signal_Read_Port); + when Read_Driver => + Start_Association (Assoc, Ghdl_Signal_Read_Driver); + end case; + + New_Association + (Assoc, New_Convert_Ov (M2E (Data.Sig), Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Drv_Index)); + E := New_Convert_Ov (New_Function_Call (Assoc), + Targ_Info.Ortho_Ptr_Type (Mode_Value)); + New_Assign_Stmt (M2Lv (Targ), + New_Value (New_Access_Element (E))); + end Read_Source_Non_Composite; + + function Read_Source_Prepare_Data_Array + (Targ: Mnode; Targ_Type : Iir; Data : Read_Source_Data) + return Read_Source_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Read_Source_Prepare_Data_Array; + + function Read_Source_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) + return Read_Source_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Read_Source_Data'(Sig => Stabilize (Data.Sig), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Prepare_Data_Record; + + function Read_Source_Update_Data_Array + (Data : Read_Source_Data; Targ_Type : Iir; Index : O_Dnode) + return Read_Source_Data + is + begin + return Read_Source_Data' + (Sig => Chap3.Index_Base (Data.Sig, Targ_Type, + New_Obj_Value (Index)), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Update_Data_Array; + + function Read_Source_Update_Data_Record + (Data : Read_Source_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Read_Source_Data + is + pragma Unreferenced (Targ_Type); + begin + return Read_Source_Data' + (Sig => Chap6.Translate_Selected_Element (Data.Sig, El), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Update_Data_Record; + + procedure Read_Source_Finish_Data_Composite + (Data : in out Read_Source_Data) + is + pragma Unreferenced (Data); + begin + null; + end Read_Source_Finish_Data_Composite; + + procedure Read_Signal_Source is new Foreach_Non_Composite + (Data_Type => Read_Source_Data, + Composite_Data_Type => Read_Source_Data, + Do_Non_Composite => Read_Source_Non_Composite, + Prepare_Data_Array => Read_Source_Prepare_Data_Array, + Update_Data_Array => Read_Source_Update_Data_Array, + Finish_Data_Array => Read_Source_Finish_Data_Composite, + Prepare_Data_Record => Read_Source_Prepare_Data_Record, + Update_Data_Record => Read_Source_Update_Data_Record, + Finish_Data_Record => Read_Source_Finish_Data_Composite); + + procedure Translate_Resolution_Function_Body (Func : Iir) + is + -- Type of the resolution function parameter. + Arr_Type : Iir; + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Index_Info : Index_Info_Acc; + + -- Type of parameter element. + El_Type : Iir; + El_Info : Type_Info_Acc; + + -- Type of the function return value. + Ret_Type : Iir; + Ret_Info : Type_Info_Acc; + + -- Type and info of the array index. + Index_Type : Iir; + Index_Tinfo : Type_Info_Acc; + + -- Local variables. + Var_I : O_Dnode; + Var_J : O_Dnode; + Var_Length : O_Dnode; + Var_Res : O_Dnode; + + Vals : Mnode; + Res : Mnode; + + If_Blk : O_If_Block; + Label : O_Snode; + + V : Mnode; + + Var_Bound : O_Dnode; + Var_Range_Ptr : O_Dnode; + Var_Array : O_Dnode; + Finfo : constant Subprg_Info_Acc := Get_Info (Func); + Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; + Assoc : O_Assoc_List; + + Data : Read_Source_Data; + begin + if Rinfo = null then + -- No resolver for this function + return; + end if; + + Ret_Type := Get_Return_Type (Func); + Ret_Info := Get_Info (Ret_Type); + + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + Base_Type := Get_Base_Type (Arr_Type); + Index_Info := Get_Info + (Get_First_Element (Get_Index_Subtype_Definition_List (Base_Type))); + Base_Info := Get_Info (Base_Type); + + El_Type := Get_Element_Subtype (Arr_Type); + El_Info := Get_Info (El_Type); + + Index_Type := Get_Index_Type (Arr_Type, 0); + Index_Tinfo := Get_Info (Index_Type); + + Start_Subprogram_Body (Rinfo.Resolv_Func); + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Start_Subprg_Instance_Use (Rinfo.Var_Instance); + end if; + Push_Local_Factory; + + -- A signal. + + New_Var_Decl + (Var_Res, Get_Identifier ("res"), + O_Storage_Local, Get_Object_Type (Ret_Info, Mode_Value)); + + -- I, J. + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_J, Get_Identifier ("J"), + O_Storage_Local, Ghdl_Index_Type); + + -- Length. + New_Var_Decl + (Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + + New_Var_Decl (Var_Bound, Get_Identifier ("BOUND"), O_Storage_Local, + Base_Info.T.Bounds_Type); + New_Var_Decl (Var_Array, Get_Identifier ("ARRAY"), O_Storage_Local, + Base_Info.Ortho_Type (Mode_Value)); + + New_Var_Decl (Var_Range_Ptr, Get_Identifier ("RANGE_PTR"), + O_Storage_Local, Index_Tinfo.T.Range_Ptr_Type); + + Open_Temp; + + case El_Info.Type_Mode is + when Type_Mode_Thin => + Vals := Dv2M (Rinfo.Var_Vals, El_Info, Mode_Signal); + when Type_Mode_Fat => + Vals := Dp2M (Rinfo.Var_Vals, El_Info, Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + + -- * length := vec_len + nports; + New_Assign_Stmt (New_Obj (Var_Length), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Rinfo.Var_Vlen), + New_Obj_Value (Rinfo.Var_Nbr_Ports))); + + -- * range_ptr := BOUND.dim_1'address; + New_Assign_Stmt + (New_Obj (Var_Range_Ptr), + New_Address (New_Selected_Element (New_Obj (Var_Bound), + Index_Info.Index_Field), + Index_Tinfo.T.Range_Ptr_Type)); + + -- Create range from length + Chap3.Create_Range_From_Length + (Index_Type, Var_Length, Var_Range_Ptr, Func); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Var_Array), + Base_Info.T.Bounds_Field (Mode_Value)), + New_Address (New_Obj (Var_Bound), Base_Info.T.Bounds_Ptr_Type)); + + -- Allocate the array. + Chap3.Allocate_Fat_Array_Base + (Alloc_Stack, Dv2M (Var_Array, Base_Info, Mode_Value), Base_Type); + + -- Fill the array + -- 1. From ports. + -- * I := 0; + Init_Var (Var_I); + -- * loop + Start_Loop_Stmt (Label); + -- * exit when I = nports; + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Obj_Value (Rinfo.Var_Nbr_Ports), + Ghdl_Bool_Type)); + -- fill array[i] + V := Chap3.Index_Base + (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), + Base_Type, New_Obj_Value (Var_I)); + Data := Read_Source_Data'(Vals, Var_I, Read_Port); + Read_Signal_Source (V, El_Type, Data); + + -- * I := I + 1; + Inc_Var (Var_I); + -- * end loop; + Finish_Loop_Stmt (Label); + + -- 2. From drivers. + -- * J := 0; + -- * loop + -- * exit when j = var_max; + -- * if vec[j] then + -- + -- * ptr := get_signal_driver (sig, j); + -- * array[i].XXX := *ptr + -- + -- * i := i + 1; + -- * end if; + -- * J := J + 1; + -- * end loop; + Init_Var (Var_J); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_J), + New_Obj_Value (Rinfo.Var_Nbr_Drv), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk, + New_Value (New_Indexed_Acc_Value (New_Obj (Rinfo.Var_Vec), + New_Obj_Value (Var_J)))); + + V := Chap3.Index_Base + (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), + Base_Type, New_Obj_Value (Var_I)); + Data := Read_Source_Data'(Vals, Var_J, Read_Driver); + Read_Signal_Source (V, El_Type, Data); + + Inc_Var (Var_I); + Finish_If_Stmt (If_Blk); + + Inc_Var (Var_J); + Finish_Loop_Stmt (Label); + + if Finfo.Res_Interface /= O_Dnode_Null then + Res := Lo2M (Var_Res, Ret_Info, Mode_Value); + if Ret_Info.Type_Mode /= Type_Mode_Fat_Array then + Allocate_Complex_Object (Ret_Type, Alloc_Stack, Res); + end if; + end if; + + -- Call the resolution function. + if Finfo.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + Start_Association (Assoc, Finfo.Ortho_Func); + if Finfo.Res_Interface /= O_Dnode_Null then + New_Association (Assoc, M2E (Res)); + end if; + Chap2.Add_Subprg_Instance_Assoc (Assoc, Finfo.Subprg_Instance); + New_Association + (Assoc, New_Address (New_Obj (Var_Array), + Base_Info.Ortho_Ptr_Type (Mode_Value))); + + if Finfo.Res_Interface = O_Dnode_Null then + Res := E2M (New_Function_Call (Assoc), Ret_Info, Mode_Value); + else + New_Procedure_Call (Assoc); + end if; + + if El_Type /= Ret_Type then + Res := E2M + (Chap7.Translate_Implicit_Conv (M2E (Res), Ret_Type, El_Type, + Mode_Value, Func), + El_Info, Mode_Value); + end if; + Chap7.Set_Driving_Value (Vals, El_Type, Res); + + Close_Temp; + Pop_Local_Factory; + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Finish_Subprg_Instance_Use (Rinfo.Var_Instance); + end if; + Finish_Subprogram_Body; + end Translate_Resolution_Function_Body; + + procedure Translate_Declaration_Chain (Parent : Iir) + is + Info : Subprg_Info_Acc; + El : Iir; + begin + El := Get_Declaration_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + -- Translate interfaces. + if (not Flag_Discard_Unused or else Get_Use_Flag (El)) + and then not Is_Second_Subprogram_Specification (El) + then + Info := Add_Info (El, Kind_Subprg); + Chap2.Translate_Subprogram_Interfaces (El); + if Get_Kind (El) = Iir_Kind_Function_Declaration then + if Get_Resolution_Function_Flag (El) then + Info.Subprg_Resolv := new Subprg_Resolv_Info; + end if; + end if; + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + when others => + Translate_Declaration (El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Declaration_Chain; + + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir) + is + El : Iir; + Infos : Chap7.Implicit_Subprogram_Infos; + begin + El := Get_Declaration_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + -- Translate only if used. + if Get_Info (El) /= null then + Chap2.Translate_Subprogram_Declaration (El); + Translate_Resolution_Function (El); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- Do not translate body if generating only specs (for + -- subprograms in an entity). + if Global_Storage /= O_Storage_External + and then + (not Flag_Discard_Unused + or else + Get_Use_Flag (Get_Subprogram_Specification (El))) + then + Chap2.Translate_Subprogram_Body (El); + Translate_Resolution_Function_Body + (Get_Subprogram_Specification (El)); + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Chap3.Translate_Type_Subprograms (El); + Chap7.Init_Implicit_Subprogram_Infos (Infos); + when Iir_Kind_Protected_Type_Body => + Chap3.Translate_Protected_Type_Body (El); + Chap3.Translate_Protected_Type_Body_Subprograms (El); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + if Flag_Discard_Unused_Implicit + and then not Get_Use_Flag (El) + then + case Get_Implicit_Definition (El) is + when Iir_Predefined_Array_Equality + | Iir_Predefined_Array_Greater + | Iir_Predefined_Record_Equality => + -- Used implicitly in case statement or other + -- predefined equality. + Chap7.Translate_Implicit_Subprogram (El, Infos); + when others => + null; + end case; + else + Chap7.Translate_Implicit_Subprogram (El, Infos); + end if; + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Translate_Declaration_Chain_Subprograms; + + procedure Elab_Declaration_Chain (Parent : Iir; Need_Final : out Boolean) + is + Decl : Iir; + begin + Decl := Get_Declaration_Chain (Parent); + Need_Final := False; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + Chap5.Elab_Disconnection_Specification (Decl); + + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Chap3.Elab_Type_Declaration (Decl); + when Iir_Kind_Subtype_Declaration => + Chap3.Elab_Subtype_Declaration (Decl); + + when Iir_Kind_Protected_Type_Body => + null; + + --when Iir_Kind_Signal_Declaration => + -- Chap1.Elab_Signal (Decl); + when Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration => + Elab_Object (Decl); + if Get_Kind (Get_Type (Decl)) + = Iir_Kind_Protected_Type_Declaration + then + Need_Final := True; + end if; + + when Iir_Kind_Signal_Declaration => + Elab_Signal_Declaration (Decl, Parent, False); + + when Iir_Kind_Object_Alias_Declaration => + Elab_Object_Alias_Declaration (Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_File_Declaration => + Elab_File_Declaration (Decl); + Need_Final := True; + + when Iir_Kind_Attribute_Declaration => + Chap3.Elab_Object_Subtype (Get_Type (Decl)); + + when Iir_Kind_Attribute_Specification => + Chap5.Elab_Attribute_Specification (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Info (Decl) /= null then + Chap2.Elab_Subprogram_Interfaces (Decl); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute => + Elab_Signal_Attribute (Decl); + + when Iir_Kind_Delayed_Attribute => + Elab_Signal_Delayed_Attribute (Decl); + + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + + when others => + Error_Kind ("elab_declaration_chain", Decl); + end case; + + Decl := Get_Chain (Decl); + end loop; + end Elab_Declaration_Chain; + + procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean) + is + Decl : Iir; + begin + Decl := Get_Declaration_Chain (Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_File_Declaration => + Final_File_Declaration (Decl); + when Iir_Kind_Variable_Declaration => + if Get_Kind (Get_Type (Decl)) + = Iir_Kind_Protected_Type_Declaration + then + Fini_Protected_Object (Decl); + end if; + if Deallocate then + Fini_Object (Decl); + end if; + when Iir_Kind_Constant_Declaration => + if Deallocate then + Fini_Object (Decl); + end if; + when others => + null; + end case; + + Decl := Get_Chain (Decl); + end loop; + end Final_Declaration_Chain; + + type Conv_Mode is (Conv_Mode_In, Conv_Mode_Out); + + -- Create subprogram for an association conversion. + -- STMT is the statement/block_header containing the association. + -- BLOCK is the architecture/block containing the instance. + -- ASSOC is the association and MODE the conversion to work on. + -- CONV_INFO is the result place holder. + -- BASE_BLOCK is the base architecture/block containing the instance. + -- ENTITY is the entity/component instantiated (null for block_stmt) + procedure Translate_Association_Subprogram + (Stmt : Iir; + Block : Iir; + Assoc : Iir; + Mode : Conv_Mode; + Conv_Info : in out Assoc_Conv_Info; + Base_Block : Iir; + Entity : Iir) + is + Formal : constant Iir := Get_Formal (Assoc); + Actual : constant Iir := Get_Actual (Assoc); + + Mark2, Mark3 : Id_Mark_Type; + Inter_List : O_Inter_List; + In_Type, Out_Type : Iir; + In_Info, Out_Info : Type_Info_Acc; + Itype : O_Tnode; + El_List : O_Element_List; + Block_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt_Info : Block_Info_Acc; + Entity_Info : Ortho_Info_Acc; + Var_Data : O_Dnode; + + -- Variables for body. + E : O_Enode; + V : O_Dnode; + V1 : O_Lnode; + V_Out : Mnode; + R : O_Enode; + Constr : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + Res : Mnode; + Imp : Iir; + Func : Iir; + begin + case Mode is + when Conv_Mode_In => + -- IN: from actual to formal. + Push_Identifier_Prefix (Mark2, "CONVIN"); + Out_Type := Get_Type (Formal); + In_Type := Get_Type (Actual); + Imp := Get_In_Conversion (Assoc); + + when Conv_Mode_Out => + -- OUT: from formal to actual. + Push_Identifier_Prefix (Mark2, "CONVOUT"); + In_Type := Get_Type (Formal); + Out_Type := Get_Type (Actual); + Imp := Get_Out_Conversion (Assoc); + + end case; + -- FIXME: individual assoc -> overload. + Push_Identifier_Prefix + (Mark3, Get_Identifier (Get_Association_Interface (Assoc))); + + -- Handle anonymous subtypes. + Chap3.Translate_Anonymous_Type_Definition (Out_Type, False); + Chap3.Translate_Anonymous_Type_Definition (In_Type, False); + Out_Info := Get_Info (Out_Type); + In_Info := Get_Info (In_Type); + + -- Start record containing data for the conversion function. + Start_Record_Type (El_List); + + -- Add instance field. + Conv_Info.Instance_Block := Base_Block; + New_Record_Field + (El_List, Conv_Info.Instance_Field, Wki_Instance, + Block_Info.Block_Decls_Ptr_Type); + + if Entity /= Null_Iir then + Conv_Info.Instantiated_Entity := Entity; + Entity_Info := Get_Info (Entity); + declare + Ptr : O_Tnode; + begin + if Entity_Info.Kind = Kind_Component then + Ptr := Entity_Info.Comp_Ptr_Type; + else + Ptr := Entity_Info.Block_Decls_Ptr_Type; + end if; + New_Record_Field + (El_List, Conv_Info.Instantiated_Field, + Get_Identifier ("instantiated"), Ptr); + end; + else + Conv_Info.Instantiated_Entity := Null_Iir; + Conv_Info.Instantiated_Field := O_Fnode_Null; + end if; + + -- Add input. + case In_Info.Type_Mode is + when Type_Mode_Thin => + Itype := In_Info.Ortho_Type (Mode_Signal); + when Type_Mode_Fat => + Itype := In_Info.Ortho_Ptr_Type (Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + New_Record_Field + (El_List, Conv_Info.In_Field, Get_Identifier ("val_in"), Itype); + + -- Add output. + New_Record_Field + (El_List, Conv_Info.Out_Field, Get_Identifier ("val_out"), + Get_Object_Type (Out_Info, Mode_Signal)); + Finish_Record_Type (El_List, Conv_Info.Record_Type); + New_Type_Decl (Create_Identifier ("DTYPE"), Conv_Info.Record_Type); + Conv_Info.Record_Ptr_Type := New_Access_Type (Conv_Info.Record_Type); + New_Type_Decl (Create_Identifier ("DPTR"), Conv_Info.Record_Ptr_Type); + + -- Declare the subprogram. + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Private); + New_Interface_Decl + (Inter_List, Var_Data, Get_Identifier ("data"), + Conv_Info.Record_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Conv_Info.Subprg); + + Start_Subprogram_Body (Conv_Info.Subprg); + Push_Local_Factory; + Open_Temp; + + -- Add an access to local block. + V := Create_Temp_Init + (Block_Info.Block_Decls_Ptr_Type, + New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Instance_Field)); + Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope, V); + + -- Add an access to instantiated entity. + -- This may be used to do some type checks. + if Conv_Info.Instantiated_Entity /= Null_Iir then + declare + Ptr_Type : O_Tnode; + begin + if Entity_Info.Kind = Kind_Component then + Ptr_Type := Entity_Info.Comp_Ptr_Type; + else + Ptr_Type := Entity_Info.Block_Decls_Ptr_Type; + end if; + V := Create_Temp_Init + (Ptr_Type, + New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Instantiated_Field)); + if Entity_Info.Kind = Kind_Component then + Set_Scope_Via_Param_Ptr (Entity_Info.Comp_Scope, V); + else + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V); + end if; + end; + end if; + + -- Add access to the instantiation-specific data. + -- This is used only for anonymous subtype variables. + -- FIXME: what if STMT is a binding_indication ? + Stmt_Info := Get_Info (Stmt); + if Stmt_Info /= null + and then Has_Scope_Type (Stmt_Info.Block_Scope) + then + Set_Scope_Via_Field (Stmt_Info.Block_Scope, + Stmt_Info.Block_Parent_Field, + Get_Info (Block).Block_Scope'Access); + end if; + + -- Read signal value. + E := New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.In_Field); + case Mode is + when Conv_Mode_In => + R := Chap7.Translate_Signal_Effective_Value (E, In_Type); + when Conv_Mode_Out => + R := Chap7.Translate_Signal_Driving_Value (E, In_Type); + end case; + + case Get_Kind (Imp) is + when Iir_Kind_Function_Call => + Func := Get_Implementation (Imp); + R := Chap7.Translate_Implicit_Conv + (R, In_Type, + Get_Type (Get_Interface_Declaration_Chain (Func)), + Mode_Value, Assoc); + + -- Create result value. + Subprg_Info := Get_Info (Func); + + if Subprg_Info.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + -- If we need to allocate, do it before starting the call! + declare + Res_Type : constant Iir := Get_Return_Type (Func); + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + begin + Res := Create_Temp (Res_Info); + if Res_Info.Type_Mode /= Type_Mode_Fat_Array then + Chap4.Allocate_Complex_Object + (Res_Type, Alloc_Stack, Res); + end if; + end; + end if; + + -- Call conversion function. + Start_Association (Constr, Subprg_Info.Ortho_Func); + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Association (Constr, M2E (Res)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Subprg_Info.Subprg_Instance); + + New_Association (Constr, R); + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + E := M2E (Res); + else + E := New_Function_Call (Constr); + end if; + Res := E2M + (Chap7.Translate_Implicit_Conv + (E, Get_Return_Type (Func), + Out_Type, Mode_Value, Imp), + Get_Info (Out_Type), Mode_Value); + + when Iir_Kind_Type_Conversion => + declare + Conv_Type : Iir; + begin + Conv_Type := Get_Type (Imp); + E := Chap7.Translate_Type_Conversion + (R, In_Type, Conv_Type, Assoc); + E := Chap7.Translate_Implicit_Conv + (E, Conv_Type, Out_Type, Mode_Value, Imp); + Res := E2M (E, Get_Info (Out_Type), Mode_Value); + end; + + when others => + Error_Kind ("Translate_Association_Subprogram", Imp); + end case; + + -- Assign signals. + V1 := New_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Out_Field); + V_Out := Lo2M (V1, Out_Info, Mode_Signal); + + case Mode is + when Conv_Mode_In => + Chap7.Set_Effective_Value (V_Out, Out_Type, Res); + when Conv_Mode_Out => + Chap7.Set_Driving_Value (V_Out, Out_Type, Res); + end case; + + Close_Temp; + if Stmt_Info /= null + and then Has_Scope_Type (Stmt_Info.Block_Scope) + then + Clear_Scope (Stmt_Info.Block_Scope); + end if; + if Conv_Info.Instantiated_Entity /= Null_Iir then + if Entity_Info.Kind = Kind_Component then + Clear_Scope (Entity_Info.Comp_Scope); + else + Clear_Scope (Entity_Info.Block_Scope); + end if; + end if; + Clear_Scope (Block_Info.Block_Scope); + + Pop_Local_Factory; + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark3); + Pop_Identifier_Prefix (Mark2); + end Translate_Association_Subprogram; + + -- ENTITY is null for block_statement. + procedure Translate_Association_Subprograms + (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir) + is + Assoc : Iir; + Info : Assoc_Info_Acc; + begin + Assoc := Get_Port_Map_Aspect_Chain (Stmt); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression + then + Info := null; + if Get_In_Conversion (Assoc) /= Null_Iir then + Info := Add_Info (Assoc, Kind_Assoc); + Translate_Association_Subprogram + (Stmt, Block, Assoc, Conv_Mode_In, Info.Assoc_In, + Base_Block, Entity); + end if; + if Get_Out_Conversion (Assoc) /= Null_Iir then + if Info = null then + Info := Add_Info (Assoc, Kind_Assoc); + end if; + Translate_Association_Subprogram + (Stmt, Block, Assoc, Conv_Mode_Out, Info.Assoc_Out, + Base_Block, Entity); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + end Translate_Association_Subprograms; + + procedure Elab_Conversion (Sig_In : Iir; + Sig_Out : Iir; + Reg_Subprg : O_Dnode; + Info : Assoc_Conv_Info; + Ndest : out Mnode) + is + Out_Type : Iir; + Out_Info : Type_Info_Acc; + Ssig : Mnode; + Constr : O_Assoc_List; + Var_Data : O_Dnode; + Data : Elab_Signal_Data; + begin + Out_Type := Get_Type (Sig_Out); + Out_Info := Get_Info (Out_Type); + + -- Allocate data for the subprogram. + Var_Data := Create_Temp (Info.Record_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Data), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Info.Record_Type, + Ghdl_Index_Type)), + Info.Record_Ptr_Type)); + + -- Set instance. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), Info.Instance_Field), + Get_Instance_Access (Info.Instance_Block)); + + -- Set instantiated unit instance (if any). + if Info.Instantiated_Entity /= Null_Iir then + declare + Inst_Addr : O_Enode; + Inst_Info : Ortho_Info_Acc; + begin + if Get_Kind (Info.Instantiated_Entity) + = Iir_Kind_Component_Declaration + then + Inst_Info := Get_Info (Info.Instantiated_Entity); + Inst_Addr := New_Address + (Get_Instance_Ref (Inst_Info.Comp_Scope), + Inst_Info.Comp_Ptr_Type); + else + Inst_Addr := Get_Instance_Access (Info.Instantiated_Entity); + end if; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Instantiated_Field), + Inst_Addr); + end; + end if; + + -- Set input. + Ssig := Chap6.Translate_Name (Sig_In); + Ssig := Stabilize (Ssig, True); + + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), Info.In_Field), + M2E (Ssig)); + + -- Create a copy of SIG_OUT. + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Chap4.Allocate_Complex_Object (Out_Type, Alloc_System, Ndest); + -- Note: NDEST will be assigned by ELAB_SIGNAL. + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Data := Elab_Signal_Data'(Has_Val => False, + Already_Resolved => True, + Val => Mnode_Null, + Check_Null => False, + If_Stmt => null); + Elab_Signal (Ndest, Out_Type, Data); + + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Ndest := Stabilize (Ndest, True); + + -- Register. + Start_Association (Constr, Reg_Subprg); + New_Association + (Constr, New_Lit (New_Subprogram_Address (Info.Subprg, + Ghdl_Ptr_Type))); + New_Association + (Constr, New_Convert_Ov (New_Obj_Value (Var_Data), Ghdl_Ptr_Type)); + + New_Association + (Constr, + New_Convert_Ov (M2E (Get_Leftest_Signal (Ssig, Get_Type (Sig_In))), + Ghdl_Signal_Ptr)); + New_Association (Constr, Get_Nbr_Signals (Ssig, Get_Type (Sig_In))); + + New_Association + (Constr, + New_Convert_Ov + (M2E (Get_Leftest_Signal (Ndest, Get_Type (Sig_Out))), + Ghdl_Signal_Ptr)); + New_Association (Constr, Get_Nbr_Signals (Ndest, Get_Type (Sig_Out))); + + New_Procedure_Call (Constr); + end Elab_Conversion; + + -- In conversion: from actual to formal. + procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode) + is + Assoc_Info : Assoc_Info_Acc; + begin + Assoc_Info := Get_Info (Assoc); + + Elab_Conversion + (Get_Actual (Assoc), Get_Formal (Assoc), + Ghdl_Signal_In_Conversion, Assoc_Info.Assoc_In, Ndest); + end Elab_In_Conversion; + + -- Out conversion: from formal to actual. + procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode) + is + Assoc_Info : Assoc_Info_Acc; + begin + Assoc_Info := Get_Info (Assoc); + + Elab_Conversion + (Get_Formal (Assoc), Get_Actual (Assoc), + Ghdl_Signal_Out_Conversion, Assoc_Info.Assoc_Out, Ndest); + end Elab_Out_Conversion; + + -- Create a record that describe thes location of an IIR node and + -- returns the address of it. + function Get_Location (N : Iir) return O_Dnode + is + Constr : O_Record_Aggr_List; + Aggr : O_Cnode; + Name : Name_Id; + Line : Natural; + Col : Natural; + C : O_Dnode; + begin + Files_Map.Location_To_Position (Get_Location (N), Name, Line, Col); + + New_Const_Decl (C, Create_Uniq_Identifier, O_Storage_Private, + Ghdl_Location_Type_Node); + Start_Const_Value (C); + Start_Record_Aggr (Constr, Ghdl_Location_Type_Node); + New_Record_Aggr_El + (Constr, New_Global_Address (Current_Filename_Node, Char_Ptr_Type)); + New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Line))); + New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Col))); + Finish_Record_Aggr (Constr, Aggr); + Finish_Const_Value (C, Aggr); + + return C; + --return New_Global_Address (C, Ghdl_Location_Ptr_Node); + end Get_Location; + end Chap4; + + package body Chap5 is + procedure Translate_Attribute_Specification + (Spec : Iir_Attribute_Specification) + is + Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + Atinfo : constant Type_Info_Acc := Get_Info (Get_Type (Attr)); + Mark : Id_Mark_Type; + Info : Object_Info_Acc; + begin + Push_Identifier_Prefix_Uniq (Mark); + Info := Add_Info (Spec, Kind_Object); + Info.Object_Var := Create_Var + (Create_Var_Identifier (Attr), + Chap4.Get_Object_Type (Atinfo, Mode_Value), + Global_Storage); + Pop_Identifier_Prefix (Mark); + end Translate_Attribute_Specification; + + procedure Elab_Attribute_Specification + (Spec : Iir_Attribute_Specification) + is + Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + begin + -- Kludge + Set_Info (Attr, Get_Info (Spec)); + Chap4.Elab_Object_Value (Attr, Get_Expression (Spec)); + Clear_Info (Attr); + end Elab_Attribute_Specification; + + procedure Gen_Elab_Disconnect_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Time : O_Dnode) + is + pragma Unreferenced (Targ_Type); + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Set_Disconnect); + New_Association + (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Time)); + New_Procedure_Call (Assoc); + end Gen_Elab_Disconnect_Non_Composite; + + function Gen_Elab_Disconnect_Prepare + (Targ : Mnode; Targ_Type : Iir; Time : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Time; + end Gen_Elab_Disconnect_Prepare; + + function Gen_Elab_Disconnect_Update_Data_Array (Time : O_Dnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ_Type, Index); + begin + return Time; + end Gen_Elab_Disconnect_Update_Data_Array; + + function Gen_Elab_Disconnect_Update_Data_Record + (Time : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Dnode + is + pragma Unreferenced (Targ_Type, El); + begin + return Time; + end Gen_Elab_Disconnect_Update_Data_Record; + + procedure Gen_Elab_Disconnect_Finish_Data_Composite + (Data : in out O_Dnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Elab_Disconnect_Finish_Data_Composite; + + procedure Gen_Elab_Disconnect is new Foreach_Non_Composite + (Data_Type => O_Dnode, + Composite_Data_Type => O_Dnode, + Do_Non_Composite => Gen_Elab_Disconnect_Non_Composite, + Prepare_Data_Array => Gen_Elab_Disconnect_Prepare, + Update_Data_Array => Gen_Elab_Disconnect_Update_Data_Array, + Finish_Data_Array => Gen_Elab_Disconnect_Finish_Data_Composite, + Prepare_Data_Record => Gen_Elab_Disconnect_Prepare, + Update_Data_Record => Gen_Elab_Disconnect_Update_Data_Record, + Finish_Data_Record => Gen_Elab_Disconnect_Finish_Data_Composite); + + procedure Elab_Disconnection_Specification + (Spec : Iir_Disconnection_Specification) + is + Val : O_Dnode; + List : constant Iir_List := Get_Signal_List (Spec); + El : Iir; + begin + Val := Create_Temp_Init + (Std_Time_Otype, + Chap7.Translate_Expression (Get_Expression (Spec))); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Gen_Elab_Disconnect (Chap6.Translate_Name (El), + Get_Type (El), Val); + end loop; + end Elab_Disconnection_Specification; + + type Connect_Mode is + ( + -- Actual is a source for the formal. + Connect_Source, + + -- Both. + Connect_Both, + + -- Effective value of actual is the effective value of the formal. + Connect_Effective, + + -- Actual is a value. + Connect_Value + ); + + type Connect_Data is record + Actual_Node : Mnode; + Actual_Type : Iir; + + -- Mode of the connection. + Mode : Connect_Mode; + + -- If true, formal signal is a copy of the actual. + By_Copy : Boolean; + end record; + + -- Connect_effective: FORMAL is set from ACTUAL. + -- Connect_Source: ACTUAL is set from FORMAL (source of ACTUAL). + procedure Connect_Scalar (Formal_Node : Mnode; + Formal_Type : Iir; + Data : Connect_Data) + is + Act_Node, Form_Node : Mnode; + begin + if Data.By_Copy then + New_Assign_Stmt (M2Lv (Formal_Node), M2E (Data.Actual_Node)); + return; + end if; + + case Data.Mode is + when Connect_Both => + Open_Temp; + Act_Node := Stabilize (Data.Actual_Node, True); + Form_Node := Stabilize (Formal_Node, True); + when Connect_Source + | Connect_Effective => + Act_Node := Data.Actual_Node; + Form_Node := Formal_Node; + when Connect_Value => + null; + end case; + + if Data.Mode in Connect_Source .. Connect_Both then + -- Formal is a source to actual. + declare + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Add_Source); + New_Association (Constr, New_Convert_Ov (M2E (Act_Node), + Ghdl_Signal_Ptr)); + New_Association (Constr, New_Convert_Ov (M2E (Form_Node), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode in Connect_Both .. Connect_Effective then + -- The effective value of formal is the effective value of actual. + declare + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Effective_Value); + New_Association (Constr, New_Convert_Ov (M2E (Form_Node), + Ghdl_Signal_Ptr)); + New_Association (Constr, New_Convert_Ov (M2E (Act_Node), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode = Connect_Value then + declare + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Constr : O_Assoc_List; + Conv : O_Tnode; + begin + Type_Info := Get_Info (Formal_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Associate_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Associate_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Associate_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 => + Subprg := Ghdl_Signal_Associate_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_Signal_Associate_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Associate_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("connect_scalar", Formal_Type); + end case; + Start_Association (Constr, Subprg); + New_Association (Constr, + New_Convert_Ov (New_Value (M2Lv (Formal_Node)), + Ghdl_Signal_Ptr)); + New_Association (Constr, + New_Convert_Ov (M2E (Data.Actual_Node), Conv)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode = Connect_Both then + Close_Temp; + end if; + end Connect_Scalar; + + function Connect_Prepare_Data_Composite + (Targ : Mnode; Formal_Type : Iir; Data : Connect_Data) + return Connect_Data + is + pragma Unreferenced (Targ, Formal_Type); + Res : Connect_Data; + Atype : Iir; + begin + Atype := Get_Base_Type (Data.Actual_Type); + if Get_Kind (Atype) = Iir_Kind_Record_Type_Definition then + Res := Data; + Stabilize (Res.Actual_Node); + return Res; + else + return Data; + end if; + end Connect_Prepare_Data_Composite; + + function Connect_Update_Data_Array (Data : Connect_Data; + Formal_Type : Iir; + Index : O_Dnode) + return Connect_Data + is + pragma Unreferenced (Formal_Type); + Res : Connect_Data; + begin + -- FIXME: should check matching elements! + Res := (Actual_Node => + Chap3.Index_Base (Chap3.Get_Array_Base (Data.Actual_Node), + Data.Actual_Type, New_Obj_Value (Index)), + Actual_Type => Get_Element_Subtype (Data.Actual_Type), + Mode => Data.Mode, + By_Copy => Data.By_Copy); + return Res; + end Connect_Update_Data_Array; + + function Connect_Update_Data_Record (Data : Connect_Data; + Formal_Type : Iir; + El : Iir_Element_Declaration) + return Connect_Data + is + pragma Unreferenced (Formal_Type); + Res : Connect_Data; + begin + Res := (Actual_Node => + Chap6.Translate_Selected_Element (Data.Actual_Node, El), + Actual_Type => Get_Type (El), + Mode => Data.Mode, + By_Copy => Data.By_Copy); + return Res; + end Connect_Update_Data_Record; + + procedure Connect_Finish_Data_Composite (Data : in out Connect_Data) + is + pragma Unreferenced (Data); + begin + null; + end Connect_Finish_Data_Composite; + + procedure Connect is new Foreach_Non_Composite + (Data_Type => Connect_Data, + Composite_Data_Type => Connect_Data, + Do_Non_Composite => Connect_Scalar, + Prepare_Data_Array => Connect_Prepare_Data_Composite, + Update_Data_Array => Connect_Update_Data_Array, + Finish_Data_Array => Connect_Finish_Data_Composite, + Prepare_Data_Record => Connect_Prepare_Data_Composite, + Update_Data_Record => Connect_Update_Data_Record, + Finish_Data_Record => Connect_Finish_Data_Composite); + + procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir) + is + Act_Node : Mnode; + Bounds : Mnode; + Tinfo : Type_Info_Acc; + Bound_Var : O_Dnode; + Actual_Type : Iir; + begin + Actual_Type := Get_Type (Actual); + Open_Temp; + if Is_Fully_Constrained_Type (Actual_Type) then + Chap3.Create_Array_Subtype (Actual_Type, False); + Tinfo := Get_Info (Actual_Type); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + if Get_Alloc_Kind_For_Var (Tinfo.T.Array_Bounds) = Alloc_Stack then + -- We need a copy. + Bound_Var := Create_Temp (Tinfo.T.Bounds_Ptr_Type); + New_Assign_Stmt + (New_Obj (Bound_Var), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Tinfo.T.Bounds_Ptr_Type)); + Gen_Memcpy (New_Obj_Value (Bound_Var), + M2Addr (Bounds), + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, + Ghdl_Index_Type))); + Bounds := Dp2M (Bound_Var, Tinfo, Mode_Value, + Tinfo.T.Bounds_Type, + Tinfo.T.Bounds_Ptr_Type); + end if; + else + Bounds := Chap3.Get_Array_Bounds (Chap6.Translate_Name (Actual)); + end if; + Act_Node := Chap6.Translate_Name (Port); + New_Assign_Stmt + (-- FIXME: this works only because it is not stabilized, + -- and therefore the bounds field is returned and not + -- a pointer to the bounds. + M2Lp (Chap3.Get_Array_Bounds (Act_Node)), + M2Addr (Bounds)); + Close_Temp; + end Elab_Unconstrained_Port; + + -- Return TRUE if EXPR is a signal name. + function Is_Signal (Expr : Iir) return Boolean + is + Obj : Iir; + begin + Obj := Sem_Names.Name_To_Object (Expr); + if Obj /= Null_Iir then + return Is_Signal_Object (Obj); + else + return False; + end if; + end Is_Signal; + + procedure Elab_Port_Map_Aspect_Assoc (Assoc : Iir; By_Copy : Boolean) + is + Formal : constant Iir := Get_Formal (Assoc); + Actual : constant Iir := Get_Actual (Assoc); + Formal_Type : constant Iir := Get_Type (Formal); + Actual_Type : constant Iir := Get_Type (Actual); + Inter : constant Iir := Get_Association_Interface (Assoc); + Formal_Node, Actual_Node : Mnode; + Data : Connect_Data; + Mode : Connect_Mode; + begin + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + raise Internal_Error; + end if; + + Open_Temp; + if Get_In_Conversion (Assoc) = Null_Iir + and then Get_Out_Conversion (Assoc) = Null_Iir + then + Formal_Node := Chap6.Translate_Name (Formal); + if Get_Object_Kind (Formal_Node) /= Mode_Signal then + raise Internal_Error; + end if; + if Is_Signal (Actual) then + -- LRM93 4.3.1.2 + -- For a signal of a scalar type, each source is either + -- a driver or an OUT, INOUT, BUFFER or LINKAGE port of + -- a component instance or of a block statement with + -- which the signalis associated. + + -- LRM93 12.6.2 + -- For a scalar signal S, the effective value of S is + -- determined in the following manner: + -- * If S is [...] a port of mode BUFFER or [...], + -- then the effective value of S is the same as + -- the driving value of S. + -- * If S is a connected port of mode IN or INOUT, + -- then the effective value of S is the same as + -- the effective value of the actual part of the + -- association element that associates an actual + -- with S. + -- * [...] + case Get_Mode (Inter) is + when Iir_In_Mode => + Mode := Connect_Effective; + when Iir_Inout_Mode => + Mode := Connect_Both; + when Iir_Out_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + Mode := Connect_Source; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + + -- translate actual (abort if not a signal). + Actual_Node := Chap6.Translate_Name (Actual); + if Get_Object_Kind (Actual_Node) /= Mode_Signal then + raise Internal_Error; + end if; + else + declare + Actual_Val : O_Enode; + begin + Actual_Val := Chap7.Translate_Expression + (Actual, Formal_Type); + Actual_Node := E2M + (Actual_Val, Get_Info (Formal_Type), Mode_Value); + Mode := Connect_Value; + end; + end if; + + if Get_Kind (Formal_Type) in Iir_Kinds_Array_Type_Definition + then + -- Check length matches. + Stabilize (Formal_Node); + Stabilize (Actual_Node); + Chap3.Check_Array_Match (Formal_Type, Formal_Node, + Actual_Type, Actual_Node, + Assoc); + end if; + + Data := (Actual_Node => Actual_Node, + Actual_Type => Actual_Type, + Mode => Mode, + By_Copy => By_Copy); + Connect (Formal_Node, Formal_Type, Data); + else + if Get_In_Conversion (Assoc) /= Null_Iir then + Chap4.Elab_In_Conversion (Assoc, Actual_Node); + Formal_Node := Chap6.Translate_Name (Formal); + Data := (Actual_Node => Actual_Node, + Actual_Type => Formal_Type, + Mode => Connect_Effective, + By_Copy => False); + Connect (Formal_Node, Formal_Type, Data); + end if; + if Get_Out_Conversion (Assoc) /= Null_Iir then + -- flow: FORMAL to ACTUAL + Chap4.Elab_Out_Conversion (Assoc, Formal_Node); + Actual_Node := Chap6.Translate_Name (Actual); + Data := (Actual_Node => Actual_Node, + Actual_Type => Actual_Type, + Mode => Connect_Source, + By_Copy => False); + Connect (Formal_Node, Actual_Type, Data); + end if; + end if; + + Close_Temp; + end Elab_Port_Map_Aspect_Assoc; + + -- Return TRUE if the collapse_signal_flag is set for each individual + -- association. + function Inherit_Collapse_Flag (Assoc : Iir) return Boolean + is + El : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Individual => + El := Get_Individual_Association_Chain (Assoc); + while El /= Null_Iir loop + if Inherit_Collapse_Flag (El) = False then + return False; + end if; + El := Get_Chain (El); + end loop; + return True; + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_Name => + El := Assoc; + while El /= Null_Iir loop + if not Inherit_Collapse_Flag (Get_Associated_Expr (Assoc)) + then + return False; + end if; + El := Get_Chain (El); + end loop; + return True; + when Iir_Kind_Association_Element_By_Expression => + return Get_Collapse_Signal_Flag (Assoc); + when others => + Error_Kind ("inherit_collapse_flag", Assoc); + end case; + end Inherit_Collapse_Flag; + + procedure Elab_Generic_Map_Aspect (Mapping : Iir) + is + Assoc : Iir; + Formal : Iir; + begin + -- Elab generics, and associate. + Assoc := Get_Generic_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Open_Temp; + Formal := Get_Formal (Assoc); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + declare + Targ : Mnode; + begin + if Get_Whole_Association_Flag (Assoc) then + Chap4.Elab_Object_Storage (Formal); + Targ := Chap6.Translate_Name (Formal); + Chap4.Elab_Object_Init + (Targ, Formal, Get_Actual (Assoc)); + else + Targ := Chap6.Translate_Name (Formal); + Chap7.Translate_Assign + (Targ, Get_Actual (Assoc), Get_Type (Formal)); + end if; + end; + when Iir_Kind_Association_Element_Open => + Chap4.Elab_Object_Value (Formal, Get_Default_Value (Formal)); + when Iir_Kind_Association_Element_By_Individual => + -- Create the object. + declare + Formal_Type : constant Iir := Get_Type (Formal); + Obj_Info : constant Object_Info_Acc := Get_Info (Formal); + Obj_Type : constant Iir := Get_Actual_Type (Assoc); + Formal_Node : Mnode; + Type_Info : Type_Info_Acc; + Bounds : Mnode; + begin + Chap3.Elab_Object_Subtype (Formal_Type); + Type_Info := Get_Info (Formal_Type); + Formal_Node := Get_Var + (Obj_Info.Object_Var, Type_Info, Mode_Value); + Stabilize (Formal_Node); + if Obj_Type = Null_Iir then + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc_System, Formal_Node); + else + Chap3.Create_Array_Subtype (Obj_Type, False); + Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type); + Chap3.Translate_Object_Allocation + (Formal_Node, Alloc_System, Formal_Type, Bounds); + end if; + end; + when Iir_Kind_Association_Element_Package => + pragma Assert (Get_Kind (Formal) = + Iir_Kind_Interface_Package_Declaration); + declare + Uninst_Pkg : constant Iir := Get_Named_Entity + (Get_Uninstantiated_Package_Name (Formal)); + Uninst_Info : constant Ortho_Info_Acc := + Get_Info (Uninst_Pkg); + Formal_Info : constant Ortho_Info_Acc := + Get_Info (Formal); + Actual : constant Iir := Get_Named_Entity + (Get_Actual (Assoc)); + Actual_Info : constant Ortho_Info_Acc := + Get_Info (Actual); + begin + New_Assign_Stmt + (Get_Var (Formal_Info.Package_Instance_Spec_Var), + New_Address + (Get_Instance_Ref + (Actual_Info.Package_Instance_Spec_Scope), + Uninst_Info.Package_Spec_Ptr_Type)); + New_Assign_Stmt + (Get_Var (Formal_Info.Package_Instance_Body_Var), + New_Address + (Get_Instance_Ref + (Actual_Info.Package_Instance_Body_Scope), + Uninst_Info.Package_Body_Ptr_Type)); + end; + when others => + Error_Kind ("elab_generic_map_aspect(1)", Assoc); + end case; + Close_Temp; + Assoc := Get_Chain (Assoc); + end loop; + end Elab_Generic_Map_Aspect; + + procedure Elab_Port_Map_Aspect (Mapping : Iir; Block_Parent : Iir) + is + Assoc : Iir; + Formal : Iir; + Formal_Base : Iir; + Fb_Type : Iir; + Fbt_Info : Type_Info_Acc; + Collapse_Individual : Boolean := False; + begin + -- Ports. + Assoc := Get_Port_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + Formal_Base := Get_Association_Interface (Assoc); + Fb_Type := Get_Type (Formal_Base); + + Open_Temp; + -- Set bounds of unconstrained ports. + Fbt_Info := Get_Info (Fb_Type); + if Fbt_Info.Type_Mode = Type_Mode_Fat_Array then + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + Elab_Unconstrained_Port (Formal, Get_Actual (Assoc)); + end if; + when Iir_Kind_Association_Element_Open => + declare + Actual_Type : Iir; + Bounds : Mnode; + Formal_Node : Mnode; + begin + Actual_Type := + Get_Type (Get_Default_Value (Formal_Base)); + Chap3.Create_Array_Subtype (Actual_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Formal_Node := Chap6.Translate_Name (Formal); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), + M2Addr (Bounds)); + end; + when Iir_Kind_Association_Element_By_Individual => + declare + Actual_Type : Iir; + Bounds : Mnode; + Formal_Node : Mnode; + begin + Actual_Type := Get_Actual_Type (Assoc); + Chap3.Create_Array_Subtype (Actual_Type, False); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Formal_Node := Chap6.Translate_Name (Formal); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), + M2Addr (Bounds)); + end; + when others => + Error_Kind ("elab_map_aspect(2)", Assoc); + end case; + end if; + Close_Temp; + + -- Allocate storage of ports. + Open_Temp; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open => + Chap4.Elab_Signal_Declaration_Storage (Formal); + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + Chap4.Elab_Signal_Declaration_Storage (Formal); + end if; + when others => + Error_Kind ("elab_map_aspect(3)", Assoc); + end case; + Close_Temp; + + -- Create or copy signals. + Open_Temp; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + if Get_Collapse_Signal_Flag (Assoc) then + -- For collapsed association, copy signals. + Elab_Port_Map_Aspect_Assoc (Assoc, True); + else + -- Create non-collapsed signals. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + -- And associate. + Elab_Port_Map_Aspect_Assoc (Assoc, False); + end if; + else + -- By sub-element. + -- Either the whole signal is collapsed or it was already + -- created. + -- And associate. + Elab_Port_Map_Aspect_Assoc (Assoc, Collapse_Individual); + end if; + when Iir_Kind_Association_Element_Open => + -- Create non-collapsed signals. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + when Iir_Kind_Association_Element_By_Individual => + -- Inherit the collapse flag. + -- If it is set for all sub-associations, continue. + -- Otherwise, create signals and do not collapse. + -- FIXME: this may be slightly optimized. + if not Inherit_Collapse_Flag (Assoc) then + -- Create the formal. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + Collapse_Individual := False; + else + Collapse_Individual := True; + end if; + when others => + Error_Kind ("elab_map_aspect(4)", Assoc); + end case; + Close_Temp; + + Assoc := Get_Chain (Assoc); + end loop; + end Elab_Port_Map_Aspect; + + procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir) is + begin + -- The generic map must be done before the elaboration of + -- the ports, since a port subtype may depend on a generic. + Elab_Generic_Map_Aspect (Mapping); + + Elab_Port_Map_Aspect (Mapping, Block_Parent); + end Elab_Map_Aspect; + end Chap5; + + package body Chap6 is + function Get_Array_Bound_Length (Arr : Mnode; + Arr_Type : Iir; + Dim : Natural) + return O_Enode + is + Index_Type : constant Iir := Get_Index_Type (Arr_Type, Dim - 1); + Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); + Constraint : Iir; + begin + if Tinfo.Type_Locally_Constrained then + Constraint := Get_Range_Constraint (Index_Type); + return New_Lit (Chap7.Translate_Static_Range_Length (Constraint)); + else + return M2E + (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, Dim))); + end if; + end Get_Array_Bound_Length; + + procedure Gen_Bound_Error (Loc : Iir) + is + Constr : O_Assoc_List; + Name : Name_Id; + Line, Col : Natural; + begin + Files_Map.Location_To_Position (Get_Location (Loc), Name, Line, Col); + + Start_Association (Constr, Ghdl_Bound_Check_Failed_L1); + Assoc_Filename_Line (Constr, Line); + New_Procedure_Call (Constr); + end Gen_Bound_Error; + + procedure Gen_Program_Error (Loc : Iir; Code : Natural) + is + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Program_Error); + + if Current_Filename_Node = O_Dnode_Null then + New_Association (Assoc, New_Lit (New_Null_Access (Char_Ptr_Type))); + New_Association (Assoc, + New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0))); + else + Assoc_Filename_Line (Assoc, Get_Line_Number (Loc)); + end if; + New_Association + (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Code)))); + New_Procedure_Call (Assoc); + end Gen_Program_Error; + + -- Generate code to emit a failure if COND is TRUE, indicating an + -- index violation for dimension DIM of an array. LOC is usually + -- the expression which has computed the index and is used only for + -- its location. + procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural) + is + pragma Unreferenced (Dim); + If_Blk : O_If_Block; + begin + Start_If_Stmt (If_Blk, Cond); + Gen_Bound_Error (Loc); + Finish_If_Stmt (If_Blk); + end Check_Bound_Error; + + -- Return TRUE if an array whose index type is RNG_TYPE indexed by + -- an expression of type EXPR_TYPE needs a bound check. + function Need_Index_Check (Expr_Type : Iir; Rng_Type : Iir) + return Boolean + is + Rng : Iir; + begin + -- Do checks if type of the expression is not a subtype. + -- FIXME: EXPR_TYPE shound not be NULL_IIR (generate stmt) + if Expr_Type = Null_Iir then + return True; + end if; + case Get_Kind (Expr_Type) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + null; + when others => + return True; + end case; + + -- No check if the expression has the type of the index. + if Expr_Type = Rng_Type then + return False; + end if; + + -- No check for 'Range or 'Reverse_Range. + Rng := Get_Range_Constraint (Expr_Type); + if (Get_Kind (Rng) = Iir_Kind_Range_Array_Attribute + or Get_Kind (Rng) = Iir_Kind_Reverse_Range_Array_Attribute) + and then Get_Type (Rng) = Rng_Type + then + return False; + end if; + + return True; + end Need_Index_Check; + + procedure Get_Deep_Range_Expression + (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean) + is + T : Iir; + R : Iir; + begin + Is_Reverse := False; + + -- T is an integer/enumeration subtype. + T := Atype; + loop + case Get_Kind (T) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + -- These types have a range. + null; + when others => + Error_Kind ("get_deep_range_expression(1)", T); + end case; + + R := Get_Range_Constraint (T); + case Get_Kind (R) is + when Iir_Kind_Range_Expression => + Rng := R; + return; + when Iir_Kind_Range_Array_Attribute => + null; + when Iir_Kind_Reverse_Range_Array_Attribute => + Is_Reverse := not Is_Reverse; + when others => + Error_Kind ("get_deep_range_expression(2)", R); + end case; + T := Get_Index_Subtype (R); + if T = Null_Iir then + Rng := Null_Iir; + return; + end if; + end loop; + end Get_Deep_Range_Expression; + + function Translate_Index_To_Offset (Rng : Mnode; + Index : O_Enode; + Index_Expr : Iir; + Range_Type : Iir; + Loc : Iir) + return O_Enode + is + Need_Check : Boolean; + Dir : O_Enode; + If_Blk : O_If_Block; + Res : O_Dnode; + Off : O_Dnode; + Bound : O_Enode; + Cond1, Cond2: O_Enode; + Index_Node : O_Dnode; + Bound_Node : O_Dnode; + Index_Info : Type_Info_Acc; + Deep_Rng : Iir; + Deep_Reverse : Boolean; + begin + Index_Info := Get_Info (Get_Base_Type (Range_Type)); + if Index_Expr = Null_Iir then + Need_Check := True; + Deep_Rng := Null_Iir; + Deep_Reverse := False; + else + Need_Check := Need_Index_Check (Get_Type (Index_Expr), Range_Type); + Get_Deep_Range_Expression (Range_Type, Deep_Rng, Deep_Reverse); + end if; + + Res := Create_Temp (Ghdl_Index_Type); + + Open_Temp; + + Off := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + Bound := M2E (Chap3.Range_To_Left (Rng)); + + if Deep_Rng /= Null_Iir then + if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then + -- Direction TO: INDEX - LEFT. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + Index, Bound)); + else + -- Direction DOWNTO: LEFT - INDEX. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + Bound, Index)); + end if; + else + Index_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), Index); + Bound_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), Bound); + Dir := M2E (Chap3.Range_To_Dir (Rng)); + + -- Non-static direction. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, Dir, + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + -- Direction TO: INDEX - LEFT. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Index_Node), + New_Obj_Value (Bound_Node))); + New_Else_Stmt (If_Blk); + -- Direction DOWNTO: LEFT - INDEX. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Bound_Node), + New_Obj_Value (Index_Node))); + Finish_If_Stmt (If_Blk); + end if; + + -- Get the offset. + New_Assign_Stmt + (New_Obj (Res), New_Convert_Ov (New_Obj_Value (Off), + Ghdl_Index_Type)); + + -- Check bounds. + if Need_Check then + Cond1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Off), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + + Cond2 := New_Compare_Op + (ON_Ge, + New_Obj_Value (Res), + M2E (Chap3.Range_To_Length (Rng)), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + end if; + + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Index_To_Offset; + + -- Translate index EXPR in dimension DIM of thin array into an + -- offset. + -- This checks bounds. + function Translate_Thin_Index_Offset (Index_Type : Iir; + Dim : Natural; + Expr : Iir) + return O_Enode + is + Index_Range : constant Iir := Get_Range_Constraint (Index_Type); + Obound : O_Cnode; + Res : O_Dnode; + Cond2: O_Enode; + Index : O_Enode; + Index_Base_Type : Iir; + V : Iir_Int64; + B : Iir_Int64; + begin + B := Eval_Pos (Get_Left_Limit (Index_Range)); + if Get_Expr_Staticness (Expr) = Locally then + V := Eval_Pos (Eval_Static_Expr (Expr)); + if Get_Direction (Index_Range) = Iir_To then + B := V - B; + else + B := B - V; + end if; + return New_Lit + (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (B))); + else + Index_Base_Type := Get_Base_Type (Index_Type); + Index := Chap7.Translate_Expression (Expr, Index_Base_Type); + + if Get_Direction (Index_Range) = Iir_To then + -- Direction TO: INDEX - LEFT. + if B /= 0 then + Obound := Chap7.Translate_Static_Range_Left + (Index_Range, Index_Base_Type); + Index := New_Dyadic_Op (ON_Sub_Ov, Index, New_Lit (Obound)); + end if; + else + -- Direction DOWNTO: LEFT - INDEX. + Obound := Chap7.Translate_Static_Range_Left + (Index_Range, Index_Base_Type); + Index := New_Dyadic_Op (ON_Sub_Ov, New_Lit (Obound), Index); + end if; + + -- Get the offset. + Index := New_Convert_Ov (Index, Ghdl_Index_Type); + + -- Since the value is unsigned, both left and right bounds are + -- checked in the same time. + if Get_Type (Expr) /= Index_Type then + Res := Create_Temp_Init (Ghdl_Index_Type, Index); + + Cond2 := New_Compare_Op + (ON_Ge, New_Obj_Value (Res), + New_Lit (Chap7.Translate_Static_Range_Length (Index_Range)), + Ghdl_Bool_Type); + Check_Bound_Error (Cond2, Expr, Dim); + Index := New_Obj_Value (Res); + end if; + + return Index; + end if; + end Translate_Thin_Index_Offset; + + -- Translate an indexed name. + type Indexed_Name_Data is record + Offset : O_Dnode; + Res : Mnode; + end record; + + function Translate_Indexed_Name_Init (Prefix_Orig : Mnode; Expr : Iir) + return Indexed_Name_Data + is + Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + Prefix_Info : constant Type_Info_Acc := Get_Info (Prefix_Type); + Index_List : constant Iir_List := Get_Index_List (Expr); + Type_List : constant Iir_List := Get_Index_Subtype_List (Prefix_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Prefix : Mnode; + Index : Iir; + Offset : O_Dnode; + R : O_Enode; + Length : O_Enode; + Itype : Iir; + Ibasetype : Iir; + Range_Ptr : Mnode; + begin + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array => + Prefix := Stabilize (Prefix_Orig); + when Type_Mode_Array => + Prefix := Prefix_Orig; + when others => + raise Internal_Error; + end case; + Offset := Create_Temp (Ghdl_Index_Type); + for Dim in 1 .. Nbr_Dim loop + Index := Get_Nth_Element (Index_List, Dim - 1); + Itype := Get_Index_Type (Type_List, Dim - 1); + Ibasetype := Get_Base_Type (Itype); + Open_Temp; + -- Compute index for the current dimension. + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array => + Range_Ptr := Stabilize + (Chap3.Get_Array_Range (Prefix, Prefix_Type, Dim)); + R := Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression (Index, Ibasetype), + Null_Iir, Itype, Index); + when Type_Mode_Array => + if Prefix_Info.Type_Locally_Constrained then + R := Translate_Thin_Index_Offset (Itype, Dim, Index); + else + -- Manually extract range since there is no infos for + -- index subtype. + Range_Ptr := Chap3.Bounds_To_Range + (Chap3.Get_Array_Type_Bounds (Prefix_Type), + Prefix_Type, Dim); + Stabilize (Range_Ptr); + R := Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression (Index, Ibasetype), + Index, Itype, Index); + end if; + when others => + raise Internal_Error; + end case; + if Dim = 1 then + -- First dimension. + New_Assign_Stmt (New_Obj (Offset), R); + else + -- If there are more dimension(s) to follow, then multiply + -- the current offset by the length of the current dimension. + if Prefix_Info.Type_Locally_Constrained then + Length := New_Lit (Chap7.Translate_Static_Range_Length + (Get_Range_Constraint (Itype))); + else + Length := M2E (Chap3.Range_To_Length (Range_Ptr)); + end if; + New_Assign_Stmt + (New_Obj (Offset), + New_Dyadic_Op (ON_Add_Ov, + New_Dyadic_Op (ON_Mul_Ov, + New_Obj_Value (Offset), + Length), + R)); + end if; + Close_Temp; + end loop; + + return (Offset => Offset, + Res => Chap3.Index_Base + (Chap3.Get_Array_Base (Prefix), Prefix_Type, + New_Obj_Value (Offset))); + end Translate_Indexed_Name_Init; + + function Translate_Indexed_Name_Finish + (Prefix : Mnode; Expr : Iir; Data : Indexed_Name_Data) + return Mnode + is + begin + return Chap3.Index_Base (Chap3.Get_Array_Base (Prefix), + Get_Type (Get_Prefix (Expr)), + New_Obj_Value (Data.Offset)); + end Translate_Indexed_Name_Finish; + + function Translate_Indexed_Name (Prefix : Mnode; Expr : Iir) + return Mnode + is + begin + return Translate_Indexed_Name_Init (Prefix, Expr).Res; + end Translate_Indexed_Name; + + type Slice_Name_Data is record + Off : Unsigned_64; + Is_Off : Boolean; + + Unsigned_Diff : O_Dnode; + + -- Variable pointing to the prefix. + Prefix_Var : Mnode; + + -- Variable pointing to slice. + Slice_Range : Mnode; + end record; + + procedure Translate_Slice_Name_Init + (Prefix : Mnode; Expr : Iir_Slice_Name; Data : out Slice_Name_Data) + is + -- Type of the prefix. + Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + + -- Type info of the prefix. + Prefix_Info : Type_Info_Acc; + + -- Type of the first (and only) index of the prefix array type. + Index_Type : constant Iir := Get_Index_Type (Prefix_Type, 0); + + -- Type of the slice. + Slice_Type : constant Iir := Get_Type (Expr); + Slice_Info : Type_Info_Acc; + + -- True iff the direction of the slice is known at compile time. + Static_Range : Boolean; + + -- Suffix of the slice (discrete range). + Expr_Range : constant Iir := Get_Suffix (Expr); + + -- Variable pointing to the prefix. + Prefix_Var : Mnode; + + -- Type info of the range base type. + Index_Info : Type_Info_Acc; + + -- Variables pointing to slice and prefix ranges. + Slice_Range : Mnode; + Prefix_Range : Mnode; + + Diff : O_Dnode; + Unsigned_Diff : O_Dnode; + If_Blk, If_Blk1 : O_If_Block; + begin + -- Evaluate slice bounds. + Chap3.Create_Array_Subtype (Slice_Type, True); + + -- The info may have just been created. + Prefix_Info := Get_Info (Prefix_Type); + Slice_Info := Get_Info (Slice_Type); + + if Slice_Info.Type_Mode = Type_Mode_Array + and then Slice_Info.Type_Locally_Constrained + and then Prefix_Info.Type_Mode = Type_Mode_Array + and then Prefix_Info.Type_Locally_Constrained + then + Data.Is_Off := True; + Data.Prefix_Var := Prefix; + + -- Both prefix and result are constrained array. + declare + Prefix_Left, Slice_Left : Iir_Int64; + Off : Iir_Int64; + Slice_Index_Type : Iir; + Slice_Range : Iir; + Slice_Length : Iir_Int64; + Index_Range : Iir; + begin + Index_Range := Get_Range_Constraint (Index_Type); + Prefix_Left := Eval_Pos (Get_Left_Limit (Index_Range)); + Slice_Index_Type := Get_Index_Type (Slice_Type, 0); + Slice_Range := Get_Range_Constraint (Slice_Index_Type); + Slice_Left := Eval_Pos (Get_Left_Limit (Slice_Range)); + Slice_Length := Eval_Discrete_Range_Length (Slice_Range); + if Slice_Length = 0 then + -- Null slice. + Data.Off := 0; + return; + end if; + if Get_Direction (Index_Range) /= Get_Direction (Slice_Range) + then + -- This is allowed with vhdl87 + Off := 0; + Slice_Length := 0; + else + -- Both prefix and slice are thin array. + case Get_Direction (Index_Range) is + when Iir_To => + Off := Slice_Left - Prefix_Left; + when Iir_Downto => + Off := Prefix_Left - Slice_Left; + end case; + if Off < 0 then + -- Must have been caught by sem. + raise Internal_Error; + end if; + if Off + Slice_Length + > Eval_Discrete_Range_Length (Index_Range) + then + -- Must have been caught by sem. + raise Internal_Error; + end if; + end if; + Data.Off := Unsigned_64 (Off); + + return; + end; + end if; + + Data.Is_Off := False; + + -- Save prefix. + Prefix_Var := Stabilize (Prefix); + + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + + -- Save prefix bounds. + Prefix_Range := Stabilize + (Chap3.Get_Array_Range (Prefix_Var, Prefix_Type, 1)); + + -- Save slice bounds. + Slice_Range := Stabilize + (Chap3.Bounds_To_Range (Chap3.Get_Array_Type_Bounds (Slice_Type), + Slice_Type, 1)); + + -- TRUE if the direction of the slice is known. + Static_Range := Get_Kind (Expr_Range) = Iir_Kind_Range_Expression; + + -- Check direction against same direction, error if different. + -- FIXME: what about v87 -> if different then null slice + if not Static_Range + or else Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition + then + -- Check same direction. + Check_Bound_Error + (New_Compare_Op (ON_Neq, + M2E (Chap3.Range_To_Dir (Prefix_Range)), + M2E (Chap3.Range_To_Dir (Slice_Range)), + Ghdl_Bool_Type), + Expr, 1); + end if; + + Unsigned_Diff := Create_Temp (Ghdl_Index_Type); + + -- Check if not a null slice. + -- The bounds of a null slice may be out of range. So DIFF cannot + -- be computed by substraction. + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + M2E (Chap3.Range_To_Length (Slice_Range)), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Unsigned_Diff), New_Lit (Ghdl_Index_0)); + New_Else_Stmt (If_Blk); + Diff := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + -- Compute the offset in the prefix. + if not Static_Range then + Start_If_Stmt + (If_Blk1, New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Slice_Range)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + end if; + if not Static_Range or else Get_Direction (Expr_Range) = Iir_To then + -- Diff = slice - bounds. + New_Assign_Stmt + (New_Obj (Diff), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Chap3.Range_To_Left (Slice_Range)), + M2E (Chap3.Range_To_Left (Prefix_Range)))); + end if; + if not Static_Range then + New_Else_Stmt (If_Blk1); + end if; + if not Static_Range or else Get_Direction (Expr_Range) = Iir_Downto + then + -- Diff = bounds - slice. + New_Assign_Stmt + (New_Obj (Diff), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Chap3.Range_To_Left (Prefix_Range)), + M2E (Chap3.Range_To_Left (Slice_Range)))); + end if; + if not Static_Range then + Finish_If_Stmt (If_Blk1); + end if; + + -- Note: this also check for overflow. + New_Assign_Stmt + (New_Obj (Unsigned_Diff), + New_Convert_Ov (New_Obj_Value (Diff), Ghdl_Index_Type)); + + -- Check bounds. + declare + Err_1 : O_Enode; + Err_2 : O_Enode; + begin + -- Bounds error if left of slice is before left of prefix. + Err_1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Diff), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + -- Bounds error if right of slice is after right of prefix. + Err_2 := New_Compare_Op + (ON_Gt, + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Unsigned_Diff), + M2E (Chap3.Range_To_Length (Slice_Range))), + M2E (Chap3.Range_To_Length (Prefix_Range)), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Err_1, Err_2), Expr, 1); + end; + Finish_If_Stmt (If_Blk); + + Data.Slice_Range := Slice_Range; + Data.Prefix_Var := Prefix_Var; + Data.Unsigned_Diff := Unsigned_Diff; + Data.Is_Off := False; + end Translate_Slice_Name_Init; + + function Translate_Slice_Name_Finish + (Prefix : Mnode; Expr : Iir_Slice_Name; Data : Slice_Name_Data) + return Mnode + is + -- Type of the slice. + Slice_Type : constant Iir := Get_Type (Expr); + Slice_Info : constant Type_Info_Acc := Get_Info (Slice_Type); + + -- Object kind of the prefix. + Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); + + Res_D : O_Dnode; + begin + if Data.Is_Off then + return Chap3.Slice_Base + (Prefix, Slice_Type, New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Data.Off))); + else + -- Create the result (fat array) and assign the bounds field. + case Slice_Info.Type_Mode is + when Type_Mode_Fat_Array => + Res_D := Create_Temp (Slice_Info.Ortho_Type (Kind)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res_D), + Slice_Info.T.Bounds_Field (Kind)), + New_Value (M2Lp (Data.Slice_Range))); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res_D), + Slice_Info.T.Base_Field (Kind)), + M2E (Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, + New_Obj_Value (Data.Unsigned_Diff)))); + return Dv2M (Res_D, Slice_Info, Kind); + when Type_Mode_Array => + return Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, + New_Obj_Value (Data.Unsigned_Diff)); + when others => + raise Internal_Error; + end case; + end if; + end Translate_Slice_Name_Finish; + + function Translate_Slice_Name (Prefix : Mnode; Expr : Iir_Slice_Name) + return Mnode + is + Data : Slice_Name_Data; + begin + Translate_Slice_Name_Init (Prefix, Expr, Data); + return Translate_Slice_Name_Finish (Data.Prefix_Var, Expr, Data); + end Translate_Slice_Name; + + function Translate_Interface_Name + (Inter : Iir; Info : Ortho_Info_Acc; Kind : Object_Kind_Type) + return Mnode + is + Type_Info : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); + begin + case Info.Kind is + when Kind_Object => + -- For a generic or a port. + return Get_Var (Info.Object_Var, Type_Info, Kind); + when Kind_Interface => + -- For a parameter. + if Info.Interface_Field = O_Fnode_Null then + -- Normal case: the parameter was translated as an ortho + -- interface. + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Dv2M (Info.Interface_Node, Type_Info, Kind); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + -- Parameter is passed by reference. + return Dp2M (Info.Interface_Node, Type_Info, Kind); + end case; + else + -- The parameter was put somewhere else. + declare + Subprg : constant Iir := Get_Parent (Inter); + Subprg_Info : constant Subprg_Info_Acc := + Get_Info (Subprg); + Linter : O_Lnode; + begin + if Info.Interface_Node = O_Dnode_Null then + -- The parameter is passed via a field of the RESULT + -- record parameter. + if Subprg_Info.Res_Record_Var = Null_Var then + Linter := New_Obj (Subprg_Info.Res_Interface); + else + -- Unnesting case. + Linter := Get_Var (Subprg_Info.Res_Record_Var); + end if; + return Lv2M (New_Selected_Element + (New_Acc_Value (Linter), + Info.Interface_Field), + Type_Info, Kind); + else + -- Unnesting case: the parameter was copied in the + -- subprogram frame so that nested subprograms can + -- reference it. Use field in FRAME. + Linter := New_Selected_Element + (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Scope), + Info.Interface_Field); + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Lv2M (Linter, Type_Info, Kind); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + -- Parameter is passed by reference. + return Lp2M (Linter, Type_Info, Kind); + end case; + end if; + end; + end if; + when others => + raise Internal_Error; + end case; + end Translate_Interface_Name; + + function Translate_Selected_Element (Prefix : Mnode; + El : Iir_Element_Declaration) + return Mnode + is + El_Info : constant Field_Info_Acc := Get_Info (El); + El_Type : constant Iir := Get_Type (El); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); + Stable_Prefix : Mnode; + begin + if Is_Complex_Type (El_Tinfo) then + -- The element is in fact an offset. + Stable_Prefix := Stabilize (Prefix); + return E2M + (New_Unchecked_Address + (New_Slice + (New_Access_Element + (New_Unchecked_Address + (M2Lv (Stable_Prefix), Char_Ptr_Type)), + Chararray_Type, + New_Value + (New_Selected_Element (M2Lv (Stable_Prefix), + El_Info.Field_Node (Kind)))), + El_Tinfo.Ortho_Ptr_Type (Kind)), + El_Tinfo, Kind); + else + return Lv2M (New_Selected_Element (M2Lv (Prefix), + El_Info.Field_Node (Kind)), + El_Tinfo, Kind); + end if; + end Translate_Selected_Element; + +-- function Translate_Formal_Interface_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir; +-- Kind : Object_Kind_Type) +-- return Mnode +-- is +-- Type_Info : Type_Info_Acc; +-- Info : Ortho_Info_Acc; +-- Res : Mnode; +-- begin +-- Type_Info := Get_Info (Get_Type (Name)); +-- Info := Get_Info (Name); +-- Push_Scope_Soft (Scope_Type, Scope_Param); +-- Res := Get_Var (Info.Object_Var, Type_Info, Kind); +-- Clear_Scope_Soft (Scope_Type); +-- return Res; +-- end Translate_Formal_Interface_Name; + +-- function Translate_Formal_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir) +-- return Mnode +-- is +-- Prefix : Iir; +-- Prefix_Name : Mnode; +-- begin +-- case Get_Kind (Name) is +-- when Iir_Kind_Interface_Constant_Declaration => +-- return Translate_Formal_Interface_Name +-- (Scope_Type, Scope_Param, Name, Mode_Value); + +-- when Iir_Kind_Interface_Signal_Declaration => +-- return Translate_Formal_Interface_Name +-- (Scope_Type, Scope_Param, Name, Mode_Signal); + +-- when Iir_Kind_Indexed_Name => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Indexed_Name (Prefix_Name, Name); + +-- when Iir_Kind_Slice_Name => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Slice_Name (Prefix_Name, Name); + +-- when Iir_Kind_Selected_Element => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Selected_Element +-- (Prefix_Name, Get_Selected_Element (Name)); + +-- when others => +-- Error_Kind ("translate_generic_name", Name); +-- end case; +-- end Translate_Formal_Name; + + function Translate_Name (Name : Iir) return Mnode + is + Name_Type : constant Iir := Get_Type (Name); + Name_Info : constant Ortho_Info_Acc := Get_Info (Name); + Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); + begin + case Get_Kind (Name) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration => + return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Value); + + when Iir_Kind_Attribute_Name => + return Translate_Name (Get_Named_Entity (Name)); + when Iir_Kind_Attribute_Value => + return Get_Var + (Get_Info (Get_Attribute_Specification (Name)).Object_Var, + Type_Info, Mode_Value); + + when Iir_Kind_Object_Alias_Declaration => + -- Alias_Var is not like an object variable, since it is + -- always a pointer to the aliased object. + declare + R : O_Lnode; + begin + R := Get_Var (Name_Info.Alias_Var); + case Type_Info.Type_Mode is + when Type_Mode_Fat_Array => + return Get_Var (Name_Info.Alias_Var, Type_Info, + Name_Info.Alias_Kind); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Acc + | Type_Mode_Fat_Acc => + R := Get_Var (Name_Info.Alias_Var); + return Lp2M (R, Type_Info, Name_Info.Alias_Kind); + when Type_Mode_Scalar => + R := Get_Var (Name_Info.Alias_Var); + if Name_Info.Alias_Kind = Mode_Signal then + return Lv2M (R, Type_Info, Name_Info.Alias_Kind); + else + return Lp2M (R, Type_Info, Name_Info.Alias_Kind); + end if; + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Guard_Signal_Declaration => + return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); + + when Iir_Kind_Interface_Constant_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_File_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_Variable_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_Signal_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Signal); + + when Iir_Kind_Indexed_Name => + return Translate_Indexed_Name + (Translate_Name (Get_Prefix (Name)), Name); + + when Iir_Kind_Slice_Name => + return Translate_Slice_Name + (Translate_Name (Get_Prefix (Name)), Name); + + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + declare + Pfx : O_Enode; + begin + Pfx := Chap7.Translate_Expression (Get_Prefix (Name)); + -- FIXME: what about fat pointer ?? + return Lv2M (New_Access_Element (Pfx), + Type_Info, Mode_Value); + end; + + when Iir_Kind_Selected_Element => + return Translate_Selected_Element + (Translate_Name (Get_Prefix (Name)), + Get_Selected_Element (Name)); + + when Iir_Kind_Function_Call => + -- This can appear as a prefix of a name, therefore, the + -- result is always a composite type or an access type. + declare + Imp : constant Iir := Get_Implementation (Name); + Obj : Iir; + Assoc_Chain : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration + then + -- FIXME : to be done + raise Internal_Error; + else + Canon.Canon_Subprogram_Call (Name); + Assoc_Chain := Get_Parameter_Association_Chain (Name); + Obj := Get_Method_Object (Name); + return E2M + (Chap7.Translate_Function_Call (Imp, Assoc_Chain, Obj), + Type_Info, Mode_Value); + end if; + end; + + when Iir_Kind_Image_Attribute => + -- Can appear as a prefix. + return E2M (Chap14.Translate_Image_Attribute (Name), + Type_Info, Mode_Value); + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Translate_Name (Get_Named_Entity (Name)); + + when others => + Error_Kind ("translate_name", Name); + end case; + end Translate_Name; + + procedure Translate_Direct_Driver + (Name : Iir; Sig : out Mnode; Drv : out Mnode) + is + Name_Type : constant Iir := Get_Type (Name); + Name_Info : constant Ortho_Info_Acc := Get_Info (Name); + Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Translate_Direct_Driver (Get_Named_Entity (Name), Sig, Drv); + when Iir_Kind_Object_Alias_Declaration => + Translate_Direct_Driver (Get_Name (Name), Sig, Drv); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Sig := Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); + Drv := Get_Var (Name_Info.Object_Driver, Type_Info, Mode_Value); + when Iir_Kind_Slice_Name => + declare + Data : Slice_Name_Data; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + Translate_Slice_Name_Init (Pfx_Sig, Name, Data); + Sig := Translate_Slice_Name_Finish + (Data.Prefix_Var, Name, Data); + Drv := Translate_Slice_Name_Finish (Pfx_Drv, Name, Data); + end; + when Iir_Kind_Indexed_Name => + declare + Data : Indexed_Name_Data; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + Data := Translate_Indexed_Name_Init (Pfx_Sig, Name); + Sig := Data.Res; + Drv := Translate_Indexed_Name_Finish (Pfx_Drv, Name, Data); + end; + when Iir_Kind_Selected_Element => + declare + El : Iir; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + El := Get_Selected_Element (Name); + Sig := Translate_Selected_Element (Pfx_Sig, El); + Drv := Translate_Selected_Element (Pfx_Drv, El); + end; + when others => + Error_Kind ("translate_direct_driver", Name); + end case; + end Translate_Direct_Driver; + end Chap6; + + package body Chap7 is + function Is_Static_Constant (Decl : Iir_Constant_Declaration) + return Boolean + is + Expr : constant Iir := Get_Default_Value (Decl); + Atype : Iir; + Info : Iir; + begin + if Expr = Null_Iir + or else Get_Kind (Expr) = Iir_Kind_Overflow_Literal + then + -- Deferred constant. + return False; + end if; + + if Get_Expr_Staticness (Decl) = Locally then + return True; + end if; + + -- Only aggregates are handled. + if Get_Kind (Expr) /= Iir_Kind_Aggregate then + return False; + end if; + + Atype := Get_Type (Decl); + -- Bounds must be known (and static). + if Get_Type_Staticness (Atype) /= Locally then + return False; + end if; + + -- Currently, only array aggregates are handled. + if Get_Kind (Get_Base_Type (Atype)) /= Iir_Kind_Array_Type_Definition + then + return False; + end if; + + -- Aggregate elements must be locally static. + -- Note: this does not yet handled aggregates of aggregates. + if Get_Value_Staticness (Expr) /= Locally then + return False; + end if; + Info := Get_Aggregate_Info (Expr); + while Info /= Null_Iir loop + if Get_Aggr_Dynamic_Flag (Info) then + raise Internal_Error; + end if; + + -- Currently, only positionnal aggregates are handled. + if Get_Aggr_Named_Flag (Info) then + return False; + end if; + -- Currently, others choice are not handled. + if Get_Aggr_Others_Flag (Info) then + return False; + end if; + + Info := Get_Sub_Aggregate_Info (Info); + end loop; + return True; + end Is_Static_Constant; + + procedure Translate_Static_String_Literal_Inner + (List : in out O_Array_Aggr_List; + Str : Iir; + El_Type : Iir) + is + use Name_Table; + + Literal_List : Iir_List; + Lit : Iir; + Len : Nat32; + Ptr : String_Fat_Acc; + begin + Literal_List := + Get_Enumeration_Literal_List (Get_Base_Type (El_Type)); + Len := Get_String_Length (Str); + Ptr := Get_String_Fat_Acc (Str); + for I in 1 .. Len loop + Lit := Find_Name_In_List (Literal_List, Get_Identifier (Ptr (I))); + New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); + end loop; + end Translate_Static_String_Literal_Inner; + + procedure Translate_Static_Bit_String_Literal_Inner + (List : in out O_Array_Aggr_List; + Lit : Iir_Bit_String_Literal; + El_Type : Iir) + is + pragma Unreferenced (El_Type); + L_0 : O_Cnode; + L_1 : O_Cnode; + Ptr : String_Fat_Acc; + Len : Nat32; + V : O_Cnode; + begin + L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit)); + L_1 := Get_Ortho_Expr (Get_Bit_String_1 (Lit)); + Ptr := Get_String_Fat_Acc (Lit); + Len := Get_String_Length (Lit); + for I in 1 .. Len loop + case Ptr (I) is + when '0' => + V := L_0; + when '1' => + V := L_1; + when others => + raise Internal_Error; + end case; + New_Array_Aggr_El (List, V); + end loop; + end Translate_Static_Bit_String_Literal_Inner; + + procedure Translate_Static_Aggregate_1 (List : in out O_Array_Aggr_List; + Aggr : Iir; + Info : Iir; + El_Type : Iir) + is + Assoc : Iir; + N_Info : Iir; + Sub : Iir; + begin + N_Info := Get_Sub_Aggregate_Info (Info); + + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + Assoc := Get_Association_Choices_Chain (Aggr); + while Assoc /= Null_Iir loop + Sub := Get_Associated_Expr (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if N_Info = Null_Iir then + New_Array_Aggr_El + (List, + Translate_Static_Expression (Sub, El_Type)); + else + Translate_Static_Aggregate_1 + (List, Sub, N_Info, El_Type); + end if; + when others => + Error_Kind ("translate_static_aggregate_1(2)", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + when Iir_Kind_String_Literal => + if N_Info /= Null_Iir then + raise Internal_Error; + end if; + Translate_Static_String_Literal_Inner (List, Aggr, El_Type); + when Iir_Kind_Bit_String_Literal => + if N_Info /= Null_Iir then + raise Internal_Error; + end if; + Translate_Static_Bit_String_Literal_Inner (List, Aggr, El_Type); + when others => + Error_Kind ("translate_static_aggregate_1", Aggr); + end case; + end Translate_Static_Aggregate_1; + + function Translate_Static_Aggregate (Aggr : Iir) + return O_Cnode + is + Aggr_Type : constant Iir := Get_Type (Aggr); + El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); + Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); + + Translate_Static_Aggregate_1 + (List, Aggr, Get_Aggregate_Info (Aggr), El_Type); + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Aggregate; + + function Translate_Static_Simple_Aggregate (Aggr : Iir) + return O_Cnode + is + Aggr_Type : Iir; + El_List : Iir_List; + El : Iir; + El_Type : Iir; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Aggr_Type := Get_Type (Aggr); + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); + El_Type := Get_Element_Subtype (Aggr_Type); + El_List := Get_Simple_Aggregate_List (Aggr); + Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); + + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + New_Array_Aggr_El + (List, Translate_Static_Expression (El, El_Type)); + end loop; + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Simple_Aggregate; + + function Translate_Static_String_Literal (Str : Iir) + return O_Cnode + is + use Name_Table; + + Lit_Type : Iir; + Element_Type : Iir; + Arr_Type : O_Tnode; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Lit_Type := Get_Type (Str); + + Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value); + + Start_Array_Aggr (List, Arr_Type); + + Element_Type := Get_Element_Subtype (Lit_Type); + + Translate_Static_String_Literal_Inner (List, Str, Element_Type); + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_String_Literal; + + -- Create a variable (constant) for string or bit string literal STR. + -- The type of the literal element is ELEMENT_TYPE, and the ortho type + -- of the string (a constrained array type) is STR_TYPE. + function Create_String_Literal_Var_Inner + (Str : Iir; Element_Type : Iir; Str_Type : O_Tnode) + return Var_Type + is + use Name_Table; + + Val_Aggr : O_Array_Aggr_List; + Res : O_Cnode; + begin + Start_Array_Aggr (Val_Aggr, Str_Type); + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Translate_Static_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when Iir_Kind_Bit_String_Literal => + Translate_Static_Bit_String_Literal_Inner + (Val_Aggr, Str, Element_Type); + when others => + raise Internal_Error; + end case; + Finish_Array_Aggr (Val_Aggr, Res); + + return Create_Global_Const + (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res); + end Create_String_Literal_Var_Inner; + + -- Create a variable (constant) for string or bit string literal STR. + function Create_String_Literal_Var (Str : Iir) return Var_Type is + use Name_Table; + + Str_Type : constant Iir := Get_Type (Str); + Arr_Type : O_Tnode; + begin + -- Create the string value. + Arr_Type := New_Constrained_Array_Type + (Get_Info (Str_Type).T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Get_String_Length (Str)))); + + return Create_String_Literal_Var_Inner + (Str, Get_Element_Subtype (Str_Type), Arr_Type); + end Create_String_Literal_Var; + + -- Some strings literal have an unconstrained array type, + -- eg: 'image of constant. Its type is not constrained + -- because it is not so in VHDL! + function Translate_Non_Static_String_Literal (Str : Iir) + return O_Enode + is + use Name_Table; + + Lit_Type : constant Iir := Get_Type (Str); + Type_Info : constant Type_Info_Acc := Get_Info (Lit_Type); + Index_Type : constant Iir := Get_Index_Type (Lit_Type, 0); + Index_Type_Info : constant Type_Info_Acc := Get_Info (Index_Type); + Bound_Aggr : O_Record_Aggr_List; + Index_Aggr : O_Record_Aggr_List; + Res_Aggr : O_Record_Aggr_List; + Res : O_Cnode; + Len : Int32; + Val : Var_Type; + Bound : Var_Type; + R : O_Enode; + begin + -- Create the string value. + Len := Get_String_Length (Str); + Val := Create_String_Literal_Var (Str); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Create the string bound. + Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type); + Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal + (Index_Type_Info.Ortho_Type (Mode_Value), 0)); + New_Record_Aggr_El + (Index_Aggr, + New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), + Integer_64 (Len - 1))); + New_Record_Aggr_El + (Index_Aggr, Ghdl_Dir_To_Node); + New_Record_Aggr_El + (Index_Aggr, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + Finish_Record_Aggr (Index_Aggr, Res); + New_Record_Aggr_El (Bound_Aggr, Res); + Finish_Record_Aggr (Bound_Aggr, Res); + Bound := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.T.Bounds_Type, + O_Storage_Private, Res); + + -- The descriptor. + Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Val), + Type_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (Res_Aggr, + New_Global_Address (Get_Var_Label (Bound), + Type_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (Res_Aggr, Res); + + Val := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + elsif Type_Info.Type_Mode = Type_Mode_Array then + -- Type of string literal isn't statically known; check the + -- length. + Chap6.Check_Bound_Error + (New_Compare_Op + (ON_Neq, + New_Lit (New_Index_Lit (Unsigned_64 (Len))), + Chap3.Get_Array_Type_Length (Lit_Type), + Ghdl_Bool_Type), + Str, 1); + else + raise Internal_Error; + end if; + + R := New_Address (Get_Var (Val), + Type_Info.Ortho_Ptr_Type (Mode_Value)); + return R; + end Translate_Non_Static_String_Literal; + + -- Only for Strings of STD.Character. + function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id) + return O_Cnode + is + use Name_Table; + + Literal_List : Iir_List; + Lit : Iir; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Str_Type, True); + + Start_Array_Aggr (List, Get_Ortho_Type (Str_Type, Mode_Value)); + + Literal_List := + Get_Enumeration_Literal_List (Character_Type_Definition); + Image (Str_Ident); + for I in 1 .. Name_Length loop + Lit := Get_Nth_Element (Literal_List, + Character'Pos (Name_Buffer (I))); + New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); + end loop; + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_String; + + function Translate_Static_Bit_String_Literal + (Lit : Iir_Bit_String_Literal) + return O_Cnode + is + Lit_Type : Iir; + Res : O_Cnode; + List : O_Array_Aggr_List; + begin + Lit_Type := Get_Type (Lit); + Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); + Translate_Static_Bit_String_Literal_Inner (List, Lit, Lit_Type); + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Bit_String_Literal; + + function Translate_String_Literal (Str : Iir) return O_Enode + is + Str_Type : constant Iir := Get_Type (Str); + Var : Var_Type; + Info : Type_Info_Acc; + Res : O_Cnode; + R : O_Enode; + begin + if Get_Constraint_State (Str_Type) = Fully_Constrained + and then + Get_Type_Staticness (Get_Index_Type (Str_Type, 0)) = Locally + then + Chap3.Create_Array_Subtype (Str_Type, True); + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Res := Translate_Static_String_Literal (Str); + when Iir_Kind_Bit_String_Literal => + Res := Translate_Static_Bit_String_Literal (Str); + when Iir_Kind_Simple_Aggregate => + Res := Translate_Static_Simple_Aggregate (Str); + when Iir_Kind_Simple_Name_Attribute => + Res := Translate_Static_String + (Get_Type (Str), Get_Simple_Name_Identifier (Str)); + when others => + raise Internal_Error; + end case; + Info := Get_Info (Str_Type); + Var := Create_Global_Const + (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); + return R; + else + return Translate_Non_Static_String_Literal (Str); + end if; + end Translate_String_Literal; + + function Translate_Static_Implicit_Conv + (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) return O_Cnode + is + Expr_Info : Type_Info_Acc; + Res_Info : Type_Info_Acc; + Val : Var_Type; + Res : O_Cnode; + List : O_Record_Aggr_List; + Bound : Var_Type; + begin + if Res_Type = Expr_Type then + return Expr; + end if; + if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then + raise Internal_Error; + end if; + if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition then + return Expr; + end if; + if Get_Kind (Res_Type) /= Iir_Kind_Array_Type_Definition then + raise Internal_Error; + end if; + Expr_Info := Get_Info (Expr_Type); + Res_Info := Get_Info (Res_Type); + Val := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Expr); + Bound := Expr_Info.T.Array_Bounds; + if Bound = Null_Var then + Bound := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type, + O_Storage_Private, + Chap3.Create_Static_Array_Subtype_Bounds (Expr_Type)); + Expr_Info.T.Array_Bounds := Bound; + end if; + + Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Val), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Bound), + Expr_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (List, Res); + return Res; + end Translate_Static_Implicit_Conv; + + function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) + return O_Cnode + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return New_Signed_Literal + (Res_Type, Integer_64 (Get_Value (Expr))); + + when Iir_Kind_Enumeration_Literal => + return Get_Ortho_Expr (Get_Enumeration_Decl (Expr)); + + when Iir_Kind_Floating_Point_Literal => + return New_Float_Literal + (Res_Type, IEEE_Float_64 (Get_Fp_Value (Expr))); + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return New_Signed_Literal + (Res_Type, Integer_64 (Get_Physical_Value (Expr))); + + when others => + Error_Kind ("translate_numeric_literal", Expr); + end case; + exception + when Constraint_Error => + -- Can be raised by Get_Physical_Unit_Value because of the kludge + -- on staticness. + Error_Msg_Elab ("numeric literal not in range", Expr); + return New_Signed_Literal (Res_Type, 0); + end Translate_Numeric_Literal; + + function Translate_Numeric_Literal (Expr : Iir; Res_Type : Iir) + return O_Cnode + is + Expr_Type : Iir; + Expr_Otype : O_Tnode; + Tinfo : Type_Info_Acc; + begin + Expr_Type := Get_Type (Expr); + Tinfo := Get_Info (Expr_Type); + if Res_Type /= Null_Iir then + Expr_Otype := Get_Ortho_Type (Res_Type, Mode_Value); + else + if Tinfo = null then + -- FIXME: this is a working kludge, in the case where EXPR_TYPE + -- is a subtype which was not yet translated. + -- (eg: evaluated array attribute) + Tinfo := Get_Info (Get_Base_Type (Expr_Type)); + end if; + Expr_Otype := Tinfo.Ortho_Type (Mode_Value); + end if; + return Translate_Numeric_Literal (Expr, Expr_Otype); + end Translate_Numeric_Literal; + + function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) + return O_Cnode + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Physical_Fp_Literal => + return Translate_Numeric_Literal (Expr, Res_Type); + + when Iir_Kind_String_Literal => + return Translate_Static_Implicit_Conv + (Translate_Static_String_Literal (Expr), Expr_Type, Res_Type); + when Iir_Kind_Bit_String_Literal => + return Translate_Static_Implicit_Conv + (Translate_Static_Bit_String_Literal (Expr), + Expr_Type, Res_Type); + when Iir_Kind_Simple_Aggregate => + return Translate_Static_Implicit_Conv + (Translate_Static_Simple_Aggregate (Expr), + Expr_Type, Res_Type); + when Iir_Kind_Aggregate => + return Translate_Static_Implicit_Conv + (Translate_Static_Aggregate (Expr), Expr_Type, Res_Type); + + when Iir_Kinds_Denoting_Name => + return Translate_Static_Expression + (Get_Named_Entity (Expr), Res_Type); + when others => + Error_Kind ("translate_static_expression", Expr); + end case; + end Translate_Static_Expression; + + function Translate_Static_Range_Left + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode + is + Left : O_Cnode; + Bound : Iir; + begin + Bound := Get_Left_Limit (Expr); + Left := Chap7.Translate_Static_Expression (Bound, Range_Type); +-- if Range_Type /= Null_Iir and then Get_Type (Bound) /= Range_Type then +-- Left := New_Convert_Ov +-- (Left, Get_Ortho_Type (Range_Type, Mode_Value)); +-- end if; + return Left; + end Translate_Static_Range_Left; + + function Translate_Static_Range_Right + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode + is + Right : O_Cnode; + begin + Right := Chap7.Translate_Static_Expression (Get_Right_Limit (Expr), + Range_Type); +-- if Range_Type /= Null_Iir then +-- Right := New_Convert_Ov +-- (Right, Get_Ortho_Type (Range_Type, Mode_Value)); +-- end if; + return Right; + end Translate_Static_Range_Right; + + function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode + is + begin + case Get_Direction (Expr) is + when Iir_To => + return Ghdl_Dir_To_Node; + when Iir_Downto => + return Ghdl_Dir_Downto_Node; + end case; + end Translate_Static_Range_Dir; + + function Translate_Static_Range_Length (Expr : Iir) return O_Cnode + is + Ulen : Unsigned_64; + begin + Ulen := Unsigned_64 (Eval_Discrete_Range_Length (Expr)); + return New_Unsigned_Literal (Ghdl_Index_Type, Ulen); + end Translate_Static_Range_Length; + + function Translate_Range_Expression_Left (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode + is + Left : O_Enode; + begin + Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); + if Range_Type /= Null_Iir then + Left := New_Convert_Ov (Left, + Get_Ortho_Type (Range_Type, Mode_Value)); + end if; + return Left; + end Translate_Range_Expression_Left; + + function Translate_Range_Expression_Right (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode + is + Right : O_Enode; + begin + Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); + if Range_Type /= Null_Iir then + Right := New_Convert_Ov (Right, + Get_Ortho_Type (Range_Type, Mode_Value)); + end if; + return Right; + end Translate_Range_Expression_Right; + + -- Compute the length of LEFT DIR (to/downto) RIGHT. + function Compute_Range_Length + (Left : O_Enode; Right : O_Enode; Dir : Iir_Direction) + return O_Enode + is + L : O_Enode; + R : O_Enode; + Val : O_Enode; + Tmp : O_Dnode; + Res : O_Dnode; + If_Blk : O_If_Block; + Rng_Type : O_Tnode; + begin + Rng_Type := Ghdl_I32_Type; + L := New_Convert_Ov (Left, Rng_Type); + R := New_Convert_Ov (Right, Rng_Type); + + case Dir is + when Iir_To => + Val := New_Dyadic_Op (ON_Sub_Ov, R, L); + when Iir_Downto => + Val := New_Dyadic_Op (ON_Sub_Ov, L, R); + end case; + + Res := Create_Temp (Ghdl_Index_Type); + Open_Temp; + Tmp := Create_Temp (Rng_Type); + New_Assign_Stmt (New_Obj (Tmp), Val); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Lt, New_Obj_Value (Tmp), + New_Lit (New_Signed_Literal (Rng_Type, 0)), + Ghdl_Bool_Type)); + Init_Var (Res); + New_Else_Stmt (If_Blk); + Val := New_Convert_Ov (New_Obj_Value (Tmp), Ghdl_Index_Type); + Val := New_Dyadic_Op (ON_Add_Ov, Val, New_Lit (Ghdl_Index_1)); + New_Assign_Stmt (New_Obj (Res), Val); + Finish_If_Stmt (If_Blk); + Close_Temp; + return New_Obj_Value (Res); + end Compute_Range_Length; + + function Translate_Range_Expression_Length (Expr : Iir) return O_Enode + is + Left, Right : O_Enode; + begin + if Get_Expr_Staticness (Expr) = Locally then + return New_Lit (Translate_Static_Range_Length (Expr)); + else + Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); + Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); + + return Compute_Range_Length (Left, Right, Get_Direction (Expr)); + end if; + end Translate_Range_Expression_Length; + + function Translate_Range_Length (Expr : Iir) return O_Enode is + begin + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + return Translate_Range_Expression_Length (Expr); + when Iir_Kind_Range_Array_Attribute => + return Chap14.Translate_Length_Array_Attribute (Expr, Null_Iir); + when others => + Error_Kind ("translate_range_length", Expr); + end case; + end Translate_Range_Length; + + function Translate_Association (Assoc : Iir) return O_Enode + is + Formal : constant Iir := Get_Formal (Assoc); + Formal_Base : constant Iir := Get_Association_Interface (Assoc); + Actual : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + when Iir_Kind_Association_Element_Open => + Actual := Get_Default_Value (Formal); + when others => + Error_Kind ("translate_association", Assoc); + end case; + + case Get_Kind (Formal_Base) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + return Chap3.Maybe_Insert_Scalar_Check + (Translate_Expression (Actual, Get_Type (Formal)), + Actual, Get_Type (Formal)); + when Iir_Kind_Interface_Signal_Declaration => + return Translate_Implicit_Conv + (M2E (Chap6.Translate_Name (Actual)), + Get_Type (Actual), + Get_Type (Formal_Base), + Mode_Signal, Assoc); + when others => + Error_Kind ("translate_association", Formal); + end case; + end Translate_Association; + + function Translate_Function_Call + (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) + return O_Enode + is + Info : constant Subprg_Info_Acc := Get_Info (Imp); + Constr : O_Assoc_List; + Assoc : Iir; + Res : Mnode; + begin + if Info.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + -- If we need to allocate, do it before starting the call! + declare + Res_Type : Iir; + Res_Info : Type_Info_Acc; + begin + Res_Type := Get_Return_Type (Imp); + Res_Info := Get_Info (Res_Type); + Res := Create_Temp (Res_Info); + if Res_Info.Type_Mode /= Type_Mode_Fat_Array then + Chap4.Allocate_Complex_Object (Res_Type, Alloc_Stack, Res); + end if; + end; + end if; + + Start_Association (Constr, Info.Ortho_Func); + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Association (Constr, M2E (Res)); + end if; + + -- If the subprogram is a method, pass the protected object. + if Obj /= Null_Iir then + New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + -- FIXME: evaluate expression before, because we + -- may allocate objects. + New_Association (Constr, Translate_Association (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + return M2E (Res); + else + return New_Function_Call (Constr); + end if; + end Translate_Function_Call; + + function Translate_Operator_Function_Call + (Imp : Iir; Left : Iir; Right : Iir; Res_Type : Iir) + return O_Enode + is + function Create_Assoc (Actual : Iir; Formal : Iir) + return Iir + is + R : Iir; + begin + R := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Location_Copy (R, Actual); + Set_Actual (R, Actual); + Set_Formal (R, Formal); + return R; + end Create_Assoc; + + Inter : Iir; + El_L : Iir; + El_R : Iir; + Res : O_Enode; + begin + Inter := Get_Interface_Declaration_Chain (Imp); + + El_L := Create_Assoc (Left, Inter); + + if Right /= Null_Iir then + Inter := Get_Chain (Inter); + El_R := Create_Assoc (Right, Inter); + Set_Chain (El_L, El_R); + end if; + + Res := Translate_Function_Call (Imp, El_L, Null_Iir); + + Free_Iir (El_L); + if Right /= Null_Iir then + Free_Iir (El_R); + end if; + + return Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Left); + end Translate_Operator_Function_Call; + + function Convert_Constrained_To_Unconstrained + (Expr : Mnode; Res_Type : Iir) + return Mnode + is + Type_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Expr); + Stable_Expr : Mnode; + Res : Mnode; + begin + Res := Create_Temp (Type_Info, Kind); + Stable_Expr := Stabilize (Expr); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (Stable_Expr)), + Type_Info.T.Base_Ptr_Type (Kind))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Stable_Expr))); + return Res; + end Convert_Constrained_To_Unconstrained; + + function Convert_Array_To_Thin_Array (Expr : Mnode; + Expr_Type : Iir; + Atype : Iir; + Loc : Iir) + return Mnode + is + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + Expr_Stable : Mnode; + Success_Label, Failure_Label : O_Snode; + begin + Expr_Stable := Stabilize (Expr); + + Open_Temp; + -- Check each dimension. + Start_Loop_Stmt (Success_Label); + Start_Loop_Stmt (Failure_Label); + for I in 1 .. Get_Nbr_Elements (Expr_Indexes) loop + Gen_Exit_When + (Failure_Label, + New_Compare_Op + (ON_Neq, + Chap6.Get_Array_Bound_Length + (Expr_Stable, Expr_Type, I), + Chap6.Get_Array_Bound_Length + (T2M (Atype, Get_Object_Kind (Expr_Stable)), Atype, I), + Ghdl_Bool_Type)); + end loop; + New_Exit_Stmt (Success_Label); + Finish_Loop_Stmt (Failure_Label); + Chap6.Gen_Bound_Error (Loc); + Finish_Loop_Stmt (Success_Label); + Close_Temp; + + return Chap3.Get_Array_Base (Expr_Stable); + end Convert_Array_To_Thin_Array; + + function Translate_Implicit_Array_Conversion + (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return Mnode + is + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + begin + pragma Assert + (Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition); + + if Res_Type = Expr_Type then + return Expr; + end if; + + Ainfo := Get_Info (Res_Type); + Einfo := Get_Info (Expr_Type); + case Ainfo.Type_Mode is + when Type_Mode_Fat_Array => + -- X to unconstrained. + case Einfo.Type_Mode is + when Type_Mode_Fat_Array => + -- unconstrained to unconstrained. + return Expr; + when Type_Mode_Array => + -- constrained to unconstrained. + return Convert_Constrained_To_Unconstrained + (Expr, Res_Type); + when others => + raise Internal_Error; + end case; + when Type_Mode_Array => + -- X to constrained. + if Einfo.Type_Locally_Constrained + and then Ainfo.Type_Locally_Constrained + then + -- FIXME: optimize static vs non-static + -- constrained to constrained. + if not Chap3.Locally_Array_Match (Expr_Type, Res_Type) then + -- FIXME: generate a bound error ? + -- Even if this is caught at compile-time, + -- the code is not required to run. + Chap6.Gen_Bound_Error (Loc); + end if; + return Expr; + else + -- Unbounded/bounded array to bounded array. + return Convert_Array_To_Thin_Array + (Expr, Expr_Type, Res_Type, Loc); + end if; + when others => + raise Internal_Error; + end case; + end Translate_Implicit_Array_Conversion; + + -- Convert (if necessary) EXPR translated from EXPR_ORIG to type ATYPE. + function Translate_Implicit_Conv (Expr : O_Enode; + Expr_Type : Iir; + Atype : Iir; + Is_Sig : Object_Kind_Type; + Loc : Iir) + return O_Enode is + begin + -- Same type: nothing to do. + if Atype = Expr_Type then + return Expr; + end if; + + if Expr_Type = Universal_Integer_Type_Definition then + return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); + elsif Expr_Type = Universal_Real_Type_Definition then + return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); + elsif Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition then + return M2E (Translate_Implicit_Array_Conversion + (E2M (Expr, Get_Info (Expr_Type), Is_Sig), + Expr_Type, Atype, Loc)); + else + return Expr; + end if; + end Translate_Implicit_Conv; + + type Predefined_To_Onop_Type is array (Iir_Predefined_Functions) + of ON_Op_Kind; + Predefined_To_Onop : constant Predefined_To_Onop_Type := + (Iir_Predefined_Boolean_Or => ON_Or, + Iir_Predefined_Boolean_Not => ON_Not, + Iir_Predefined_Boolean_And => ON_And, + Iir_Predefined_Boolean_Xor => ON_Xor, + + Iir_Predefined_Bit_Not => ON_Not, + Iir_Predefined_Bit_And => ON_And, + Iir_Predefined_Bit_Or => ON_Or, + Iir_Predefined_Bit_Xor => ON_Xor, + + Iir_Predefined_Integer_Equality => ON_Eq, + Iir_Predefined_Integer_Inequality => ON_Neq, + Iir_Predefined_Integer_Less_Equal => ON_Le, + Iir_Predefined_Integer_Less => ON_Lt, + Iir_Predefined_Integer_Greater => ON_Gt, + Iir_Predefined_Integer_Greater_Equal => ON_Ge, + Iir_Predefined_Integer_Plus => ON_Add_Ov, + Iir_Predefined_Integer_Minus => ON_Sub_Ov, + Iir_Predefined_Integer_Mul => ON_Mul_Ov, + Iir_Predefined_Integer_Rem => ON_Rem_Ov, + Iir_Predefined_Integer_Mod => ON_Mod_Ov, + Iir_Predefined_Integer_Div => ON_Div_Ov, + Iir_Predefined_Integer_Absolute => ON_Abs_Ov, + Iir_Predefined_Integer_Negation => ON_Neg_Ov, + + Iir_Predefined_Enum_Equality => ON_Eq, + Iir_Predefined_Enum_Inequality => ON_Neq, + Iir_Predefined_Enum_Greater_Equal => ON_Ge, + Iir_Predefined_Enum_Greater => ON_Gt, + Iir_Predefined_Enum_Less => ON_Lt, + Iir_Predefined_Enum_Less_Equal => ON_Le, + + Iir_Predefined_Physical_Equality => ON_Eq, + Iir_Predefined_Physical_Inequality => ON_Neq, + Iir_Predefined_Physical_Less => ON_Lt, + Iir_Predefined_Physical_Less_Equal => ON_Le, + Iir_Predefined_Physical_Greater => ON_Gt, + Iir_Predefined_Physical_Greater_Equal => ON_Ge, + Iir_Predefined_Physical_Negation => ON_Neg_Ov, + Iir_Predefined_Physical_Absolute => ON_Abs_Ov, + Iir_Predefined_Physical_Minus => ON_Sub_Ov, + Iir_Predefined_Physical_Plus => ON_Add_Ov, + + Iir_Predefined_Floating_Greater => ON_Gt, + Iir_Predefined_Floating_Greater_Equal => ON_Ge, + Iir_Predefined_Floating_Less => ON_Lt, + Iir_Predefined_Floating_Less_Equal => ON_Le, + Iir_Predefined_Floating_Equality => ON_Eq, + Iir_Predefined_Floating_Inequality => ON_Neq, + Iir_Predefined_Floating_Minus => ON_Sub_Ov, + Iir_Predefined_Floating_Plus => ON_Add_Ov, + Iir_Predefined_Floating_Mul => ON_Mul_Ov, + Iir_Predefined_Floating_Div => ON_Div_Ov, + Iir_Predefined_Floating_Negation => ON_Neg_Ov, + Iir_Predefined_Floating_Absolute => ON_Abs_Ov, + + others => ON_Nil); + + function Translate_Shortcut_Operator + (Imp : Iir_Implicit_Function_Declaration; Left, Right : Iir) + return O_Enode + is + Rtype : Iir; + Res : O_Dnode; + Res_Type : O_Tnode; + If_Blk : O_If_Block; + Val : Integer; + V : O_Cnode; + Kind : Iir_Predefined_Functions; + Invert : Boolean; + begin + Rtype := Get_Return_Type (Imp); + Res_Type := Get_Ortho_Type (Rtype, Mode_Value); + Res := Create_Temp (Res_Type); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Left)); + Close_Temp; + Kind := Get_Implicit_Definition (Imp); + + -- Short cut: RIGHT is the result (and must be evaluated) iff + -- LEFT is equal to VAL (ie '0' or false for 0, '1' or true for 1). + case Kind is + when Iir_Predefined_Bit_And + | Iir_Predefined_Boolean_And => + Invert := False; + Val := 1; + when Iir_Predefined_Bit_Nand + | Iir_Predefined_Boolean_Nand => + Invert := True; + Val := 1; + when Iir_Predefined_Bit_Or + | Iir_Predefined_Boolean_Or => + Invert := False; + Val := 0; + when Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_Nor => + Invert := True; + Val := 0; + when others => + Ada.Text_IO.Put_Line + ("translate_shortcut_operator: cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + end case; + + V := Get_Ortho_Expr + (Get_Nth_Element (Get_Enumeration_Literal_List (Rtype), Val)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Res), New_Lit (V), + Ghdl_Bool_Type)); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Right)); + Close_Temp; + Finish_If_Stmt (If_Blk); + if Invert then + return New_Monadic_Op (ON_Not, New_Obj_Value (Res)); + else + return New_Obj_Value (Res); + end if; + end Translate_Shortcut_Operator; + + function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Func); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + return New_Function_Call (Constr); + end Translate_Lib_Operator; + + function Translate_Predefined_Lib_Operator + (Left, Right : O_Enode; Func : Iir_Implicit_Function_Declaration) + return O_Enode + is + Info : constant Subprg_Info_Acc := Get_Info (Func); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + return New_Function_Call (Constr); + end Translate_Predefined_Lib_Operator; + + function Translate_Predefined_Array_Operator + (Left, Right : O_Enode; Func : Iir) + return O_Enode + is + Res : O_Dnode; + Constr : O_Assoc_List; + Info : Type_Info_Acc; + Func_Info : Subprg_Info_Acc; + begin + Create_Temp_Stack2_Mark; + Info := Get_Info (Get_Return_Type (Func)); + Res := Create_Temp (Info.Ortho_Type (Mode_Value)); + Func_Info := Get_Info (Func); + Start_Association (Constr, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Func_Info.Subprg_Instance); + New_Association (Constr, + New_Address (New_Obj (Res), + Info.Ortho_Ptr_Type (Mode_Value))); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), Info.Ortho_Ptr_Type (Mode_Value)); + end Translate_Predefined_Array_Operator; + + function Translate_Predefined_Array_Operator_Convert + (Left, Right : O_Enode; Func : Iir; Res_Type : Iir) + return O_Enode + is + Res : O_Enode; + Ret_Type : Iir; + begin + Ret_Type := Get_Return_Type (Func); + Res := Translate_Predefined_Array_Operator (Left, Right, Func); + return Translate_Implicit_Conv + (Res, Ret_Type, Res_Type, Mode_Value, Func); + end Translate_Predefined_Array_Operator_Convert; + + -- Create an array aggregate containing one element, EL. + function Translate_Element_To_Array (El : O_Enode; Arr_Type : Iir) + return O_Enode + is + Res : O_Dnode; + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + V : O_Dnode; + begin + Ainfo := Get_Info (Arr_Type); + Einfo := Get_Info (Get_Element_Subtype (Arr_Type)); + Res := Create_Temp (Ainfo.Ortho_Type (Mode_Value)); + if Is_Composite (Einfo) then + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Base_Field (Mode_Value)), + New_Convert_Ov (El, Ainfo.T.Base_Ptr_Type (Mode_Value))); + else + V := Create_Temp_Init (Einfo.Ortho_Type (Mode_Value), El); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Base_Field (Mode_Value)), + New_Convert_Ov (New_Address (New_Obj (V), + Einfo.Ortho_Ptr_Type (Mode_Value)), + Ainfo.T.Base_Ptr_Type (Mode_Value))); + end if; + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Bounds_Field (Mode_Value)), + New_Address (Get_Var (Ainfo.T.Array_1bound), + Ainfo.T.Bounds_Ptr_Type)); + return New_Address (New_Obj (Res), Ainfo.Ortho_Ptr_Type (Mode_Value)); + end Translate_Element_To_Array; + + function Translate_Concat_Operator + (Left_Tree, Right_Tree : O_Enode; + Imp : Iir_Implicit_Function_Declaration; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Ret_Type : constant Iir := Get_Return_Type (Imp); + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Arr_El1 : O_Enode; + Arr_El2 : O_Enode; + Res : O_Enode; + begin + case Kind is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Arr_El1 := Translate_Element_To_Array (Left_Tree, Ret_Type); + when others => + Arr_El1 := Left_Tree; + end case; + case Kind is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Arr_El2 := Translate_Element_To_Array (Right_Tree, Ret_Type); + when others => + Arr_El2 := Right_Tree; + end case; + Res := Translate_Predefined_Array_Operator (Arr_El1, Arr_El2, Imp); + return Translate_Implicit_Conv + (Res, Ret_Type, Res_Type, Mode_Value, Loc); + end Translate_Concat_Operator; + + function Translate_Scalar_Min_Max + (Op : ON_Op_Kind; + Left, Right : Iir; + Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + Res, L, R : O_Dnode; + If_Blk : O_If_Block; + begin + -- Create a variable for the result. + Res := Create_Temp (Res_Otype); + + Open_Temp; + L := Create_Temp_Init + (Res_Otype, Translate_Expression (Left, Res_Type)); + R := Create_Temp_Init + (Res_Otype, Translate_Expression (Right, Res_Type)); + + Start_If_Stmt (If_Blk, New_Compare_Op (Op, + New_Obj_Value (L), + New_Obj_Value (R), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (L)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (R)); + Finish_If_Stmt (If_Blk); + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Scalar_Min_Max; + + function Translate_Predefined_Vector_Min_Max (Is_Min : Boolean; + Left : Iir; + Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + Left_Type : constant Iir := Get_Type (Left); + Res, El, Len : O_Dnode; + Arr : Mnode; + If_Blk : O_If_Block; + Label : O_Snode; + Op : ON_Op_Kind; + begin + -- Create a variable for the result. + Res := Create_Temp (Res_Otype); + + Open_Temp; + if Is_Min then + Op := ON_Lt; + else + Op := ON_Gt; + end if; + New_Assign_Stmt + (New_Obj (Res), + Chap14.Translate_High_Low_Type_Attribute (Res_Type, Is_Min)); + + El := Create_Temp (Res_Otype); + Arr := Stabilize (E2M (Translate_Expression (Left), + Get_Info (Left_Type), Mode_Value)); + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Left_Type, 1)))); + + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- if ARR[LEN] </> RES then + -- RES := ARR[LEN]; + -- end if; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Obj (El), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Left_Type, New_Obj_Value (Len)))); + Start_If_Stmt (If_Blk, New_Compare_Op (Op, + New_Obj_Value (El), + New_Obj_Value (Res), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (El)); + Finish_If_Stmt (If_Blk); + Finish_Loop_Stmt (Label); + + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Predefined_Vector_Min_Max; + + function Translate_Std_Ulogic_Match (Func : O_Dnode; + L, R : O_Enode; + Res_Type : O_Tnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Func); + New_Association (Constr, New_Convert_Ov (L, Ghdl_I32_Type)); + New_Association (Constr, New_Convert_Ov (R, Ghdl_I32_Type)); + return New_Convert_Ov (New_Function_Call (Constr), Res_Type); + end Translate_Std_Ulogic_Match; + + function Translate_To_String (Subprg : O_Dnode; + Res_Type : Iir; + Loc : Iir; + Val : O_Enode; + Arg2 : O_Enode := O_Enode_Null; + Arg3 : O_Enode := O_Enode_Null) + return O_Enode + is + Val_Type : constant Iir := Get_Base_Type (Res_Type); + Res : O_Dnode; + Assoc : O_Assoc_List; + begin + Res := Create_Temp (Std_String_Node); + Create_Temp_Stack2_Mark; + Start_Association (Assoc, Subprg); + New_Association (Assoc, + New_Address (New_Obj (Res), Std_String_Ptr_Node)); + New_Association (Assoc, Val); + if Arg2 /= O_Enode_Null then + New_Association (Assoc, Arg2); + if Arg3 /= O_Enode_Null then + New_Association (Assoc, Arg3); + end if; + end if; + New_Procedure_Call (Assoc); + return M2E (Translate_Implicit_Array_Conversion + (Dv2M (Res, Get_Info (Val_Type), Mode_Value), + Val_Type, Res_Type, Loc)); + end Translate_To_String; + + function Translate_Bv_To_String (Subprg : O_Dnode; + Val : O_Enode; + Val_Type : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Arr : Mnode; + begin + Arr := Stabilize (E2M (Val, Get_Info (Val_Type), Mode_Value)); + return Translate_To_String + (Subprg, Res_Type, Loc, + M2E (Chap3.Get_Array_Base (Arr)), + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Val_Type, 1)))); + end Translate_Bv_To_String; + + subtype Predefined_Boolean_Logical is Iir_Predefined_Functions range + Iir_Predefined_Boolean_And .. Iir_Predefined_Boolean_Xnor; + + function Translate_Predefined_Logical + (Op : Predefined_Boolean_Logical; Left, Right : O_Enode) + return O_Enode is + begin + case Op is + when Iir_Predefined_Boolean_And => + return New_Dyadic_Op (ON_And, Left, Right); + when Iir_Predefined_Boolean_Or => + return New_Dyadic_Op (ON_Or, Left, Right); + when Iir_Predefined_Boolean_Nand => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_And, Left, Right)); + when Iir_Predefined_Boolean_Nor => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_Or, Left, Right)); + when Iir_Predefined_Boolean_Xor => + return New_Dyadic_Op (ON_Xor, Left, Right); + when Iir_Predefined_Boolean_Xnor => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_Xor, Left, Right)); + end case; + end Translate_Predefined_Logical; + + function Translate_Predefined_TF_Array_Element + (Op : Predefined_Boolean_Logical; + Left, Right : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Type (Left); + Res_Btype : constant Iir := Get_Base_Type (Res_Type); + Res_Info : constant Type_Info_Acc := Get_Info (Res_Btype); + Base_Ptr_Type : constant O_Tnode := + Res_Info.T.Base_Ptr_Type (Mode_Value); + Arr : Mnode; + El : O_Dnode; + Base : O_Dnode; + Len : O_Dnode; + Label : O_Snode; + Res : Mnode; + begin + -- Translate the array. + Arr := Stabilize (E2M (Translate_Expression (Left), + Get_Info (Arr_Type), Mode_Value)); + + -- Extract its length. + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); + + -- Allocate the result array. + Base := Create_Temp_Init + (Base_Ptr_Type, + Gen_Alloc (Alloc_Stack, New_Obj_Value (Len), Base_Ptr_Type)); + + Open_Temp; + -- Translate the element. + El := Create_Temp_Init (Get_Ortho_Type (Get_Type (Right), Mode_Value), + Translate_Expression (Right)); + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- BASE[LEN] := EL op ARR[LEN]; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Base), + New_Obj_Value (Len)), + Translate_Predefined_Logical + (Op, + New_Obj_Value (El), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Arr_Type, New_Obj_Value (Len))))); + Finish_Loop_Stmt (Label); + Close_Temp; + + Res := Create_Temp (Res_Info, Mode_Value); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), + New_Obj_Value (Base)); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Arr))); + + return Translate_Implicit_Conv (M2E (Res), Res_Btype, Res_Type, + Mode_Value, Loc); + end Translate_Predefined_TF_Array_Element; + + function Translate_Predefined_TF_Reduction + (Op : ON_Op_Kind; Operand : Iir; Res_Type : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Type (Operand); + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Res_Type)); + Init_Enum : Iir; + + Res : O_Dnode; + Arr_Expr : O_Enode; + Arr : Mnode; + Len : O_Dnode; + Label : O_Snode; + begin + if Op = ON_And then + Init_Enum := Get_Nth_Element (Enums, 1); + else + Init_Enum := Get_Nth_Element (Enums, 0); + end if; + + Res := Create_Temp_Init (Get_Ortho_Type (Res_Type, Mode_Value), + New_Lit (Get_Ortho_Expr (Init_Enum))); + + Open_Temp; + -- Translate the array. Note that Translate_Expression may create + -- the info for the array type, so be sure to call it before calling + -- Get_Info. + Arr_Expr := Translate_Expression (Operand); + Arr := Stabilize (E2M (Arr_Expr, Get_Info (Arr_Type), Mode_Value)); + + -- Extract its length. + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); + + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- RES := RES op ARR[LEN]; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Obj (Res), + New_Dyadic_Op + (Op, + New_Obj_Value (Res), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Arr_Type, New_Obj_Value (Len))))); + Finish_Loop_Stmt (Label); + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Predefined_TF_Reduction; + + function Translate_Predefined_Array_Min_Max + (Is_Min : Boolean; + Left, Right : O_Enode; + Left_Type, Right_Type : Iir; + Res_Type : Iir; + Imp : Iir; + Loc : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Base_Type (Left_Type); + Arr_Info : constant Type_Info_Acc := Get_Info (Arr_Type); + L, R : Mnode; + If_Blk : O_If_Block; + Res : Mnode; + begin + Res := Create_Temp (Arr_Info, Mode_Value); + L := Stabilize (E2M (Left, Get_Info (Left_Type), Mode_Value)); + R := Stabilize (E2M (Right, Get_Info (Right_Type), Mode_Value)); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (M2E (L), M2E (R), Imp), + New_Lit (Ghdl_Compare_Lt), + Std_Boolean_Type_Node)); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + end if; + New_Else_Stmt (If_Blk); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + end if; + Finish_If_Stmt (If_Blk); + + return M2E (Translate_Implicit_Array_Conversion + (Res, Arr_Type, Res_Type, Loc)); + end Translate_Predefined_Array_Min_Max; + + function Translate_Predefined_TF_Edge + (Is_Rising : Boolean; Left : Iir) + return O_Enode + is + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Left))); + Name : Mnode; + begin + Name := Stabilize (Chap6.Translate_Name (Left), True); + return New_Dyadic_Op + (ON_And, + New_Value (Chap14.Get_Signal_Field + (Name, Ghdl_Signal_Event_Field)), + New_Compare_Op + (ON_Eq, + New_Value (New_Access_Element (M2E (Name))), + New_Lit (Get_Ortho_Expr + (Get_Nth_Element (Enums, Boolean'Pos (Is_Rising)))), + Std_Boolean_Type_Node)); + end Translate_Predefined_TF_Edge; + + function Translate_Predefined_Std_Ulogic_Array_Match + (Subprg : O_Dnode; Left, Right : Iir; Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + L_Type : constant Iir := Get_Type (Left); + R_Type : constant Iir := Get_Type (Right); + L_Expr, R_Expr : O_Enode; + L, R : Mnode; + Assoc : O_Assoc_List; + + Res : O_Dnode; + begin + Res := Create_Temp (Ghdl_I32_Type); + + Open_Temp; + -- Translate the arrays. Note that Translate_Expression may create + -- the info for the array type, so be sure to call it before calling + -- Get_Info. + L_Expr := Translate_Expression (Left); + L := Stabilize (E2M (L_Expr, Get_Info (L_Type), Mode_Value)); + + R_Expr := Translate_Expression (Right); + R := Stabilize (E2M (R_Expr, Get_Info (R_Type), Mode_Value)); + + Start_Association (Assoc, Subprg); + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (L)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, L_Type, 1)))); + + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (R)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, R_Type, 1)))); + + New_Assign_Stmt (New_Obj (Res), New_Function_Call (Assoc)); + + Close_Temp; + + return New_Convert_Ov (New_Obj_Value (Res), Res_Otype); + end Translate_Predefined_Std_Ulogic_Array_Match; + + function Translate_Predefined_Operator + (Imp : Iir_Implicit_Function_Declaration; + Left, Right : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Left_Tree : O_Enode; + Right_Tree : O_Enode; + Left_Type : Iir; + Right_Type : Iir; + Res_Otype : O_Tnode; + Op : ON_Op_Kind; + Inter : Iir; + Res : O_Enode; + begin + case Kind is + when Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor => + -- Right operand of shortcur operators may not be evaluated. + return Translate_Shortcut_Operator (Imp, Left, Right); + + -- Operands of min/max are evaluated in a declare block. + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Integer_Minimum + | Iir_Predefined_Floating_Minimum + | Iir_Predefined_Physical_Minimum => + return Translate_Scalar_Min_Max (ON_Le, Left, Right, Res_Type); + when Iir_Predefined_Enum_Maximum + | Iir_Predefined_Integer_Maximum + | Iir_Predefined_Floating_Maximum + | Iir_Predefined_Physical_Maximum => + return Translate_Scalar_Min_Max (ON_Ge, Left, Right, Res_Type); + + -- Avoid implicit conversion of the array parameters to the + -- unbounded type for optimizing purpose. FIXME: should do the + -- same for the result. + when Iir_Predefined_TF_Array_Element_And => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_And => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Or => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Or => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Nand => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Nand => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Nor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Nor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Xor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Xor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Xnor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Xnor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Loc); + + -- Avoid implicit conversion of the array parameters to the + -- unbounded type for optimizing purpose. + when Iir_Predefined_TF_Reduction_And => + return Translate_Predefined_TF_Reduction + (ON_And, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Or => + return Translate_Predefined_TF_Reduction + (ON_Or, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Nand => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_And, Left, Res_Type)); + when Iir_Predefined_TF_Reduction_Nor => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Or, Left, Res_Type)); + when Iir_Predefined_TF_Reduction_Xor => + return Translate_Predefined_TF_Reduction + (ON_Xor, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Xnor => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Xor, Left, Res_Type)); + + when Iir_Predefined_Vector_Minimum => + return Translate_Predefined_Vector_Min_Max + (True, Left, Res_Type); + when Iir_Predefined_Vector_Maximum => + return Translate_Predefined_Vector_Min_Max + (False, Left, Res_Type); + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Translate_Predefined_TF_Edge (True, Left); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Translate_Predefined_TF_Edge (False, Left); + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Eq, Left, Right, Res_Type); + when Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Ne, Left, Right, Res_Type); + + when others => + null; + end case; + + -- Evaluate parameters. + Res_Otype := Get_Ortho_Type (Res_Type, Mode_Value); + Inter := Get_Interface_Declaration_Chain (Imp); + if Left = Null_Iir then + Left_Tree := O_Enode_Null; + else + Left_Type := Get_Type (Inter); + Left_Tree := Translate_Expression (Left, Left_Type); + end if; + + if Right = Null_Iir then + Right_Tree := O_Enode_Null; + else + Right_Type := Get_Type (Get_Chain (Inter)); + Right_Tree := Translate_Expression (Right, Right_Type); + end if; + + Op := Predefined_To_Onop (Kind); + if Op /= ON_Nil then + case Op is + when ON_Eq + | ON_Neq + | ON_Ge + | ON_Gt + | ON_Le + | ON_Lt => + Res := New_Compare_Op (Op, Left_Tree, Right_Tree, + Std_Boolean_Type_Node); + when ON_Add_Ov + | ON_Sub_Ov + | ON_Mul_Ov + | ON_Div_Ov + | ON_Rem_Ov + | ON_Mod_Ov + | ON_Xor => + Res := New_Dyadic_Op (Op, Left_Tree, Right_Tree); + when ON_Abs_Ov + | ON_Neg_Ov + | ON_Not => + Res := New_Monadic_Op (Op, Left_Tree); + when others => + Ada.Text_IO.Put_Line + ("translate_predefined_operator: cannot handle " + & ON_Op_Kind'Image (Op)); + raise Internal_Error; + end case; + Res := Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Loc); + return Res; + end if; + + case Kind is + when Iir_Predefined_Bit_Xnor + | Iir_Predefined_Boolean_Xnor => + return Translate_Predefined_Logical + (Iir_Predefined_Boolean_Xnor, Left_Tree, Right_Tree); + when Iir_Predefined_Bit_Match_Equality => + return New_Compare_Op (ON_Eq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + when Iir_Predefined_Bit_Match_Inequality => + return New_Compare_Op (ON_Neq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + + when Iir_Predefined_Bit_Condition => + return New_Compare_Op + (ON_Eq, Left_Tree, New_Lit (Get_Ortho_Expr (Bit_1)), + Std_Boolean_Type_Node); + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Physical_Identity => + return Translate_Implicit_Conv + (Left_Tree, Left_Type, Res_Type, Mode_Value, Loc); + + when Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality => + if Is_Composite (Get_Info (Left_Type)) then + -- a fat pointer. + declare + T : Type_Info_Acc; + B : Type_Info_Acc; + L, R : O_Dnode; + V1, V2 : O_Enode; + Op1, Op2 : ON_Op_Kind; + begin + if Kind = Iir_Predefined_Access_Equality then + Op1 := ON_Eq; + Op2 := ON_And; + else + Op1 := ON_Neq; + Op2 := ON_Or; + end if; + T := Get_Info (Left_Type); + B := Get_Info (Get_Designated_Type (Left_Type)); + L := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); + R := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (L), Left_Tree); + New_Assign_Stmt (New_Obj (R), Right_Tree); + V1 := New_Compare_Op + (Op1, + New_Value_Selected_Acc_Value + (New_Obj (L), B.T.Base_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (R), B.T.Base_Field (Mode_Value)), + Std_Boolean_Type_Node); + V2 := New_Compare_Op + (Op1, + New_Value_Selected_Acc_Value + (New_Obj (L), B.T.Bounds_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (R), B.T.Bounds_Field (Mode_Value)), + Std_Boolean_Type_Node); + return New_Dyadic_Op (Op2, V1, V2); + end; + else + -- a thin pointer. + if Kind = Iir_Predefined_Access_Equality then + return New_Compare_Op + (ON_Eq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); + else + return New_Compare_Op + (ON_Neq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); + end if; + end if; + + when Iir_Predefined_Physical_Integer_Div => + return New_Dyadic_Op (ON_Div_Ov, Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + when Iir_Predefined_Physical_Physical_Div => + return New_Convert_Ov + (New_Dyadic_Op (ON_Div_Ov, Left_Tree, Right_Tree), Res_Otype); + + -- LRM 7.2.6 + -- Multiplication of a value P of a physical type Tp by a + -- value I of type INTEGER is equivalent to the following + -- computation: Tp'Val (Tp'Pos (P) * I) + -- FIXME: this is not what is really done... + when Iir_Predefined_Integer_Physical_Mul => + return New_Dyadic_Op (ON_Mul_Ov, + New_Convert_Ov (Left_Tree, Res_Otype), + Right_Tree); + when Iir_Predefined_Physical_Integer_Mul => + return New_Dyadic_Op (ON_Mul_Ov, Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + + -- LRM 7.2.6 + -- Multiplication of a value P of a physical type Tp by a + -- value F of type REAL is equivalten to the following + -- computation: Tp'Val (INTEGER (REAL (Tp'Pos (P)) * F)) + -- FIXME: we do not restrict with INTEGER. + when Iir_Predefined_Physical_Real_Mul => + declare + Right_Otype : O_Tnode; + begin + Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, + New_Convert_Ov (Left_Tree, Right_Otype), + Right_Tree), + Res_Otype); + end; + when Iir_Predefined_Physical_Real_Div => + declare + Right_Otype : O_Tnode; + begin + Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Div_Ov, + New_Convert_Ov (Left_Tree, Right_Otype), + Right_Tree), + Res_Otype); + end; + when Iir_Predefined_Real_Physical_Mul => + declare + Left_Otype : O_Tnode; + begin + Left_Otype := Get_Ortho_Type (Left_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, + Left_Tree, + New_Convert_Ov (Right_Tree, Left_Otype)), + Res_Otype); + end; + + when Iir_Predefined_Universal_R_I_Mul => + return New_Dyadic_Op (ON_Mul_Ov, + Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + + when Iir_Predefined_Floating_Exp => + Res := Translate_Lib_Operator + (New_Convert_Ov (Left_Tree, Std_Real_Otype), + Right_Tree, Ghdl_Real_Exp); + return New_Convert_Ov (Res, Res_Otype); + when Iir_Predefined_Integer_Exp => + Res := Translate_Lib_Operator + (New_Convert_Ov (Left_Tree, Std_Integer_Otype), + Right_Tree, + Ghdl_Integer_Exp); + return New_Convert_Ov (Res, Res_Otype); + + when Iir_Predefined_Array_Inequality + | Iir_Predefined_Record_Inequality => + return New_Monadic_Op + (ON_Not, Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp)); + when Iir_Predefined_Array_Equality + | Iir_Predefined_Record_Equality => + return Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp); + + when Iir_Predefined_Array_Greater => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Gt), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Greater_Equal => + return New_Compare_Op + (ON_Ge, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Eq), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Less => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Lt), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Less_Equal => + return New_Compare_Op + (ON_Le, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Eq), + Std_Boolean_Type_Node); + + when Iir_Predefined_TF_Array_And + | Iir_Predefined_TF_Array_Or + | Iir_Predefined_TF_Array_Nand + | Iir_Predefined_TF_Array_Nor + | Iir_Predefined_TF_Array_Xor + | Iir_Predefined_TF_Array_Xnor + | Iir_Predefined_TF_Array_Not + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + return Translate_Predefined_Array_Operator_Convert + (Left_Tree, Right_Tree, Imp, Res_Type); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Right_Tree := New_Monadic_Op (ON_Neg_Ov, Right_Tree); + return Translate_Predefined_Array_Operator_Convert + (Left_Tree, Right_Tree, Imp, Res_Type); + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + return Translate_Concat_Operator + (Left_Tree, Right_Tree, Imp, Res_Type, Loc); + + when Iir_Predefined_Endfile => + return Translate_Lib_Operator + (Left_Tree, O_Enode_Null, Ghdl_File_Endfile); + + when Iir_Predefined_Now_Function => + return New_Obj_Value (Ghdl_Now); + + when Iir_Predefined_Std_Ulogic_Match_Equality => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Eq, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Inequality => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Ne, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Less => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Lt, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Less_Equal => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Le, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Greater => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Lt, + Right_Tree, Left_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Le, + Right_Tree, Left_Tree, Res_Otype); + + when Iir_Predefined_Bit_Array_Match_Equality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_True_Node), + Res_Otype); + when Iir_Predefined_Bit_Array_Match_Inequality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_False_Node), + Res_Otype); + + when Iir_Predefined_Array_Minimum => + return Translate_Predefined_Array_Min_Max + (True, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + when Iir_Predefined_Array_Maximum => + return Translate_Predefined_Array_Min_Max + (False, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + + when Iir_Predefined_Integer_To_String => + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_I32 => + return Translate_To_String + (Ghdl_To_String_I32, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_I32_Type)); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_To_String => + -- LRM08 5.7 String representations + -- - For a given value of type CHARACTER, [...] + -- + -- So special case for character. + if Get_Base_Type (Left_Type) = Character_Type_Definition then + return Translate_To_String + (Ghdl_To_String_Char, Res_Type, Loc, Left_Tree); + end if; + + -- LRM08 5.7 String representations + -- - For a given value of type other than CHARACTER, [...] + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_To_String_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_To_String_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_To_String_E32; + Conv := Ghdl_I32_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Floating_To_String => + return Translate_To_String + (Ghdl_To_String_F64, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type)); + when Iir_Predefined_Real_To_String_Digits => + return Translate_To_String + (Ghdl_To_String_F64_Digits, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type), + New_Convert_Ov (Right_Tree, Ghdl_I32_Type)); + when Iir_Predefined_Real_To_String_Format => + return Translate_To_String + (Ghdl_To_String_F64_Format, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type), + Right_Tree); + when Iir_Predefined_Physical_To_String => + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_P32 => + Subprg := Ghdl_To_String_P32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_To_String_P64; + Conv := Ghdl_I64_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Time_To_String_Unit => + return Translate_To_String + (Ghdl_Time_To_String_Unit, Res_Type, Loc, + Left_Tree, Right_Tree, + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + when Iir_Predefined_Bit_Vector_To_Ostring => + return Translate_Bv_To_String + (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Loc); + when Iir_Predefined_Bit_Vector_To_Hstring => + return Translate_Bv_To_String + (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Loc); + when Iir_Predefined_Array_Char_To_String => + declare + El_Type : constant Iir := Get_Element_Subtype (Left_Type); + Subprg : O_Dnode; + Arg : Mnode; + begin + Arg := Stabilize + (E2M (Left_Tree, Get_Info (Left_Type), Mode_Value)); + case Get_Info (El_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Array_Char_To_String_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Array_Char_To_String_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Array_Char_To_String_E32; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (Arg)), + Ghdl_Ptr_Type), + Chap3.Get_Array_Length (Arg, Left_Type), + New_Lit (Rtis.New_Rti_Address + (Get_Info (El_Type).Type_Rti))); + end; + + when others => + Ada.Text_IO.Put_Line + ("translate_predefined_operator(2): cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + return O_Enode_Null; + end case; + end Translate_Predefined_Operator; + + -- Assign EXPR to TARGET. + procedure Translate_Assign + (Target : Mnode; + Val : O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir) + is + T_Info : constant Type_Info_Acc := Get_Info (Target_Type); + begin + case T_Info.Type_Mode is + when Type_Mode_Scalar => + New_Assign_Stmt + (M2Lv (Target), + Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type)); + when Type_Mode_Acc + | Type_Mode_File => + New_Assign_Stmt (M2Lv (Target), Val); + when Type_Mode_Fat_Acc => + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Fat_Array => + declare + T : Mnode; + E : O_Dnode; + begin + T := Stabilize (Target); + E := Create_Temp_Init + (T_Info.Ortho_Ptr_Type (Mode_Value), Val); + Chap3.Check_Array_Match + (Target_Type, T, + Get_Type (Expr), Dp2M (E, T_Info, Mode_Value), Loc); + Chap3.Translate_Object_Copy + (T, New_Obj_Value (E), Target_Type); + end; + when Type_Mode_Array => + -- Source is of type TARGET_TYPE, so no length check is + -- necessary. + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Record => + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Assign; + + procedure Translate_Assign + (Target : Mnode; Expr : Iir; Target_Type : Iir) + is + Val : O_Enode; + begin + if Get_Kind (Expr) = Iir_Kind_Aggregate then + -- FIXME: handle overlap between TARGET and EXPR. + Translate_Aggregate (Target, Target_Type, Expr); + else + Open_Temp; + Val := Chap7.Translate_Expression (Expr, Target_Type); + Translate_Assign (Target, Val, Expr, Target_Type, Expr); + Close_Temp; + end if; + end Translate_Assign; + + -- If AGGR is of the form (others => (others => EXPR)) (where the + -- number of (others => ) sub-aggregate is at least 1, return EXPR + -- otherwise return NULL_IIR. + function Is_Aggregate_Others (Aggr : Iir_Aggregate) return Iir + is + Chain : Iir; + Aggr1 : Iir; + --Type_Info : Type_Info_Acc; + begin + Aggr1 := Aggr; + -- Do not use translate_aggregate_others for a complex type. + --Type_Info := Get_Info (Get_Type (Aggr)); + --if Type_Info.C /= null and then Type_Info.C.Builder_Need_Func then + -- return Null_Iir; + --end if; + loop + Chain := Get_Association_Choices_Chain (Aggr1); + if not Is_Chain_Length_One (Chain) then + return Null_Iir; + end if; + if Get_Kind (Chain) /= Iir_Kind_Choice_By_Others then + return Null_Iir; + end if; + Aggr1 := Get_Associated_Expr (Chain); + case Get_Kind (Aggr1) is + when Iir_Kind_Aggregate => + if Get_Type (Aggr1) /= Null_Iir then + -- Stop when a sub-aggregate is in fact an aggregate. + return Aggr1; + end if; + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return Null_Iir; + --Error_Kind ("is_aggregate_others", Aggr1); + when others => + return Aggr1; + end case; + end loop; + end Is_Aggregate_Others; + + -- Generate code for (others => EL). + procedure Translate_Aggregate_Others + (Target : Mnode; Target_Type : Iir; El : Iir) + is + Base_Ptr : Mnode; + Info : Type_Info_Acc; + It : O_Dnode; + Len : O_Dnode; + Len_Val : O_Enode; + Label : O_Snode; + Arr_Var : Mnode; + El_Node : Mnode; + begin + Open_Temp; + + Info := Get_Info (Target_Type); + case Info.Type_Mode is + when Type_Mode_Fat_Array => + Arr_Var := Stabilize (Target); + Base_Ptr := Stabilize (Chap3.Get_Array_Base (Arr_Var)); + Len_Val := Chap3.Get_Array_Length (Arr_Var, Target_Type); + when Type_Mode_Array => + Base_Ptr := Stabilize (Chap3.Get_Array_Base (Target)); + Len_Val := Chap3.Get_Array_Type_Length (Target_Type); + when others => + raise Internal_Error; + end case; + -- FIXME: use this (since this use one variable instead of two): + -- I := length; + -- loop + -- exit when I = 0; + -- I := I - 1; + -- A[I] := xxx; + -- end loop; + Len := Create_Temp_Init (Ghdl_Index_Type, Len_Val); + if True then + It := Create_Temp (Ghdl_Index_Type); + else + New_Var_Decl (It, Wki_I, O_Storage_Local, Ghdl_Index_Type); + end if; + Init_Var (It); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Eq, + New_Obj_Value (It), New_Obj_Value (Len), + Ghdl_Bool_Type)); + El_Node := Chap3.Index_Base (Base_Ptr, Target_Type, + New_Obj_Value (It)); + --New_Assign_Stmt (El_Node, Chap7.Translate_Expression (El)); + Translate_Assign (El_Node, El, Get_Element_Subtype (Target_Type)); + Inc_Var (It); + Finish_Loop_Stmt (Label); + + Close_Temp; + end Translate_Aggregate_Others; + + procedure Translate_Array_Aggregate_Gen + (Base_Ptr : Mnode; + Bounds_Ptr : Mnode; + Aggr : Iir; + Aggr_Type : Iir; + Dim : Natural; + Var_Index : O_Dnode) + is + Index_List : Iir_List; + Expr_Type : Iir; + Final : Boolean; + + procedure Do_Assign (Expr : Iir) + is + begin + if Final then + Translate_Assign (Chap3.Index_Base (Base_Ptr, Aggr_Type, + New_Obj_Value (Var_Index)), + Expr, Expr_Type); + Inc_Var (Var_Index); + else + Translate_Array_Aggregate_Gen + (Base_Ptr, Bounds_Ptr, Expr, Aggr_Type, Dim + 1, Var_Index); + end if; + end Do_Assign; + + P : Natural; + El : Iir; + begin + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + -- Continue below. + null; + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + declare + Len : constant Nat32 := Get_String_Length (Aggr); + + -- Type of the unconstrained array type. + Arr_Type : O_Tnode; + + -- Type of the constrained array type. + Str_Type : O_Tnode; + + Cst : Var_Type; + Var_I : O_Dnode; + Label : O_Snode; + begin + Expr_Type := Get_Element_Subtype (Aggr_Type); + + -- Create a constant for the string. + -- First, create its type, because the literal has no + -- type (subaggregate). + Arr_Type := New_Array_Type + (Get_Ortho_Type (Expr_Type, Mode_Value), + Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Arr_Type); + Str_Type := New_Constrained_Array_Type + (Arr_Type, New_Index_Lit (Unsigned_64 (Len))); + Cst := Create_String_Literal_Var_Inner + (Aggr, Expr_Type, Str_Type); + + -- Copy it. + Open_Temp; + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Lit (New_Index_Lit (Nat32'Pos (Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt + (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, + New_Obj_Value (Var_Index))), + New_Value (New_Indexed_Element (Get_Var (Cst), + New_Obj_Value (Var_I)))); + Inc_Var (Var_I); + Inc_Var (Var_Index); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + return; + when others => + raise Internal_Error; + end case; + + Index_List := Get_Index_Subtype_List (Aggr_Type); + + -- FINAL is true if the elements of the aggregate are elements of + -- the array. + if Get_Nbr_Elements (Index_List) = Dim then + Expr_Type := Get_Element_Subtype (Aggr_Type); + Final:= True; + else + Final := False; + end if; + + El := Get_Association_Choices_Chain (Aggr); + + -- First, assign positionnal association. + -- FIXME: count the number of positionnal association and generate + -- an error if there is more positionnal association than elements + -- in the array. + P := 0; + loop + if El = Null_Iir then + -- There is only positionnal associations. + return; + end if; + exit when Get_Kind (El) /= Iir_Kind_Choice_By_None; + Do_Assign (Get_Associated_Expr (El)); + P := P + 1; + El := Get_Chain (El); + end loop; + + -- Then, assign named or others association. + if Get_Chain (El) = Null_Iir then + -- There is only one choice + case Get_Kind (El) is + when Iir_Kind_Choice_By_Others => + -- falltrough... + null; + when Iir_Kind_Choice_By_Expression => + Do_Assign (Get_Associated_Expr (El)); + return; + when Iir_Kind_Choice_By_Range => + declare + Var_Length : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + begin + Open_Temp; + Var_Length := Create_Temp_Init + (Ghdl_Index_Type, + Chap7.Translate_Range_Length (Get_Choice_Range (El))); + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Do_Assign (Get_Associated_Expr (El)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + return; + when others => + Error_Kind ("translate_array_aggregate_gen", El); + end case; + end if; + + -- Several choices.. + declare + Range_Type : Iir; + Var_Pos : O_Dnode; + Var_Len : O_Dnode; + Range_Ptr : Mnode; + Rtinfo : Type_Info_Acc; + If_Blk : O_If_Block; + Case_Blk : O_Case_Block; + Label : O_Snode; + El_Assoc : Iir; + Len_Tmp : O_Enode; + begin + Open_Temp; + -- Create a loop from left +- number of positionnals associations + -- to/downto right. + Range_Type := + Get_Base_Type (Get_Nth_Element (Index_List, Dim - 1)); + Rtinfo := Get_Info (Range_Type); + Var_Pos := Create_Temp (Rtinfo.Ortho_Type (Mode_Value)); + Range_Ptr := Stabilize + (Chap3.Bounds_To_Range (Bounds_Ptr, Aggr_Type, Dim)); + New_Assign_Stmt (New_Obj (Var_Pos), + M2E (Chap3.Range_To_Left (Range_Ptr))); + Var_Len := Create_Temp (Ghdl_Index_Type); + if P /= 0 then + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (P), + Range_Type); + New_Else_Stmt (If_Blk); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (P), + Range_Type); + Finish_If_Stmt (If_Blk); + end if; + + Len_Tmp := M2E (Chap3.Range_To_Length (Range_Ptr)); + if P /= 0 then + Len_Tmp := New_Dyadic_Op + (ON_Sub_Ov, + Len_Tmp, + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (P)))); + end if; + New_Assign_Stmt (New_Obj (Var_Len), Len_Tmp); + + -- Start loop. + Start_Loop_Stmt (Label); + -- Check if end of loop. + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + + -- convert aggr into a case statement. + Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Pos)); + El_Assoc := Null_Iir; + while El /= Null_Iir loop + Start_Choice (Case_Blk); + Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk); + if Get_Associated_Expr (El) /= Null_Iir then + El_Assoc := Get_Associated_Expr (El); + end if; + Finish_Choice (Case_Blk); + Do_Assign (El_Assoc); + P := P + 1; + El := Get_Chain (El); + end loop; + Finish_Case_Stmt (Case_Blk); + -- Update var_pos + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (1), + Range_Type); + New_Else_Stmt (If_Blk); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (1), + Range_Type); + Finish_If_Stmt (If_Blk); + New_Assign_Stmt + (New_Obj (Var_Len), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Len), + New_Lit (Ghdl_Index_1))); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + end Translate_Array_Aggregate_Gen; + + procedure Translate_Record_Aggregate (Target : Mnode; Aggr : Iir) + is + Targ : Mnode; + Aggr_Type : constant Iir := Get_Type (Aggr); + Aggr_Base_Type : constant Iir_Record_Type_Definition := + Get_Base_Type (Aggr_Type); + El_List : constant Iir_List := + Get_Elements_Declaration_List (Aggr_Base_Type); + El_Index : Natural; + Nbr_El : constant Natural := Get_Nbr_Elements (El_List); + + -- Record which elements of the record have been set. The 'others' + -- clause applies to all elements not already set. + type Bool_Array_Type is array (0 .. Nbr_El - 1) of Boolean; + pragma Pack (Bool_Array_Type); + Set_Array : Bool_Array_Type := (others => False); + + -- The expression associated. + El_Expr : Iir; + + -- Set an elements. + procedure Set_El (El : Iir_Element_Declaration) is + begin + Translate_Assign (Chap6.Translate_Selected_Element (Targ, El), + El_Expr, Get_Type (El)); + Set_Array (Natural (Get_Element_Position (El))) := True; + end Set_El; + + Assoc : Iir; + N_El_Expr : Iir; + begin + Open_Temp; + Targ := Stabilize (Target); + El_Index := 0; + Assoc := Get_Association_Choices_Chain (Aggr); + while Assoc /= Null_Iir loop + N_El_Expr := Get_Associated_Expr (Assoc); + if N_El_Expr /= Null_Iir then + El_Expr := N_El_Expr; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + Set_El (Get_Nth_Element (El_List, El_Index)); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Set_El (Get_Choice_Name (Assoc)); + El_Index := Natural'Last; + when Iir_Kind_Choice_By_Others => + for J in Set_Array'Range loop + if not Set_Array (J) then + Set_El (Get_Nth_Element (El_List, J)); + end if; + end loop; + when others => + Error_Kind ("translate_record_aggregate", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + Close_Temp; + end Translate_Record_Aggregate; + + procedure Translate_Array_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir) + is + Aggr_Type : constant Iir := Get_Type (Aggr); + Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); + Targ_Index_List : constant Iir_List := + Get_Index_Subtype_List (Target_Type); + + Aggr_Info : Iir_Aggregate_Info; + Base : Mnode; + Bounds : Mnode; + Var_Index : O_Dnode; + Targ : Mnode; + + Rinfo : Type_Info_Acc; + Bt : Iir; + + -- Generate code for: (LVAL lop RNG.left) or (RVAL rop RNG.right) + function Check_Value (Lval : Iir; + Lop : ON_Op_Kind; + Rval : Iir; + Rop : ON_Op_Kind; + Rng : Mnode) + return O_Enode + is + L, R : O_Enode; + begin + L := New_Compare_Op + (Lop, + New_Lit (Translate_Static_Expression (Lval, Bt)), + M2E (Chap3.Range_To_Left (Rng)), + Ghdl_Bool_Type); + R := New_Compare_Op + (Rop, + New_Lit (Translate_Static_Expression (Rval, Bt)), + M2E (Chap3.Range_To_Right (Rng)), + Ghdl_Bool_Type); + return New_Dyadic_Op (ON_Or, L, R); + end Check_Value; + + Range_Ptr : Mnode; + Subtarg_Type : Iir; + Subaggr_Type : Iir; + L, H : Iir; + Min : Iir_Int32; + Has_Others : Boolean; + + Var_Err : O_Dnode; + E : O_Enode; + If_Blk : O_If_Block; + Op : ON_Op_Kind; + begin + Open_Temp; + Targ := Stabilize (Target); + Base := Stabilize (Chap3.Get_Array_Base (Targ)); + Bounds := Stabilize (Chap3.Get_Array_Bounds (Targ)); + Aggr_Info := Get_Aggregate_Info (Aggr); + + -- Check type + for I in Natural loop + Subaggr_Type := Get_Index_Type (Index_List, I); + exit when Subaggr_Type = Null_Iir; + Subtarg_Type := Get_Index_Type (Targ_Index_List, I); + + Bt := Get_Base_Type (Subaggr_Type); + Rinfo := Get_Info (Bt); + + if Get_Aggr_Dynamic_Flag (Aggr_Info) then + -- Dynamic range, must evaluate it. + Open_Temp; + declare + A_Range : O_Dnode; + Rng_Ptr : O_Dnode; + begin + -- Evaluate the range. + Chap3.Translate_Anonymous_Type_Definition + (Subaggr_Type, True); + + A_Range := Create_Temp (Rinfo.T.Range_Type); + Rng_Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, New_Obj (A_Range)); + Chap7.Translate_Range_Ptr + (Rng_Ptr, + Get_Range_Constraint (Subaggr_Type), + Subaggr_Type); + + -- Check range length VS target length. + Chap6.Check_Bound_Error + (New_Compare_Op + (ON_Neq, + M2E (Chap3.Range_To_Length + (Dv2M (A_Range, + Rinfo, + Mode_Value, + Rinfo.T.Range_Type, + Rinfo.T.Range_Ptr_Type))), + M2E (Chap3.Range_To_Length + (Chap3.Bounds_To_Range + (Bounds, Target_Type, I + 1))), + Ghdl_Bool_Type), + Aggr, I); + end; + Close_Temp; + elsif Get_Type_Staticness (Subaggr_Type) /= Locally + or else Subaggr_Type /= Subtarg_Type + then + -- Note: if the aggregate has no others, then the bounds + -- must be the same, otherwise, aggregate bounds must be + -- inside type bounds. + Has_Others := Get_Aggr_Others_Flag (Aggr_Info); + Min := Get_Aggr_Min_Length (Aggr_Info); + L := Get_Aggr_Low_Limit (Aggr_Info); + + if Min > 0 or L /= Null_Iir then + Open_Temp; + + -- Pointer to the range. + Range_Ptr := Stabilize + (Chap3.Bounds_To_Range (Bounds, Target_Type, I + 1)); + Var_Err := Create_Temp (Ghdl_Bool_Type); + H := Get_Aggr_High_Limit (Aggr_Info); + + if L /= Null_Iir then + -- Check the index range of the aggregrate is equal + -- (or within in presence of 'others') the index range + -- of the target. + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + if Has_Others then + E := Check_Value (L, ON_Lt, H, ON_Gt, Range_Ptr); + else + E := Check_Value (L, ON_Neq, H, ON_Neq, Range_Ptr); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + New_Else_Stmt (If_Blk); + if Has_Others then + E := Check_Value (H, ON_Gt, L, ON_Lt, Range_Ptr); + else + E := Check_Value (H, ON_Neq, L, ON_Neq, Range_Ptr); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + Finish_If_Stmt (If_Blk); + -- If L and H are greather than the minimum length, + -- then there is no need to check with min. + if Iir_Int32 (Eval_Pos (H) - Eval_Pos (L) + 1) >= Min then + Min := 0; + end if; + end if; + + if Min > 0 then + -- Check the number of elements is equal (or less in + -- presence of 'others') than the length of the index + -- range of the target. + if Has_Others then + Op := ON_Lt; + else + Op := ON_Neq; + end if; + E := New_Compare_Op + (Op, + M2E (Chap3.Range_To_Length (Range_Ptr)), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Min))), + Ghdl_Bool_Type); + if L /= Null_Iir then + E := New_Dyadic_Op (ON_Or, E, New_Obj_Value (Var_Err)); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + end if; + Chap6.Check_Bound_Error (New_Obj_Value (Var_Err), Aggr, I); + Close_Temp; + end if; + end if; + + -- Next dimension. + Aggr_Info := Get_Sub_Aggregate_Info (Aggr_Info); + end loop; + + Var_Index := Create_Temp_Init + (Ghdl_Index_Type, New_Lit (Ghdl_Index_0)); + Translate_Array_Aggregate_Gen + (Base, Bounds, Aggr, Aggr_Type, 1, Var_Index); + Close_Temp; + + -- FIXME: creating aggregate subtype is expensive and rarely used. + -- (one of the current use - only ? - is check_array_match). + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False); + end Translate_Array_Aggregate; + + procedure Translate_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir) + is + Aggr_Type : constant Iir := Get_Type (Aggr); + El : Iir; + begin + case Get_Kind (Aggr_Type) is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + El := Is_Aggregate_Others (Aggr); + if El /= Null_Iir then + Translate_Aggregate_Others (Target, Target_Type, El); + else + Translate_Array_Aggregate (Target, Target_Type, Aggr); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Record_Aggregate (Target, Aggr); + when others => + Error_Kind ("translate_aggregate", Aggr_Type); + end case; + end Translate_Aggregate; + + function Translate_Allocator_By_Expression (Expr : Iir) + return O_Enode + is + Val : O_Enode; + Val_M : Mnode; + A_Type : constant Iir := Get_Type (Expr); + A_Info : constant Type_Info_Acc := Get_Info (A_Type); + D_Type : constant Iir := Get_Designated_Type (A_Type); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + R : Mnode; + Rtype : O_Tnode; + begin + -- Compute the expression. + Val := Translate_Expression (Get_Expression (Expr), D_Type); + -- Allocate memory for the object. + case A_Info.Type_Mode is + when Type_Mode_Fat_Acc => + R := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), + D_Info, Mode_Value); + Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); + Chap3.Translate_Object_Allocation + (R, Alloc_Heap, D_Type, + Chap3.Get_Array_Bounds (Val_M)); + Val := M2E (Val_M); + Rtype := A_Info.Ortho_Ptr_Type (Mode_Value); + when Type_Mode_Acc => + R := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), + D_Info, Mode_Value); + Chap3.Translate_Object_Allocation + (R, Alloc_Heap, D_Type, Mnode_Null); + Rtype := A_Info.Ortho_Type (Mode_Value); + when others => + raise Internal_Error; + end case; + Chap3.Translate_Object_Copy (R, Val, D_Type); + return New_Convert_Ov (M2Addr (R), Rtype); + end Translate_Allocator_By_Expression; + + function Translate_Allocator_By_Subtype (Expr : Iir) + return O_Enode + is + P_Type : constant Iir := Get_Type (Expr); + P_Info : constant Type_Info_Acc := Get_Info (P_Type); + D_Type : constant Iir := Get_Designated_Type (P_Type); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + Sub_Type : Iir; + Bounds : Mnode; + Res : Mnode; + Rtype : O_Tnode; + begin + case P_Info.Type_Mode is + when Type_Mode_Fat_Acc => + Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), + D_Info, Mode_Value); + -- FIXME: should allocate bounds, and directly set bounds + -- from the range. + Sub_Type := Get_Subtype_Indication (Expr); + Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); + Chap3.Create_Array_Subtype (Sub_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Sub_Type); + Rtype := P_Info.Ortho_Ptr_Type (Mode_Value); + when Type_Mode_Acc => + Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), + D_Info, Mode_Value); + Bounds := Mnode_Null; + Rtype := P_Info.Ortho_Type (Mode_Value); + when others => + raise Internal_Error; + end case; + Chap3.Translate_Object_Allocation (Res, Alloc_Heap, D_Type, Bounds); + Chap4.Init_Object (Res, D_Type); + return New_Convert_Ov (M2Addr (Res), Rtype); + end Translate_Allocator_By_Subtype; + + function Translate_Fat_Array_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode; + + function Translate_Array_Subtype_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + E : Mnode; + begin + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); + case Res_Info.Type_Mode is + when Type_Mode_Array => + Chap3.Check_Array_Match + (Res_Type, T2M (Res_Type, Mode_Value), + Expr_Type, E, + Loc); + return New_Convert_Ov + (M2Addr (Chap3.Get_Array_Base (E)), + Res_Info.Ortho_Ptr_Type (Mode_Value)); + when Type_Mode_Fat_Array => + declare + Res : Mnode; + begin + Res := Create_Temp (Res_Info); + Copy_Fat_Pointer (Res, E); + Chap3.Check_Array_Match (Res_Type, Res, Expr_Type, E, Loc); + return M2Addr (Res); + end; + when others => + Error_Kind ("translate_array_subtype_conversion", Res_Type); + end case; + end Translate_Array_Subtype_Conversion; + + function Translate_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Res : O_Enode; + begin + case Get_Kind (Res_Type) is + when Iir_Kinds_Scalar_Type_Definition => + Res := New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); + if Chap3.Need_Range_Check (Null_Iir, Res_Type) then + Res := Chap3.Insert_Scalar_Check + (Res, Null_Iir, Res_Type, Loc); + end if; + return Res; + when Iir_Kinds_Array_Type_Definition => + if Get_Constraint_State (Res_Type) = Fully_Constrained then + return Translate_Array_Subtype_Conversion + (Expr, Expr_Type, Res_Type, Loc); + else + return Translate_Fat_Array_Type_Conversion + (Expr, Expr_Type, Res_Type, Loc); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Expr; + when others => + Error_Kind ("translate_type_conversion", Res_Type); + end case; + end Translate_Type_Conversion; + + function Translate_Fat_Array_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + Res_Indexes : constant Iir_List := + Get_Index_Subtype_List (Res_Type); + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + + Res_Base_Type : constant Iir := Get_Base_Type (Res_Type); + Expr_Base_Type : constant Iir := Get_Base_Type (Expr_Type); + Res_Base_Indexes : constant Iir_List := + Get_Index_Subtype_List (Res_Base_Type); + Expr_Base_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Base_Type); + Res : Mnode; + E : Mnode; + Bounds : O_Dnode; + R_El : Iir; + E_El : Iir; + begin + Res := Create_Temp (Res_Info, Mode_Value); + Bounds := Create_Temp (Res_Info.T.Bounds_Type); + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); + Open_Temp; + -- Set base. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (E)), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + -- Set bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + New_Address (New_Obj (Bounds), Res_Info.T.Bounds_Ptr_Type)); + + -- Convert bounds. + for I in Natural loop + R_El := Get_Index_Type (Res_Indexes, I); + E_El := Get_Index_Type (Expr_Indexes, I); + exit when R_El = Null_Iir; + declare + Rb_Ptr : Mnode; + Eb_Ptr : Mnode; + Ee : O_Enode; + Same_Index_Type : constant Boolean := + (Get_Index_Type (Res_Base_Indexes, I) + = Get_Index_Type (Expr_Base_Indexes, I)); + begin + Open_Temp; + Rb_Ptr := Stabilize + (Chap3.Get_Array_Range (Res, Res_Type, I + 1)); + Eb_Ptr := Stabilize + (Chap3.Get_Array_Range (E, Expr_Type, I + 1)); + -- Convert left and right (unless they have the same type - + -- this is an optimization but also this deals with null + -- array in common cases). + Ee := M2E (Chap3.Range_To_Left (Eb_Ptr)); + if not Same_Index_Type then + Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); + end if; + New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Rb_Ptr)), Ee); + Ee := M2E (Chap3.Range_To_Right (Eb_Ptr)); + if not Same_Index_Type then + Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); + end if; + New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Rb_Ptr)), Ee); + -- Copy Dir and Length. + New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Rb_Ptr)), + M2E (Chap3.Range_To_Dir (Eb_Ptr))); + New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Rb_Ptr)), + M2E (Chap3.Range_To_Length (Eb_Ptr))); + Close_Temp; + end; + end loop; + Close_Temp; + return M2E (Res); + end Translate_Fat_Array_Type_Conversion; + + function Sig2val_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + if Get_Type_Info (Data).Type_Mode = Type_Mode_Fat_Array then + return Stabilize (Chap3.Get_Array_Base (Data)); + else + return Stabilize (Data); + end if; + end Sig2val_Prepare_Composite; + + function Sig2val_Update_Data_Array + (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) return Mnode + is + begin + return Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index)); + end Sig2val_Update_Data_Array; + + function Sig2val_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return Mnode + is + pragma Unreferenced (Targ_Type); + begin + return Chap6.Translate_Selected_Element (Val, El); + end Sig2val_Update_Data_Record; + + procedure Sig2val_Finish_Data_Composite (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Sig2val_Finish_Data_Composite; + + procedure Translate_Signal_Assign_Effective_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Mnode) + is + pragma Unreferenced (Targ_Type); + begin + New_Assign_Stmt (New_Access_Element (M2E (Targ)), M2E (Data)); + end Translate_Signal_Assign_Effective_Non_Composite; + + procedure Translate_Signal_Assign_Effective is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Assign_Effective_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + procedure Translate_Signal_Assign_Driving_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data: Mnode) + is + begin + New_Assign_Stmt + (Chap14.Get_Signal_Value_Field (M2E (Targ), Targ_Type, + Ghdl_Signal_Driving_Value_Field), + M2E (Data)); + end Translate_Signal_Assign_Driving_Non_Composite; + + procedure Translate_Signal_Assign_Driving is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Assign_Driving_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + procedure Translate_Signal_Non_Composite + (Targ : Mnode; + Targ_Type : Iir; + Data : Mnode) + is + begin + New_Assign_Stmt (M2Lv (Targ), + Read_Value (M2E (Data), Targ_Type)); + end Translate_Signal_Non_Composite; + + procedure Translate_Signal_Target is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Info (Sig_Type); + if Tinfo.Type_Mode in Type_Mode_Scalar then + return Read_Value (Sig, Sig_Type); + else + declare + Res : Mnode; + Var_Val : Mnode; + begin + -- allocate result array + if Tinfo.Type_Mode = Type_Mode_Fat_Array then + Res := Create_Temp (Tinfo); + + Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); + + -- Copy bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Var_Val))); + + -- Allocate base. + Chap3.Allocate_Fat_Array_Base (Alloc_Stack, Res, Sig_Type); + elsif Is_Complex_Type (Tinfo) then + Res := Create_Temp (Tinfo); + Chap4.Allocate_Complex_Object (Sig_Type, Alloc_Stack, Res); + else + Res := Create_Temp (Tinfo); + end if; + + Open_Temp; + + if Tinfo.Type_Mode /= Type_Mode_Fat_Array then + Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); + end if; + + Translate_Signal_Target (Res, Sig_Type, Var_Val); + Close_Temp; + return M2Addr (Res); + end; + end if; + end Translate_Signal_Value; + + -- Get the effective value of a simple signal SIG. + function Read_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + pragma Unreferenced (Sig_Type); + begin + return New_Value (New_Access_Element (Sig)); + end Read_Signal_Value; + + -- Get the value of signal SIG. + function Translate_Signal is new Translate_Signal_Value + (Read_Value => Read_Signal_Value); + + function Translate_Signal_Effective_Value + (Sig : O_Enode; Sig_Type : Iir) return O_Enode + renames Translate_Signal; + + function Read_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode is + begin + return New_Value (Chap14.Get_Signal_Value_Field + (Sig, Sig_Type, Ghdl_Signal_Driving_Value_Field)); + end Read_Signal_Driving_Value; + + function Translate_Signal_Driving_Value_1 is new Translate_Signal_Value + (Read_Value => Read_Signal_Driving_Value); + + function Translate_Signal_Driving_Value + (Sig : O_Enode; Sig_Type : Iir) return O_Enode + renames Translate_Signal_Driving_Value_1; + + procedure Set_Effective_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode) + renames Translate_Signal_Assign_Effective; + procedure Set_Driving_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode) + renames Translate_Signal_Assign_Driving; + + function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) + return O_Enode + is + Imp : Iir; + Expr_Type : Iir; + Res_Type : Iir; + Res : O_Enode; + begin + Expr_Type := Get_Type (Expr); + if Rtype = Null_Iir then + Res_Type := Expr_Type; + else + Res_Type := Rtype; + end if; + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal => + return New_Lit (Translate_Static_Expression (Expr, Rtype)); + + when Iir_Kind_Physical_Int_Literal => + declare + Unit : Iir; + Unit_Info : Object_Info_Acc; + begin + Unit := Get_Unit_Name (Expr); + Unit_Info := Get_Info (Unit); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + return New_Dyadic_Op + (ON_Mul_Ov, + New_Lit (New_Signed_Literal + (Get_Ortho_Type (Expr_Type, Mode_Value), + Integer_64 (Get_Value (Expr)))), + New_Value (Get_Var (Unit_Info.Object_Var))); + end if; + end; + + when Iir_Kind_Physical_Fp_Literal => + declare + Unit : Iir; + Unit_Info : Object_Info_Acc; + L, R : O_Enode; + begin + Unit := Get_Unit_Name (Expr); + Unit_Info := Get_Info (Unit); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + L := New_Lit + (New_Float_Literal + (Ghdl_Real_Type, IEEE_Float_64 (Get_Fp_Value (Expr)))); + R := New_Convert_Ov + (New_Value (Get_Var (Unit_Info.Object_Var)), + Ghdl_Real_Type); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, L, R), + Get_Ortho_Type (Expr_Type, Mode_Value)); + end if; + end; + + when Iir_Kind_Unit_Declaration => + declare + Unit_Info : Object_Info_Acc; + begin + Unit_Info := Get_Info (Expr); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + return New_Value (Get_Var (Unit_Info.Object_Var)); + end if; + end; + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Simple_Name_Attribute => + Res := Translate_String_Literal (Expr); + + when Iir_Kind_Aggregate => + declare + Aggr_Type : Iir; + Tinfo : Type_Info_Acc; + Mres : Mnode; + begin + -- Extract the type of the aggregate. Use the type of the + -- context if it is fully constrained. + pragma Assert (Rtype /= Null_Iir); + if Is_Fully_Constrained_Type (Rtype) then + Aggr_Type := Rtype; + else + Aggr_Type := Expr_Type; + end if; + if Get_Kind (Aggr_Type) = Iir_Kind_Array_Subtype_Definition + then + Chap3.Create_Array_Subtype (Aggr_Type, True); + end if; + + -- FIXME: this may be not necessary + Tinfo := Get_Info (Aggr_Type); + + -- The result area has to be created + if Is_Complex_Type (Tinfo) then + Mres := Create_Temp (Tinfo); + Chap4.Allocate_Complex_Object + (Aggr_Type, Alloc_Stack, Mres); + else + -- if thin array/record: + -- create result + Mres := Create_Temp (Tinfo); + end if; + + Translate_Aggregate (Mres, Aggr_Type, Expr); + Res := M2E (Mres); + + if Aggr_Type /= Rtype then + Res := Translate_Implicit_Conv + (Res, Aggr_Type, Rtype, Mode_Value, Expr); + end if; + return Res; + end; + + when Iir_Kind_Null_Literal => + declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); + L : O_Dnode; + B : Type_Info_Acc; + begin + if Tinfo.Type_Mode = Type_Mode_Fat_Acc then + -- Create a fat null pointer. + -- FIXME: should be optimized!! + L := Create_Temp (Otype); + B := Get_Info (Get_Designated_Type (Expr_Type)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (L), + B.T.Base_Field (Mode_Value)), + New_Lit + (New_Null_Access (B.T.Base_Ptr_Type (Mode_Value)))); + New_Assign_Stmt + (New_Selected_Element + (New_Obj (L), B.T.Bounds_Field (Mode_Value)), + New_Lit (New_Null_Access (B.T.Bounds_Ptr_Type))); + return New_Address (New_Obj (L), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + else + return New_Lit (New_Null_Access (Otype)); + end if; + end; + + when Iir_Kind_Overflow_Literal => + declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); + L : O_Dnode; + begin + -- Generate the error message + Chap6.Gen_Bound_Error (Expr); + + -- Create a dummy value + L := Create_Temp (Otype); + if Tinfo.Type_Mode = Type_Mode_Fat_Acc then + return New_Address (New_Obj (L), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + else + return New_Obj_Value (L); + end if; + end; + + when Iir_Kind_Parenthesis_Expression => + return Translate_Expression (Get_Expression (Expr), Rtype); + + when Iir_Kind_Allocator_By_Expression => + return Translate_Allocator_By_Expression (Expr); + when Iir_Kind_Allocator_By_Subtype => + return Translate_Allocator_By_Subtype (Expr); + + when Iir_Kind_Qualified_Expression => + -- FIXME: check type. + Res := Translate_Expression (Get_Expression (Expr), Expr_Type); + + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Attribute_Name => + declare + L : Mnode; + begin + L := Chap6.Translate_Name (Expr); + + Res := M2E (L); + if Get_Object_Kind (L) = Mode_Signal then + Res := Translate_Signal (Res, Expr_Type); + end if; + end; + + when Iir_Kind_Iterator_Declaration => + declare + Expr_Info : Ortho_Info_Acc; + begin + Expr_Info := Get_Info (Expr); + Res := New_Value (Get_Var (Expr_Info.Iterator_Var)); + if Rtype /= Null_Iir then + Res := New_Convert_Ov + (Res, Get_Ortho_Type (Rtype, Mode_Value)); + end if; + return Res; + end; + + when Iir_Kinds_Dyadic_Operator => + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then + return Translate_Predefined_Operator + (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type, Expr); + else + return Translate_Operator_Function_Call + (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type); + end if; + when Iir_Kinds_Monadic_Operator => + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then + return Translate_Predefined_Operator + (Imp, Get_Operand (Expr), Null_Iir, Res_Type, Expr); + else + return Translate_Operator_Function_Call + (Imp, Get_Operand (Expr), Null_Iir, Res_Type); + end if; + when Iir_Kind_Function_Call => + Imp := Get_Implementation (Expr); + declare + Assoc_Chain : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration + then + declare + Left, Right : Iir; + begin + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + if Assoc_Chain = Null_Iir then + Left := Null_Iir; + Right := Null_Iir; + else + Left := Get_Actual (Assoc_Chain); + Assoc_Chain := Get_Chain (Assoc_Chain); + if Assoc_Chain = Null_Iir then + Right := Null_Iir; + else + Right := Get_Actual (Assoc_Chain); + end if; + end if; + return Translate_Predefined_Operator + (Imp, Left, Right, Res_Type, Expr); + end; + else + Canon.Canon_Subprogram_Call (Expr); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Res := Translate_Function_Call + (Imp, Assoc_Chain, Get_Method_Object (Expr)); + Expr_Type := Get_Return_Type (Imp); + end if; + end; + + when Iir_Kind_Type_Conversion => + declare + Conv_Expr : Iir; + begin + Conv_Expr := Get_Expression (Expr); + Res := Translate_Type_Conversion + (Translate_Expression (Conv_Expr), Get_Type (Conv_Expr), + Expr_Type, Expr); + end; + + when Iir_Kind_Length_Array_Attribute => + return Chap14.Translate_Length_Array_Attribute + (Expr, Res_Type); + when Iir_Kind_Low_Array_Attribute => + return Chap14.Translate_Low_Array_Attribute (Expr); + when Iir_Kind_High_Array_Attribute => + return Chap14.Translate_High_Array_Attribute (Expr); + when Iir_Kind_Left_Array_Attribute => + return Chap14.Translate_Left_Array_Attribute (Expr); + when Iir_Kind_Right_Array_Attribute => + return Chap14.Translate_Right_Array_Attribute (Expr); + when Iir_Kind_Ascending_Array_Attribute => + return Chap14.Translate_Ascending_Array_Attribute (Expr); + + when Iir_Kind_Val_Attribute => + return Chap14.Translate_Val_Attribute (Expr); + when Iir_Kind_Pos_Attribute => + return Chap14.Translate_Pos_Attribute (Expr, Res_Type); + + when Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute => + return Chap14.Translate_Succ_Pred_Attribute (Expr); + + when Iir_Kind_Image_Attribute => + Res := Chap14.Translate_Image_Attribute (Expr); + + when Iir_Kind_Value_Attribute => + return Chap14.Translate_Value_Attribute (Expr); + + when Iir_Kind_Event_Attribute => + return Chap14.Translate_Event_Attribute (Expr); + when Iir_Kind_Active_Attribute => + return Chap14.Translate_Active_Attribute (Expr); + when Iir_Kind_Last_Value_Attribute => + Res := Chap14.Translate_Last_Value_Attribute (Expr); + + when Iir_Kind_High_Type_Attribute => + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), True); + when Iir_Kind_Low_Type_Attribute => + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), False); + when Iir_Kind_Left_Type_Attribute => + return M2E + (Chap3.Range_To_Left + (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), + Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); + when Iir_Kind_Right_Type_Attribute => + return M2E + (Chap3.Range_To_Right + (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), + Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); + + when Iir_Kind_Last_Event_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Event_Field); + when Iir_Kind_Last_Active_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Active_Field); + + when Iir_Kind_Driving_Value_Attribute => + Res := Chap14.Translate_Driving_Value_Attribute (Expr); + when Iir_Kind_Driving_Attribute => + Res := Chap14.Translate_Driving_Attribute (Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + Res := Chap14.Translate_Path_Instance_Name_Attribute (Expr); + + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Selected_Name => + return Translate_Expression (Get_Named_Entity (Expr), Rtype); + + when others => + Error_Kind ("translate_expression", Expr); + end case; + + -- Quick test to avoid useless calls. + if Expr_Type /= Res_Type then + Res := Translate_Implicit_Conv + (Res, Expr_Type, Res_Type, Mode_Value, Expr); + end if; + + return Res; + end Translate_Expression; + + -- Check if RNG is of the form: + -- 1 to T'length + -- or T'Length downto 1 + -- or 0 to T'length - 1 + -- or T'Length - 1 downto 0 + -- In either of these cases, return T'Length + function Is_Length_Range_Expression (Rng : Iir_Range_Expression) + return Iir + is + -- Pattern of a bound. + type Length_Pattern is + ( + Pat_Unknown, + Pat_Length, + Pat_Length_1, -- Length - 1 + Pat_1, + Pat_0 + ); + Length_Attr : Iir := Null_Iir; + + -- Classify the bound. + -- Set LENGTH_ATTR is the pattern is Pat_Length. + function Get_Length_Pattern (Expr : Iir; Recurse : Boolean) + return Length_Pattern + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Length_Array_Attribute => + Length_Attr := Expr; + return Pat_Length; + when Iir_Kind_Integer_Literal => + case Get_Value (Expr) is + when 0 => + return Pat_0; + when 1 => + return Pat_1; + when others => + return Pat_Unknown; + end case; + when Iir_Kind_Substraction_Operator => + if not Recurse then + return Pat_Unknown; + end if; + if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length + and then + Get_Length_Pattern (Get_Right (Expr), False) = Pat_1 + then + return Pat_Length_1; + else + return Pat_Unknown; + end if; + when others => + return Pat_Unknown; + end case; + end Get_Length_Pattern; + Left_Pat, Right_Pat : Length_Pattern; + begin + Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True); + if Left_Pat = Pat_Unknown then + return Null_Iir; + end if; + Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True); + if Right_Pat = Pat_Unknown then + return Null_Iir; + end if; + case Get_Direction (Rng) is + when Iir_To => + if (Left_Pat = Pat_1 and Right_Pat = Pat_Length) + or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1) + then + return Length_Attr; + end if; + when Iir_Downto => + if (Left_Pat = Pat_Length and Right_Pat = Pat_1) + or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0) + then + return Length_Attr; + end if; + end case; + return Null_Iir; + end Is_Length_Range_Expression; + + procedure Translate_Range_Expression_Ptr + (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir) + is + T_Info : Type_Info_Acc; + Length_Attr : Iir; + begin + T_Info := Get_Info (Range_Type); + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Left), + Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Right), + Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Dir), + New_Lit (Chap7.Translate_Static_Range_Dir (Expr))); + if T_Info.T.Range_Length /= O_Fnode_Null then + if Get_Expr_Staticness (Expr) = Locally then + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + New_Lit (Translate_Static_Range_Length (Expr))); + else + Length_Attr := Is_Length_Range_Expression (Expr); + if Length_Attr = Null_Iir then + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Compute_Range_Length + (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Right), + Get_Direction (Expr))); + Close_Temp; + else + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Chap14.Translate_Length_Array_Attribute + (Length_Attr, Null_Iir)); + end if; + end if; + end if; + Close_Temp; + end Translate_Range_Expression_Ptr; + + -- Reverse range ARANGE. + procedure Translate_Reverse_Range_Ptr + (Res_Ptr : O_Dnode; Arange : O_Lnode; Range_Type : Iir) + is + Rinfo : Type_Info_Acc; + Ptr : O_Dnode; + If_Blk : O_If_Block; + begin + Rinfo := Get_Info (Get_Base_Type (Range_Type)); + Open_Temp; + Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, Arange); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Right)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Right), + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Left)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Length), + New_Value_Selected_Acc_Value (New_Obj (Ptr), + Rinfo.T.Range_Length)); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_Downto_Node)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end Translate_Reverse_Range_Ptr; + + procedure Copy_Range (Dest_Ptr : O_Dnode; + Src_Ptr : O_Dnode; + Info : Type_Info_Acc) + is + begin + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Left)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Right), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Right)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Dir), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Dir)); + if Info.T.Range_Length /= O_Fnode_Null then + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), + Info.T.Range_Length), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Length)); + end if; + end Copy_Range; + + procedure Translate_Range_Ptr + (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir) + is + begin + case Get_Kind (Arange) is + when Iir_Kind_Range_Array_Attribute => + declare + Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Get_Base_Type (Range_Type)); + Open_Temp; + Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, + Chap14.Translate_Range_Array_Attribute (Arange)); + Copy_Range (Res_Ptr, Ptr, Rinfo); + Close_Temp; + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + Translate_Reverse_Range_Ptr + (Res_Ptr, + Chap14.Translate_Range_Array_Attribute (Arange), + Range_Type); + when Iir_Kind_Range_Expression => + Translate_Range_Expression_Ptr (Res_Ptr, Arange, Range_Type); + when others => + Error_Kind ("translate_range_ptr", Arange); + end case; + end Translate_Range_Ptr; + + procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir) + is + begin + case Get_Kind (Arange) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + if not Is_Anonymous_Type_Definition (Arange) then + declare + Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Arange); + Open_Temp; + Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, Get_Var (Rinfo.T.Range_Var)); + Copy_Range (Res_Ptr, Ptr, Rinfo); + Close_Temp; + end; + else + Translate_Range_Ptr (Res_Ptr, + Get_Range_Constraint (Arange), + Get_Base_Type (Arange)); + end if; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Range_Expression => + Translate_Range_Ptr (Res_Ptr, Arange, Get_Type (Arange)); + when others => + Error_Kind ("translate_discrete_range_ptr", Arange); + end case; + end Translate_Discrete_Range_Ptr; + + function Translate_Range (Arange : Iir; Range_Type : Iir) + return O_Lnode is + begin + case Get_Kind (Arange) is + when Iir_Kinds_Denoting_Name => + return Translate_Range (Get_Named_Entity (Arange), Range_Type); + when Iir_Kind_Subtype_Declaration => + -- Must be a scalar subtype. Range of types is static. + return Get_Var (Get_Info (Get_Type (Arange)).T.Range_Var); + when Iir_Kind_Range_Array_Attribute => + return Chap14.Translate_Range_Array_Attribute (Arange); + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + Res : O_Dnode; + Res_Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Range_Type); + Res := Create_Temp (Rinfo.T.Range_Type); + Open_Temp; + Res_Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, + New_Obj (Res)); + Translate_Reverse_Range_Ptr + (Res_Ptr, + Chap14.Translate_Range_Array_Attribute (Arange), + Range_Type); + Close_Temp; + return New_Obj (Res); + end; + when Iir_Kind_Range_Expression => + declare + Res : O_Dnode; + Ptr : O_Dnode; + T_Info : Type_Info_Acc; + begin + T_Info := Get_Info (Range_Type); + Res := Create_Temp (T_Info.T.Range_Type); + Open_Temp; + Ptr := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, + New_Obj (Res)); + Translate_Range_Expression_Ptr (Ptr, Arange, Range_Type); + Close_Temp; + return New_Obj (Res); + end; + when others => + Error_Kind ("translate_range", Arange); + end case; + return O_Lnode_Null; + end Translate_Range; + + function Translate_Static_Range (Arange : Iir; Range_Type : Iir) + return O_Cnode + is + Constr : O_Record_Aggr_List; + Res : O_Cnode; + T_Info : Type_Info_Acc; + begin + T_Info := Get_Info (Range_Type); + Start_Record_Aggr (Constr, T_Info.T.Range_Type); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Left (Arange, Range_Type)); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Right (Arange, Range_Type)); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Dir (Arange)); + if T_Info.T.Range_Length /= O_Fnode_Null then + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Length (Arange)); + end if; + Finish_Record_Aggr (Constr, Res); + return Res; + end Translate_Static_Range; + + procedure Translate_Predefined_Array_Compare (Subprg : Iir) + is + procedure Gen_Compare (L, R : O_Dnode) + is + If_Blk1, If_Blk2 : O_If_Block; + begin + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Neq, New_Obj_Value (L), New_Obj_Value (R), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Gt, New_Obj_Value (L), New_Obj_Value (R), + Ghdl_Bool_Type)); + New_Return_Stmt (New_Lit (Ghdl_Compare_Gt)); + New_Else_Stmt (If_Blk2); + New_Return_Stmt (New_Lit (Ghdl_Compare_Lt)); + Finish_If_Stmt (If_Blk2); + Finish_If_Stmt (If_Blk1); + end Gen_Compare; + + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info : Subprg_Info_Acc; + L, R : O_Dnode; + Interface_List : O_Inter_List; + If_Blk : O_If_Block; + Var_L_Len, Var_R_Len : O_Dnode; + Var_L_El, Var_R_El : O_Dnode; + Var_I, Var_Len : O_Dnode; + Label : O_Snode; + El_Otype : O_Tnode; + begin + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_CMP"), + Global_Storage, Ghdl_Compare_Type); + New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + El_Otype := Get_Ortho_Type + (Get_Element_Subtype (Arr_Type), Mode_Value); + Start_Subprogram_Body (F_Info.Ortho_Func); + -- Compute length of L and R. + New_Var_Decl (Var_L_Len, Wki_L_Len, + O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Wki_R_Len, + O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Obj (Var_L_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); + New_Assign_Stmt (New_Obj (Var_R_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1)); + -- Find the minimum length. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_L_Len), + New_Obj_Value (Var_R_Len), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_R_Len)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_L_Len)); + Finish_If_Stmt (If_Blk); + + -- for each element, compare elements; if not equal return the + -- comparaison result. + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Len), + Ghdl_Bool_Type)); + -- Compare the length and return the result. + Gen_Compare (Var_L_Len, Var_R_Len); + New_Return_Stmt (New_Lit (Ghdl_Compare_Eq)); + Finish_If_Stmt (If_Blk); + Start_Declare_Stmt; + New_Var_Decl (Var_L_El, Get_Identifier ("l_el"), O_Storage_Local, + El_Otype); + New_Var_Decl (Var_R_El, Get_Identifier ("r_el"), O_Storage_Local, + El_Otype); + New_Assign_Stmt + (New_Obj (Var_L_El), + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); + New_Assign_Stmt + (New_Obj (Var_R_El), + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); + Gen_Compare (Var_L_El, Var_R_El); + Finish_Declare_Stmt; + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Compare; + + -- Find the declaration of the predefined function IMP in type + -- definition BASE_TYPE. + function Find_Predefined_Function + (Base_Type : Iir; Imp : Iir_Predefined_Functions) + return Iir + is + El : Iir; + begin + El := Get_Chain (Get_Type_Declarator (Base_Type)); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + if Get_Implicit_Definition (El) = Imp then + return El; + else + El := Get_Chain (El); + end if; + when others => + raise Internal_Error; + end case; + end loop; + raise Internal_Error; + end Find_Predefined_Function; + + function Translate_Equality (L, R : Mnode; Etype : Iir) + return O_Enode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (L); + case Tinfo.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc => + return New_Compare_Op (ON_Eq, M2E (L), M2E (R), + Ghdl_Bool_Type); + when Type_Mode_Fat_Acc => + -- a fat pointer. + declare + B : Type_Info_Acc; + Ln, Rn : Mnode; + V1, V2 : O_Enode; + begin + B := Get_Info (Get_Designated_Type (Etype)); + Ln := Stabilize (L); + Rn := Stabilize (R); + V1 := New_Compare_Op + (ON_Eq, + New_Value (New_Selected_Element + (M2Lv (Ln), B.T.Base_Field (Mode_Value))), + New_Value (New_Selected_Element + (M2Lv (Rn), B.T.Base_Field (Mode_Value))), + Std_Boolean_Type_Node); + V2 := New_Compare_Op + (ON_Eq, + New_Value (New_Selected_Element + (M2Lv (Ln), B.T.Bounds_Field (Mode_Value))), + New_Value (New_Selected_Element + (M2Lv (Rn), B.T.Bounds_Field (Mode_Value))), + Std_Boolean_Type_Node); + return New_Dyadic_Op (ON_And, V1, V2); + end; + + when Type_Mode_Array => + declare + Lc, Rc : O_Enode; + Base_Type : Iir_Array_Type_Definition; + Func : Iir; + begin + Base_Type := Get_Base_Type (Etype); + Lc := Translate_Implicit_Conv + (M2E (L), Etype, Base_Type, Mode_Value, Null_Iir); + Rc := Translate_Implicit_Conv + (M2E (R), Etype, Base_Type, Mode_Value, Null_Iir); + Func := Find_Predefined_Function + (Base_Type, Iir_Predefined_Array_Equality); + return Translate_Predefined_Lib_Operator (Lc, Rc, Func); + end; + + when Type_Mode_Record => + declare + Func : Iir; + begin + Func := Find_Predefined_Function + (Get_Base_Type (Etype), Iir_Predefined_Record_Equality); + return Translate_Predefined_Lib_Operator + (M2E (L), M2E (R), Func); + end; + + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Equality; + + procedure Translate_Predefined_Array_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + Indexes : Iir_List; + Nbr_Indexes : Natural; + If_Blk : O_If_Block; + Var_I : O_Dnode; + Var_Len : O_Dnode; + Label : O_Snode; + Le, Re : Mnode; + El_Type : Iir; + begin + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + El_Type := Get_Element_Subtype (Arr_Type); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + Indexes := Get_Index_Subtype_List (Arr_Type); + Nbr_Indexes := Get_Nbr_Elements (Indexes); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + -- for each dimension: if length mismatch: return false + for I in 1 .. Nbr_Indexes loop + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Neq, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, Arr_Type, I))), + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, Arr_Type, I))), + Std_Boolean_Type_Node)); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + end loop; + + -- for each element: if element is not equal, return false + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + Open_Temp; + New_Assign_Stmt (New_Obj (Var_Len), + Chap3.Get_Array_Length (L, Arr_Type)); + Close_Temp; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + -- If the end of the array is reached, return TRUE. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Len), + Ghdl_Bool_Type)); + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (If_Blk); + Open_Temp; + Le := Chap3.Index_Base (Chap3.Get_Array_Base (L), Arr_Type, + New_Obj_Value (Var_I)); + Re := Chap3.Index_Base (Chap3.Get_Array_Base (R), Arr_Type, + New_Obj_Value (Var_I)); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, Translate_Equality (Le, Re, El_Type))); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Equality; + + procedure Translate_Predefined_Record_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Rec_Type : Iir_Record_Type_Definition; + Rec_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + If_Blk : O_If_Block; + Le, Re : Mnode; + + El_List : Iir_List; + El : Iir_Element_Declaration; + begin + Rec_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info := Get_Info (Rec_Type); + Id := Get_Identifier (Get_Type_Declarator (Rec_Type)); + Rec_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Rec_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Rec_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + -- Compare each element. + El_List := Get_Elements_Declaration_List (Rec_Type); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Le := Chap6.Translate_Selected_Element (L, El); + Re := Chap6.Translate_Selected_Element (R, El); + + Open_Temp; + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, + Translate_Equality (Le, Re, Get_Type (El)))); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end loop; + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Record_Equality; + + procedure Translate_Predefined_Array_Array_Concat (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + + -- Info for the array type. + Info : Type_Info_Acc; + + -- Info for the index type. + Iinfo : Type_Info_Acc; + Index_Type : Iir; + + Index_Otype : O_Tnode; + Id : Name_Id; + Interface_List : O_Inter_List; + Var_Res, Var_L, Var_R : O_Dnode; + Res, L, R : Mnode; + Var_Length, Var_L_Len, Var_R_Len : O_Dnode; + Var_Bounds, Var_Right : O_Dnode; + V_Bounds : Mnode; + If_Blk : O_If_Block; + begin + Arr_Type := Get_Return_Type (Subprg); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + F_Info.Use_Stack2 := True; + + -- Create function. + Start_Procedure_Decl + (Interface_List, Create_Identifier (Id, "_CONCAT"), Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a concatenation returns its value without + -- the use of the record. + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Index_Type := Get_Index_Type (Arr_Type, 0); + Iinfo := Get_Info (Index_Type); + Index_Otype := Iinfo.Ortho_Type (Mode_Value); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_L_Len, Wki_L_Len, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Wki_R_Len, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Bounds, Get_Identifier ("bounds"), O_Storage_Local, + Info.T.Bounds_Ptr_Type); + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + Res := Dp2M (Var_Res, Info, Mode_Value); + V_Bounds := Dp2M (Var_Bounds, Info, Mode_Value, + Info.T.Bounds_Type, Info.T.Bounds_Ptr_Type); + + -- Compute length. + New_Assign_Stmt + (New_Obj (Var_L_Len), Chap3.Get_Array_Length (L, Arr_Type)); + New_Assign_Stmt + (New_Obj (Var_R_Len), Chap3.Get_Array_Length (R, Arr_Type)); + New_Assign_Stmt + (New_Obj (Var_Length), New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_L_Len), + New_Obj_Value (Var_R_Len))); + + -- Check case where the result is the right operand. + declare + Len : O_Enode; + begin + if Flags.Vhdl_Std = Vhdl_87 then + -- LRM87 7.2.4 + -- [...], unless the left operand is a null array, in which + -- case the result of the concatenation is the right operand. + Len := New_Obj_Value (Var_L_Len); + + else + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + -- GHDL: since the length type is unsigned, then both operands + -- are null arrays iff the result is a null array. + Len := New_Obj_Value (Var_Length); + end if; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + Len, + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Copy_Fat_Pointer (Res, R); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + end; + + -- Allocate bounds. + New_Assign_Stmt + (New_Obj (Var_Bounds), + Gen_Alloc (Alloc_Return, + New_Lit (New_Sizeof (Info.T.Bounds_Type, + Ghdl_Index_Type)), + Info.T.Bounds_Ptr_Type)); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), New_Obj_Value (Var_Bounds)); + + -- Set bound. + if Flags.Vhdl_Std = Vhdl_87 then + -- Set length. + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Length + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Length)); + + -- Set direction, left bound and right bound. + -- LRM87 7.2.4 + -- The left bound of this result is the left bound of the left + -- operand, unless the left operand is a null array, in which + -- case the result of the concatenation is the right operand. + -- The direction of the result is the direction of the left + -- operand, unless the left operand is a null array, in which + -- case the direction of the result is that of the right operand. + declare + Var_Dir, Var_Left : O_Dnode; + Var_Length1 : O_Dnode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), + O_Storage_Local, Index_Otype); + New_Var_Decl (Var_Dir, Wki_Dir, O_Storage_Local, + Ghdl_Dir_Type_Node); + New_Var_Decl (Var_Left, Get_Identifier ("left_bound"), + O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); + New_Var_Decl (Var_Length1, Get_Identifier ("length_1"), + O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Var_Dir), + M2E (Chap3.Range_To_Dir + (Chap3.Get_Array_Range (L, Arr_Type, 1)))); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Dir + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Dir)); + New_Assign_Stmt + (New_Obj (Var_Left), + M2E (Chap3.Range_To_Left + (Chap3.Get_Array_Range (L, Arr_Type, 1)))); + -- Note this substraction cannot overflow, since LENGTH >= 1. + New_Assign_Stmt + (New_Obj (Var_Length1), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_1))); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Left + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Left)); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, New_Obj_Value (Var_Dir), + New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Var_Right), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Left), + New_Convert_Ov (New_Obj_Value (Var_Length1), + Index_Otype))); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Obj (Var_Right), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Left), + New_Convert_Ov (New_Obj_Value (Var_Length1), + Index_Otype))); + Finish_If_Stmt (If_Blk); + -- Check the right bounds is inside the bounds of the + -- index type. + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Subprg); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Right + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Right)); + Finish_Declare_Stmt; + end; + else + -- LRM93 7.2.4 + -- [...], the direction and bounds of the result are determined + -- as follows: Let S be the index subtype of the base type of the + -- result. The direction of the result of the concatenation is + -- the direction of S, and the left bound of the result is + -- S'LEFT. + declare + Var_Range_Ptr : O_Dnode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_Range_Ptr, Get_Identifier ("range_ptr"), + O_Storage_Local, Iinfo.T.Range_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Range_Ptr), + M2Addr (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))); + Chap3.Create_Range_From_Length + (Index_Type, Var_Length, Var_Range_Ptr, Subprg); + Finish_Declare_Stmt; + end; + end if; + + -- Allocate array base. + Chap3.Allocate_Fat_Array_Base (Alloc_Return, Res, Arr_Type); + + -- Copy left. + declare + V_Arr : O_Dnode; + Var_Arr : Mnode; + begin + Open_Temp; + V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); + Var_Arr := Dv2M (V_Arr, Info, Mode_Value); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), + M2Addr (Chap3.Get_Array_Bounds (L))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Var_Arr)), + M2Addr (Chap3.Get_Array_Base (Res))); + Chap3.Translate_Object_Copy + (Var_Arr, New_Obj_Value (Var_L), Arr_Type); + Close_Temp; + end; + + -- Copy right. + declare + V_Arr : O_Dnode; + Var_Arr : Mnode; + begin + Open_Temp; + V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); + Var_Arr := Dv2M (V_Arr, Info, Mode_Value); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), + M2Addr (Chap3.Get_Array_Bounds (R))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Var_Arr)), + M2Addr (Chap3.Slice_Base (Chap3.Get_Array_Base (Res), + Arr_Type, + New_Obj_Value (Var_L_Len)))); + Chap3.Translate_Object_Copy + (Var_Arr, New_Obj_Value (Var_R), Arr_Type); + Close_Temp; + end; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Array_Concat; + + procedure Translate_Predefined_Array_Logical (Subprg : Iir) + is + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); + -- Info for the array type. + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + -- Identifier of the type. + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + F_Info : Subprg_Info_Acc; + Interface_List : O_Inter_List; + Var_Res : O_Dnode; + Res : Mnode; + L, R : O_Dnode; + Var_Length, Var_I : O_Dnode; + Var_Base, Var_L_Base, Var_R_Base : O_Dnode; + If_Blk : O_If_Block; + Label : O_Snode; + Name : O_Ident; + Is_Monadic : Boolean; + El, L_El : O_Enode; + Op : ON_Op_Kind; + Do_Invert : Boolean; + begin + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := True; + + Is_Monadic := False; + case Get_Implicit_Definition (Subprg) is + when Iir_Predefined_TF_Array_And => + Name := Create_Identifier (Id, "_AND"); + Op := ON_And; + Do_Invert := False; + when Iir_Predefined_TF_Array_Or => + Name := Create_Identifier (Id, "_OR"); + Op := ON_Or; + Do_Invert := False; + when Iir_Predefined_TF_Array_Nand => + Name := Create_Identifier (Id, "_NAND"); + Op := ON_And; + Do_Invert := True; + when Iir_Predefined_TF_Array_Nor => + Name := Create_Identifier (Id, "_NOR"); + Op := ON_Or; + Do_Invert := True; + when Iir_Predefined_TF_Array_Xor => + Name := Create_Identifier (Id, "_XOR"); + Op := ON_Xor; + Do_Invert := False; + when Iir_Predefined_TF_Array_Xnor => + Name := Create_Identifier (Id, "_XNOR"); + Op := ON_Xor; + Do_Invert := True; + when Iir_Predefined_TF_Array_Not => + Name := Create_Identifier (Id, "_NOT"); + Is_Monadic := True; + Op := ON_Not; + Do_Invert := False; + when others => + raise Internal_Error; + end case; + + -- Create function. + Start_Procedure_Decl (Interface_List, Name, Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a concatenation returns its value without + -- the use of the record. + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); + if not Is_Monadic then + New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); + end if; + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Base, Get_Identifier ("base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + if not Is_Monadic then + New_Var_Decl + (Var_R_Base, Get_Identifier ("r_base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + end if; + Open_Temp; + -- Get length of LEFT. + New_Assign_Stmt (New_Obj (Var_Length), + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); + -- If dyadic, check RIGHT has the same length. + if not Is_Monadic then + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Neq, + New_Obj_Value (Var_Length), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1), + Ghdl_Bool_Type), + Subprg, 0); + end if; + + -- Create the result from LEFT bound. + Res := Dp2M (Var_Res, Info, Mode_Value); + Chap3.Translate_Object_Allocation + (Res, Alloc_Return, Arr_Type, + Chap3.Get_Array_Bounds (Dp2M (L, Info, Mode_Value))); + New_Assign_Stmt + (New_Obj (Var_Base), M2Addr (Chap3.Get_Array_Base (Res))); + New_Assign_Stmt + (New_Obj (Var_L_Base), + M2Addr (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)))); + if not Is_Monadic then + New_Assign_Stmt + (New_Obj (Var_R_Base), + M2Addr (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)))); + end if; + + -- Do the logical operation on each element. + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + L_El := New_Value (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_L_Base)), + New_Obj_Value (Var_I))); + if Is_Monadic then + El := New_Monadic_Op (Op, L_El); + else + El := New_Dyadic_Op + (Op, L_El, + New_Value (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_R_Base)), + New_Obj_Value (Var_I)))); + end if; + if Do_Invert then + El := New_Monadic_Op (ON_Not, El); + end if; + + New_Assign_Stmt (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_Base)), + New_Obj_Value (Var_I)), + El); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + Finish_Subprogram_Body; + end Translate_Predefined_Array_Logical; + + procedure Translate_Predefined_Array_Shift (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Inter : Iir; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Int_Type : O_Tnode; + -- Info for the array type. + Info : Type_Info_Acc; + Id : Name_Id; + Interface_List : O_Inter_List; + Var_Res : O_Dnode; + Var_L, Var_R : O_Dnode; + Name : O_Ident; + + type Shift_Kind is (Sh_Logical, Sh_Arith, Rotation); + Shift : Shift_Kind; + + -- Body; + Var_Length, Var_I, Var_I1 : O_Dnode; + Var_Res_Base, Var_L_Base : O_Dnode; + Var_Rl : O_Dnode; + Var_E : O_Dnode; + L : Mnode; + If_Blk, If_Blk1 : O_If_Block; + Label : O_Snode; + Res : Mnode; + + procedure Do_Shift (To_Right : Boolean) + is + Tmp : O_Enode; + begin + -- LEFT: + -- * I := 0; + if not To_Right then + Init_Var (Var_I); + end if; + + -- * If R < LENGTH then + Start_If_Stmt (If_Blk1, + New_Compare_Op (ON_Lt, + New_Obj_Value (Var_Rl), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + -- Shift the elements (that remains in the result). + -- RIGHT: + -- * for I = R to LENGTH - 1 loop + -- * RES[I] := L[I - R] + -- LEFT: + -- * for I = 0 to LENGTH - R loop + -- * RES[I] := L[R + I] + if To_Right then + New_Assign_Stmt (New_Obj (Var_I), New_Obj_Value (Var_Rl)); + Init_Var (Var_I1); + else + New_Assign_Stmt (New_Obj (Var_I1), New_Obj_Value (Var_Rl)); + end if; + Start_Loop_Stmt (Label); + if To_Right then + Tmp := New_Obj_Value (Var_I); + else + Tmp := New_Obj_Value (Var_I1); + end if; + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + Tmp, + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), + New_Value + (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + New_Obj_Value (Var_I1)))); + Inc_Var (Var_I); + Inc_Var (Var_I1); + Finish_Loop_Stmt (Label); + -- RIGHT: + -- * else + -- * R := LENGTH; + if To_Right then + New_Else_Stmt (If_Blk1); + New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); + end if; + Finish_If_Stmt (If_Blk1); + + -- Pad the result. + -- RIGHT: + -- * For I = 0 to R - 1 + -- * RES[I] := 0/L[0/LENGTH-1] + -- LEFT: + -- * For I = LENGTH - R to LENGTH - 1 + -- * RES[I] := 0/L[0/LENGTH-1] + if To_Right then + Init_Var (Var_I); + else + -- I is yet correctly set. + null; + end if; + if Shift = Sh_Arith then + if To_Right then + Tmp := New_Lit (Ghdl_Index_0); + else + Tmp := New_Dyadic_Op + (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_1)); + end if; + New_Assign_Stmt + (New_Obj (Var_E), + New_Value (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + Tmp))); + end if; + Start_Loop_Stmt (Label); + if To_Right then + Tmp := New_Obj_Value (Var_Rl); + else + Tmp := New_Obj_Value (Var_Length); + end if; + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + Tmp, + Ghdl_Bool_Type)); + case Shift is + when Sh_Logical => + declare + Enum_List : Iir_List; + begin + Enum_List := Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Arr_Type))); + Tmp := New_Lit + (Get_Ortho_Expr (Get_First_Element (Enum_List))); + end; + when Sh_Arith => + Tmp := New_Obj_Value (Var_E); + when Rotation => + raise Internal_Error; + end case; + + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), Tmp); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + end Do_Shift; + begin + Inter := Get_Interface_Declaration_Chain (Subprg); + + Info := Get_Info (Get_Type (Get_Chain (Inter))); + Int_Type := Info.Ortho_Type (Mode_Value); + + Arr_Type := Get_Type (Inter); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := True; + + case Get_Implicit_Definition (Subprg) is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + -- Shift logical. + Name := Create_Identifier (Id, "_SHL"); + Shift := Sh_Logical; + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + -- Shift arithmetic. + Name := Create_Identifier (Id, "_SHA"); + Shift := Sh_Arith; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + -- Rotation + Name := Create_Identifier (Id, "_ROT"); + Shift := Rotation; + when others => + raise Internal_Error; + end case; + + -- Create function. + Start_Procedure_Decl (Interface_List, Name, Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a shift returns its value without + -- the use of the record. + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Int_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Body + Start_Subprogram_Body (F_Info.Ortho_Func); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + if Shift /= Rotation then + New_Var_Decl (Var_Rl, Get_Identifier ("rl"), O_Storage_Local, + Ghdl_Index_Type); + end if; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_I1, Get_Identifier ("I1"), O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_Res_Base, Get_Identifier ("res_base"), + O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); + New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), + O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); + if Shift = Sh_Arith then + New_Var_Decl (Var_E, Get_Identifier ("E"), O_Storage_Local, + Get_Info (Get_Element_Subtype (Arr_Type)). + Ortho_Type (Mode_Value)); + end if; + Res := Dp2M (Var_Res, Info, Mode_Value); + L := Dp2M (Var_L, Info, Mode_Value); + + -- LRM93 7.2.3 + -- The index subtypes of the return values of all shift operators is + -- the same as the index subtype of their left arguments. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (L))); + + -- Get length of LEFT. + New_Assign_Stmt (New_Obj (Var_Length), + Chap3.Get_Array_Length (L, Arr_Type)); + + -- LRM93 7.2.3 [6 times] + -- That is, if R is 0 or L is a null array, the return value is L. + Start_If_Stmt + (If_Blk, + New_Dyadic_Op + (ON_Or, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_R), + New_Lit (New_Signed_Literal (Int_Type, 0)), + Ghdl_Bool_Type), + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + M2Addr (Chap3.Get_Array_Base (L))); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + + -- Allocate base. + New_Assign_Stmt + (New_Obj (Var_Res_Base), + Gen_Alloc (Alloc_Return, New_Obj_Value (Var_Length), + Info.T.Base_Ptr_Type (Mode_Value))); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), + New_Obj_Value (Var_Res_Base)); + + New_Assign_Stmt (New_Obj (Var_L_Base), + M2Addr (Chap3.Get_Array_Base (L))); + + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Gt, + New_Obj_Value (Var_R), + New_Lit (New_Signed_Literal (Int_Type, + 0)), + Ghdl_Bool_Type)); + -- R > 0. + -- Ie, to the right + case Shift is + when Rotation => + -- * I1 := LENGTH - (R mod LENGTH) + New_Assign_Stmt + (New_Obj (Var_I1), + New_Dyadic_Op + (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Dyadic_Op (ON_Mod_Ov, + New_Convert_Ov (New_Obj_Value (Var_R), + Ghdl_Index_Type), + New_Obj_Value (Var_Length)))); + + when Sh_Logical + | Sh_Arith => + -- Real SRL or SRA. + New_Assign_Stmt + (New_Obj (Var_Rl), + New_Convert_Ov (New_Obj_Value (Var_R), Ghdl_Index_Type)); + + Do_Shift (True); + end case; + + New_Else_Stmt (If_Blk); + + -- R < 0, to the left. + case Shift is + when Rotation => + -- * I1 := (-R) mod LENGTH + New_Assign_Stmt + (New_Obj (Var_I1), + New_Dyadic_Op (ON_Mod_Ov, + New_Convert_Ov + (New_Monadic_Op (ON_Neg_Ov, + New_Obj_Value (Var_R)), + Ghdl_Index_Type), + New_Obj_Value (Var_Length))); + when Sh_Logical + | Sh_Arith => + -- Real SLL or SLA. + New_Assign_Stmt + (New_Obj (Var_Rl), + New_Convert_Ov (New_Monadic_Op (ON_Neg_Ov, + New_Obj_Value (Var_R)), + Ghdl_Index_Type)); + + Do_Shift (False); + end case; + Finish_If_Stmt (If_Blk); + + if Shift = Rotation then + -- * If I1 = LENGTH then + -- * I1 := 0 + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I1), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Init_Var (Var_I1); + Finish_If_Stmt (If_Blk); + + -- * for I = 0 to LENGTH - 1 loop + -- * RES[I] := L[I1]; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), + New_Value + (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + New_Obj_Value (Var_I1)))); + Inc_Var (Var_I); + -- * I1 := I1 + 1 + Inc_Var (Var_I1); + -- * If I1 = LENGTH then + -- * I1 := 0 + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I1), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Init_Var (Var_I1); + Finish_If_Stmt (If_Blk); + Finish_Loop_Stmt (Label); + end if; + Finish_Subprogram_Body; + end Translate_Predefined_Array_Shift; + + procedure Translate_File_Subprogram (Subprg : Iir; File_Type : Iir) + is + Etype : Iir; + Tinfo : Type_Info_Acc; + Kind : Iir_Predefined_Functions; + F_Info : Subprg_Info_Acc; + Name : O_Ident; + Inter_List : O_Inter_List; + Id : Name_Id; + Var_File : O_Dnode; + Var_Val : O_Dnode; + + procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode); + + procedure Translate_Rw_Array + (Val : Mnode; Val_Type : Iir; Var_Max : O_Dnode; Proc : O_Dnode) + is + Var_It : O_Dnode; + Label : O_Snode; + begin + Var_It := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_It); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_It), + New_Obj_Value (Var_Max), + Ghdl_Bool_Type)); + Translate_Rw + (Chap3.Index_Base (Val, Val_Type, New_Obj_Value (Var_It)), + Get_Element_Subtype (Val_Type), Proc); + Inc_Var (Var_It); + Finish_Loop_Stmt (Label); + end Translate_Rw_Array; + + procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode) + is + Val_Info : Type_Info_Acc; + Assocs : O_Assoc_List; + begin + Val_Info := Get_Type_Info (Val); + case Val_Info.Type_Mode is + when Type_Mode_Scalar => + Start_Association (Assocs, Proc); + -- compute file parameter (get an index) + New_Association (Assocs, New_Obj_Value (Var_File)); + -- compute the value. + New_Association + (Assocs, New_Convert_Ov (M2Addr (Val), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, + New_Lit (New_Sizeof (Val_Info.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + when Type_Mode_Record => + declare + El_List : Iir_List; + El : Iir; + Val1 : Mnode; + begin + Open_Temp; + Val1 := Stabilize (Val); + El_List := Get_Elements_Declaration_List + (Get_Base_Type (Val_Type)); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Translate_Rw + (Chap6.Translate_Selected_Element (Val1, El), + Get_Type (El), Proc); + end loop; + Close_Temp; + end; + when Type_Mode_Array => + declare + Var_Max : O_Dnode; + begin + Open_Temp; + Var_Max := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Var_Max), + Chap3.Get_Array_Type_Length (Val_Type)); + Translate_Rw_Array (Val, Val_Type, Var_Max, Proc); + Close_Temp; + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Fat_Array + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Rw; + + procedure Translate_Rw_Length (Var_Length : O_Dnode; Proc : O_Dnode) + is + Assocs : O_Assoc_List; + begin + Start_Association (Assocs, Proc); + New_Association (Assocs, New_Obj_Value (Var_File)); + New_Association + (Assocs, New_Unchecked_Address (New_Obj (Var_Length), + Ghdl_Ptr_Type)); + New_Association + (Assocs, + New_Lit (New_Sizeof (Ghdl_Index_Type, Ghdl_Index_Type))); + New_Procedure_Call (Assocs); + end Translate_Rw_Length; + + Var : Mnode; + begin + Etype := Get_Type (Get_File_Type_Mark (File_Type)); + Tinfo := Get_Info (Etype); + if Tinfo.Type_Mode in Type_Mode_Scalar then + -- Intrinsic. + return; + end if; + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := False; + + Id := Get_Identifier (Get_Type_Declarator (File_Type)); + Kind := Get_Implicit_Definition (Subprg); + case Kind is + when Iir_Predefined_Write => + Name := Create_Identifier (Id, "_WRITE"); + when Iir_Predefined_Read + | Iir_Predefined_Read_Length => + Name := Create_Identifier (Id, "_READ"); + when others => + raise Internal_Error; + end case; + + -- Create function. + if Kind = Iir_Predefined_Read_Length then + Start_Function_Decl + (Inter_List, Name, Global_Storage, Std_Integer_Otype); + else + Start_Procedure_Decl (Inter_List, Name, Global_Storage); + end if; + Chap2.Create_Subprg_Instance (Inter_List, Subprg); + + New_Interface_Decl + (Inter_List, Var_File, Get_Identifier ("FILE"), + Ghdl_File_Index_Type); + New_Interface_Decl + (Inter_List, Var_Val, Wki_Val, + Tinfo.Ortho_Ptr_Type (Mode_Value)); + Finish_Subprogram_Decl (Inter_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + Push_Local_Factory; + + Var := Dp2M (Var_Val, Tinfo, Mode_Value); + + case Kind is + when Iir_Predefined_Write => + if Tinfo.Type_Mode = Type_Mode_Fat_Array then + declare + Var_Max : O_Dnode; + begin + Open_Temp; + Var_Max := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Array_Length (Var, Etype)); + Translate_Rw_Length (Var_Max, Ghdl_Write_Scalar); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Max, Ghdl_Write_Scalar); + Close_Temp; + end; + else + Translate_Rw (Var, Etype, Ghdl_Write_Scalar); + end if; + when Iir_Predefined_Read => + Translate_Rw (Var, Etype, Ghdl_Read_Scalar); + + when Iir_Predefined_Read_Length => + declare + Var_Len : O_Dnode; + begin + Open_Temp; + Var_Len := Create_Temp (Ghdl_Index_Type); + Translate_Rw_Length (Var_Len, Ghdl_Read_Scalar); + + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Gt, + New_Obj_Value (Var_Len), + Chap3.Get_Array_Length (Var, Etype), + Ghdl_Bool_Type), + Subprg, 1); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Len, Ghdl_Read_Scalar); + New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_Len), + Std_Integer_Otype)); + Close_Temp; + end; + when others => + raise Internal_Error; + end case; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_File_Subprogram; + + procedure Init_Implicit_Subprogram_Infos + (Infos : out Implicit_Subprogram_Infos) is + begin + -- Be independant of declaration order since the same subprogram + -- may be used for several implicit operators (eg. array comparaison) + Infos.Arr_Eq_Info := null; + Infos.Arr_Cmp_Info := null; + Infos.Arr_Concat_Info := null; + Infos.Rec_Eq_Info := null; + Infos.Arr_Shl_Info := null; + Infos.Arr_Sha_Info := null; + Infos.Arr_Rot_Info := null; + end Init_Implicit_Subprogram_Infos; + + procedure Translate_Implicit_Subprogram + (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos) + is + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Subprg); + begin + if Predefined_To_Onop (Kind) /= ON_Nil then + -- Intrinsic. + return; + end if; + + case Kind is + when Iir_Predefined_Error => + raise Internal_Error; + when Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Xor + | Iir_Predefined_Boolean_Not + | Iir_Predefined_Enum_Equality + | Iir_Predefined_Enum_Inequality + | Iir_Predefined_Enum_Less + | Iir_Predefined_Enum_Less_Equal + | Iir_Predefined_Enum_Greater + | Iir_Predefined_Enum_Greater_Equal + | Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Xor + | Iir_Predefined_Bit_Not + | Iir_Predefined_Integer_Equality + | Iir_Predefined_Integer_Inequality + | Iir_Predefined_Integer_Less + | Iir_Predefined_Integer_Less_Equal + | Iir_Predefined_Integer_Greater + | Iir_Predefined_Integer_Greater_Equal + | Iir_Predefined_Integer_Negation + | Iir_Predefined_Integer_Absolute + | Iir_Predefined_Integer_Plus + | Iir_Predefined_Integer_Minus + | Iir_Predefined_Integer_Mul + | Iir_Predefined_Integer_Div + | Iir_Predefined_Integer_Mod + | Iir_Predefined_Integer_Rem + | Iir_Predefined_Floating_Equality + | Iir_Predefined_Floating_Inequality + | Iir_Predefined_Floating_Less + | Iir_Predefined_Floating_Less_Equal + | Iir_Predefined_Floating_Greater + | Iir_Predefined_Floating_Greater_Equal + | Iir_Predefined_Floating_Negation + | Iir_Predefined_Floating_Absolute + | Iir_Predefined_Floating_Plus + | Iir_Predefined_Floating_Minus + | Iir_Predefined_Floating_Mul + | Iir_Predefined_Floating_Div + | Iir_Predefined_Physical_Equality + | Iir_Predefined_Physical_Inequality + | Iir_Predefined_Physical_Less + | Iir_Predefined_Physical_Less_Equal + | Iir_Predefined_Physical_Greater + | Iir_Predefined_Physical_Greater_Equal + | Iir_Predefined_Physical_Negation + | Iir_Predefined_Physical_Absolute + | Iir_Predefined_Physical_Plus + | Iir_Predefined_Physical_Minus => + pragma Assert (Predefined_To_Onop (Kind) /= ON_Nil); + return; + + when Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor + | Iir_Predefined_Boolean_Xnor + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Bit_Xnor + | Iir_Predefined_Bit_Match_Equality + | Iir_Predefined_Bit_Match_Inequality + | Iir_Predefined_Bit_Match_Less + | Iir_Predefined_Bit_Match_Less_Equal + | Iir_Predefined_Bit_Match_Greater + | Iir_Predefined_Bit_Match_Greater_Equal + | Iir_Predefined_Bit_Condition + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Boolean_Falling_Edge + | Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge => + -- Intrinsic. + null; + + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Enum_Maximum + | Iir_Predefined_Enum_To_String => + -- Intrinsic. + null; + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Integer_Exp + | Iir_Predefined_Integer_Minimum + | Iir_Predefined_Integer_Maximum + | Iir_Predefined_Integer_To_String => + -- Intrinsic. + null; + when Iir_Predefined_Universal_R_I_Mul + | Iir_Predefined_Universal_I_R_Mul + | Iir_Predefined_Universal_R_I_Div => + -- Intrinsic + null; + + when Iir_Predefined_Physical_Identity + | Iir_Predefined_Physical_Minimum + | Iir_Predefined_Physical_Maximum + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + null; + + when Iir_Predefined_Physical_Integer_Mul + | Iir_Predefined_Physical_Integer_Div + | Iir_Predefined_Integer_Physical_Mul + | Iir_Predefined_Physical_Real_Mul + | Iir_Predefined_Physical_Real_Div + | Iir_Predefined_Real_Physical_Mul + | Iir_Predefined_Physical_Physical_Div => + null; + + when Iir_Predefined_Floating_Exp + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Floating_Minimum + | Iir_Predefined_Floating_Maximum + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format => + null; + + when Iir_Predefined_Record_Equality + | Iir_Predefined_Record_Inequality => + if Infos.Rec_Eq_Info = null then + Translate_Predefined_Record_Equality (Subprg); + Infos.Rec_Eq_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Rec_Eq_Info); + end if; + + when Iir_Predefined_Array_Equality + | Iir_Predefined_Array_Inequality + | Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => + if Infos.Arr_Eq_Info = null then + Translate_Predefined_Array_Equality (Subprg); + Infos.Arr_Eq_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Eq_Info); + end if; + + when Iir_Predefined_Array_Greater + | Iir_Predefined_Array_Greater_Equal + | Iir_Predefined_Array_Less + | Iir_Predefined_Array_Less_Equal + | Iir_Predefined_Array_Minimum + | Iir_Predefined_Array_Maximum => + if Infos.Arr_Cmp_Info = null then + Translate_Predefined_Array_Compare (Subprg); + Infos.Arr_Cmp_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Cmp_Info); + end if; + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + if Infos.Arr_Concat_Info = null then + Translate_Predefined_Array_Array_Concat (Subprg); + Infos.Arr_Concat_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Concat_Info); + end if; + + when Iir_Predefined_Vector_Minimum + | Iir_Predefined_Vector_Maximum => + null; + + when Iir_Predefined_TF_Array_And + | Iir_Predefined_TF_Array_Or + | Iir_Predefined_TF_Array_Nand + | Iir_Predefined_TF_Array_Nor + | Iir_Predefined_TF_Array_Xor + | Iir_Predefined_TF_Array_Xnor + | Iir_Predefined_TF_Array_Not => + Translate_Predefined_Array_Logical (Subprg); + + when Iir_Predefined_TF_Reduction_And + | Iir_Predefined_TF_Reduction_Or + | Iir_Predefined_TF_Reduction_Nand + | Iir_Predefined_TF_Reduction_Nor + | Iir_Predefined_TF_Reduction_Xor + | Iir_Predefined_TF_Reduction_Xnor + | Iir_Predefined_TF_Reduction_Not + | Iir_Predefined_TF_Array_Element_And + | Iir_Predefined_TF_Element_Array_And + | Iir_Predefined_TF_Array_Element_Or + | Iir_Predefined_TF_Element_Array_Or + | Iir_Predefined_TF_Array_Element_Nand + | Iir_Predefined_TF_Element_Array_Nand + | Iir_Predefined_TF_Array_Element_Nor + | Iir_Predefined_TF_Element_Array_Nor + | Iir_Predefined_TF_Array_Element_Xor + | Iir_Predefined_TF_Element_Array_Xor + | Iir_Predefined_TF_Array_Element_Xnor + | Iir_Predefined_TF_Element_Array_Xnor => + null; + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + if Infos.Arr_Shl_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Shl_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Shl_Info); + end if; + + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Infos.Arr_Sha_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Sha_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Sha_Info); + end if; + + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + if Infos.Arr_Rot_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Rot_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Rot_Info); + end if; + + when Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality => + -- Intrinsic. + null; + when Iir_Predefined_Deallocate => + -- Intrinsic. + null; + + when Iir_Predefined_File_Open + | Iir_Predefined_File_Open_Status + | Iir_Predefined_File_Close + | Iir_Predefined_Flush + | Iir_Predefined_Endfile => + -- All of them have predefined definitions. + null; + + when Iir_Predefined_Write + | Iir_Predefined_Read_Length + | Iir_Predefined_Read => + declare + Param : Iir; + File_Type : Iir; + begin + Param := Get_Interface_Declaration_Chain (Subprg); + File_Type := Get_Type (Param); + if not Get_Text_File_Flag (File_Type) then + Translate_File_Subprogram (Subprg, File_Type); + end if; + end; + + when Iir_Predefined_Attribute_Image + | Iir_Predefined_Attribute_Value + | Iir_Predefined_Attribute_Pos + | Iir_Predefined_Attribute_Val + | Iir_Predefined_Attribute_Succ + | Iir_Predefined_Attribute_Pred + | Iir_Predefined_Attribute_Leftof + | Iir_Predefined_Attribute_Rightof + | Iir_Predefined_Attribute_Left + | Iir_Predefined_Attribute_Right + | Iir_Predefined_Attribute_Event + | Iir_Predefined_Attribute_Active + | Iir_Predefined_Attribute_Last_Event + | Iir_Predefined_Attribute_Last_Active + | Iir_Predefined_Attribute_Last_Value + | Iir_Predefined_Attribute_Driving + | Iir_Predefined_Attribute_Driving_Value => + raise Internal_Error; + + when Iir_Predefined_Array_Char_To_String + | Iir_Predefined_Bit_Vector_To_Ostring + | Iir_Predefined_Bit_Vector_To_Hstring + | Iir_Predefined_Std_Ulogic_Match_Equality + | Iir_Predefined_Std_Ulogic_Match_Inequality + | Iir_Predefined_Std_Ulogic_Match_Less + | Iir_Predefined_Std_Ulogic_Match_Less_Equal + | Iir_Predefined_Std_Ulogic_Match_Greater + | Iir_Predefined_Std_Ulogic_Match_Greater_Equal + | Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + null; + + when Iir_Predefined_Now_Function => + null; + + -- when others => + -- Error_Kind ("translate_implicit_subprogram (" + -- & Iir_Predefined_Functions'Image (Kind) & ")", + -- Subprg); + end case; + end Translate_Implicit_Subprogram; + end Chap7; + + package body Chap8 is + procedure Translate_Return_Statement (Stmt : Iir_Return_Statement) + is + Subprg_Info : constant Ortho_Info_Acc := + Get_Info (Chap2.Current_Subprogram); + Expr : constant Iir := Get_Expression (Stmt); + Ret_Type : Iir; + Ret_Info : Type_Info_Acc; + + procedure Gen_Return is + begin + if Subprg_Info.Subprg_Exit /= O_Snode_Null then + New_Exit_Stmt (Subprg_Info.Subprg_Exit); + else + New_Return_Stmt; + end if; + end Gen_Return; + + procedure Gen_Return_Value (Val : O_Enode) is + begin + if Subprg_Info.Subprg_Exit /= O_Snode_Null then + New_Assign_Stmt (New_Obj (Subprg_Info.Subprg_Result), Val); + New_Exit_Stmt (Subprg_Info.Subprg_Exit); + else + New_Return_Stmt (Val); + end if; + end Gen_Return_Value; + begin + if Expr = Null_Iir then + -- Return in a procedure. + Gen_Return; + return; + end if; + + -- Return in a function. + Ret_Type := Get_Return_Type (Chap2.Current_Subprogram); + Ret_Info := Get_Info (Ret_Type); + case Ret_Info.Type_Mode is + when Type_Mode_Scalar => + -- * if the return type is scalar, simply returns. + declare + V : O_Dnode; + R : O_Enode; + begin + -- Always uses a temporary in case of the return expression + -- uses secondary stack. + -- FIXME: don't use the temp if not required. + R := Chap7.Translate_Expression (Expr, Ret_Type); + if Has_Stack2_Mark + or else Chap3.Need_Range_Check (Expr, Ret_Type) + then + V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (V), R); + Stack2_Release; + Chap3.Check_Range (V, Expr, Ret_Type, Expr); + Gen_Return_Value (New_Obj_Value (V)); + else + Gen_Return_Value (R); + end if; + end; + when Type_Mode_Acc => + -- * access: thin and no range. + declare + Res : O_Enode; + begin + Res := Chap7.Translate_Expression (Expr, Ret_Type); + Gen_Return_Value (Res); + end; + when Type_Mode_Fat_Array => + -- * if the return type is unconstrained: allocate an area from + -- the secondary stack, copy it to the area, and fill the fat + -- pointer. + -- Evaluate the result. + declare + Val : Mnode; + Area : Mnode; + begin + Area := Dp2M (Subprg_Info.Res_Interface, + Ret_Info, Mode_Value); + Val := Stabilize + (E2M (Chap7.Translate_Expression (Expr, Ret_Type), + Ret_Info, Mode_Value)); + Chap3.Translate_Object_Allocation + (Area, Alloc_Return, Ret_Type, + Chap3.Get_Array_Bounds (Val)); + Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type); + Gen_Return; + end; + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Fat_Acc => + -- * if the return type is a constrained composite type, copy + -- it to the result area. + -- Create a temporary area so that if the expression use + -- stack2, it will be freed before the return (otherwise, + -- the stack area will be lost). + declare + V : Mnode; + begin + Open_Temp; + V := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); + Chap3.Translate_Object_Copy + (V, Chap7.Translate_Expression (Expr, Ret_Type), Ret_Type); + Close_Temp; + Gen_Return; + end; + when Type_Mode_File => + -- FIXME: Is it possible ? + Error_Kind ("translate_return_statement", Ret_Type); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Return_Statement; + + procedure Translate_If_Statement (Stmt : Iir) + is + Blk : O_If_Block; + Else_Clause : Iir; + begin + Start_If_Stmt + (Blk, Chap7.Translate_Expression (Get_Condition (Stmt))); + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Else_Clause := Get_Else_Clause (Stmt); + if Else_Clause /= Null_Iir then + New_Else_Stmt (Blk); + if Get_Condition (Else_Clause) = Null_Iir then + Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Else_Clause)); + else + Open_Temp; + Translate_If_Statement (Else_Clause); + Close_Temp; + end if; + end if; + Finish_If_Stmt (Blk); + end Translate_If_Statement; + + function Get_Range_Ptr_Field_Value (O_Range : O_Lnode; Field : O_Fnode) + return O_Enode + is + begin + return New_Value (New_Selected_Element + (New_Access_Element (New_Value (O_Range)), Field)); + end Get_Range_Ptr_Field_Value; + + -- Inc or dec ITERATOR according to DIR. + procedure Gen_Update_Iterator (Iterator : O_Dnode; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir) + is + Op : ON_Op_Kind; + Base_Type : Iir; + V : O_Enode; + begin + case Dir is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + Base_Type := Get_Base_Type (Itype); + case Get_Kind (Base_Type) is + when Iir_Kind_Integer_Type_Definition => + V := New_Lit + (New_Signed_Literal + (Get_Ortho_Type (Base_Type, Mode_Value), Integer_64 (Val))); + when Iir_Kind_Enumeration_Type_Definition => + declare + List : Iir_List; + begin + List := Get_Enumeration_Literal_List (Base_Type); + -- FIXME: what about type E is ('T') ?? + if Natural (Val) > Get_Nbr_Elements (List) then + raise Internal_Error; + end if; + V := New_Lit + (Get_Ortho_Expr (Get_Nth_Element (List, Natural (Val)))); + end; + + when others => + Error_Kind ("gen_update_iterator", Base_Type); + end case; + New_Assign_Stmt (New_Obj (Iterator), + New_Dyadic_Op (Op, New_Obj_Value (Iterator), V)); + end Gen_Update_Iterator; + + type For_Loop_Data is record + Iterator : Iir_Iterator_Declaration; + Stmt : Iir_For_Loop_Statement; + -- If around the loop, to check if the loop must be executed. + If_Blk : O_If_Block; + Label_Next, Label_Exit : O_Snode; + -- Right bound of the iterator, used only if the iterator is a + -- range expression. + O_Right : O_Dnode; + -- Range variable of the iterator, used only if the iterator is not + -- a range expression. + O_Range : O_Dnode; + end record; + + procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration; + Stmt : Iir_For_Loop_Statement; + Data : out For_Loop_Data) + is + Iter_Type : Iir; + Iter_Base_Type : Iir; + Var_Iter : Var_Type; + Constraint : Iir; + Cond : O_Enode; + Dir : Iir_Direction; + Iter_Type_Info : Ortho_Info_Acc; + Op : ON_Op_Kind; + begin + -- Initialize DATA. + Data.Iterator := Iterator; + Data.Stmt := Stmt; + + Iter_Type := Get_Type (Iterator); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + Var_Iter := Get_Info (Iterator).Iterator_Var; + + Open_Temp; + + Constraint := Get_Range_Constraint (Iter_Type); + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + New_Assign_Stmt + (Get_Var (Var_Iter), Chap7.Translate_Range_Expression_Left + (Constraint, Iter_Base_Type)); + Dir := Get_Direction (Constraint); + Data.O_Right := Create_Temp + (Iter_Type_Info.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Obj (Data.O_Right), Chap7.Translate_Range_Expression_Right + (Constraint, Iter_Base_Type)); + case Dir is + when Iir_To => + Op := ON_Le; + when Iir_Downto => + Op := ON_Ge; + end case; + -- Check for at least one iteration. + Cond := New_Compare_Op + (Op, New_Value (Get_Var (Var_Iter)), + New_Obj_Value (Data.O_Right), + Ghdl_Bool_Type); + else + Data.O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type); + New_Assign_Stmt (New_Obj (Data.O_Range), + New_Address (Chap7.Translate_Range + (Constraint, Iter_Base_Type), + Iter_Type_Info.T.Range_Ptr_Type)); + New_Assign_Stmt + (Get_Var (Var_Iter), Get_Range_Ptr_Field_Value + (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Left)); + -- Before starting the loop, check wether there will be at least + -- one iteration. + Cond := New_Compare_Op + (ON_Gt, + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type); + end if; + + Start_If_Stmt (Data.If_Blk, Cond); + + -- Start loop. + -- There are two blocks: one for the exit, one for the next. + Start_Loop_Stmt (Data.Label_Exit); + Start_Loop_Stmt (Data.Label_Next); + + if Stmt /= Null_Iir then + declare + Loop_Info : Loop_Info_Acc; + begin + Loop_Info := Add_Info (Stmt, Kind_Loop); + Loop_Info.Label_Exit := Data.Label_Exit; + Loop_Info.Label_Next := Data.Label_Next; + end; + end if; + end Start_For_Loop; + + procedure Finish_For_Loop (Data : in out For_Loop_Data) + is + Cond : O_Enode; + If_Blk1 : O_If_Block; + Iter_Type : Iir; + Iter_Base_Type : Iir; + Iter_Type_Info : Type_Info_Acc; + Var_Iter : Var_Type; + Constraint : Iir; + Deep_Rng : Iir; + Deep_Reverse : Boolean; + begin + New_Exit_Stmt (Data.Label_Next); + Finish_Loop_Stmt (Data.Label_Next); + + -- Check end of loop. + -- Equality is necessary and enough. + Iter_Type := Get_Type (Data.Iterator); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + Var_Iter := Get_Info (Data.Iterator).Iterator_Var; + + Constraint := Get_Range_Constraint (Iter_Type); + + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + Cond := New_Obj_Value (Data.O_Right); + else + Cond := Get_Range_Ptr_Field_Value + (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Right); + end if; + Gen_Exit_When (Data.Label_Exit, + New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)), + Cond, Ghdl_Bool_Type)); + + -- Update the iterator. + Chap6.Get_Deep_Range_Expression (Iter_Type, Deep_Rng, Deep_Reverse); + if Deep_Rng /= Null_Iir then + if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + else + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + end if; + else + Start_If_Stmt + (If_Blk1, New_Compare_Op + (ON_Eq, + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + New_Else_Stmt (If_Blk1); + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + Finish_If_Stmt (If_Blk1); + end if; + + Finish_Loop_Stmt (Data.Label_Exit); + Finish_If_Stmt (Data.If_Blk); + Close_Temp; + + if Data.Stmt /= Null_Iir then + Free_Info (Data.Stmt); + end if; + end Finish_For_Loop; + + Current_Loop : Iir := Null_Iir; + + procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) + is + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Iter_Type : constant Iir := Get_Type (Iterator); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); + Data : For_Loop_Data; + It_Info : Ortho_Info_Acc; + Var_Iter : Var_Type; + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + Start_Declare_Stmt; + + Chap3.Translate_Object_Subtype (Iterator, False); + + -- Create info for the iterator. + It_Info := Add_Info (Iterator, Kind_Iterator); + Var_Iter := Create_Var + (Create_Var_Identifier (Iterator), + Iter_Type_Info.Ortho_Type (Mode_Value), + O_Storage_Local); + It_Info.Iterator_Var := Var_Iter; + + Start_For_Loop (Iterator, Stmt, Data); + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Finish_For_Loop (Data); + + Finish_Declare_Stmt; + + Free_Info (Iterator); + Current_Loop := Prev_Loop; + end Translate_For_Loop_Statement; + + procedure Translate_While_Loop_Statement + (Stmt : Iir_While_Loop_Statement) + is + Info : Loop_Info_Acc; + Cond : Iir; + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + + Info := Add_Info (Stmt, Kind_Loop); + + Start_Loop_Stmt (Info.Label_Exit); + Info.Label_Next := O_Snode_Null; + + Open_Temp; + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Gen_Exit_When + (Info.Label_Exit, + New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond))); + end if; + Close_Temp; + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Finish_Loop_Stmt (Info.Label_Exit); + Free_Info (Stmt); + Current_Loop := Prev_Loop; + end Translate_While_Loop_Statement; + + procedure Translate_Exit_Next_Statement (Stmt : Iir) + is + Cond : constant Iir := Get_Condition (Stmt); + If_Blk : O_If_Block; + Info : Loop_Info_Acc; + Loop_Label : Iir; + Loop_Stmt : Iir; + begin + if Cond /= Null_Iir then + Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); + end if; + + Loop_Label := Get_Loop_Label (Stmt); + if Loop_Label = Null_Iir then + Loop_Stmt := Current_Loop; + else + Loop_Stmt := Get_Named_Entity (Loop_Label); + end if; + + Info := Get_Info (Loop_Stmt); + case Get_Kind (Stmt) is + when Iir_Kind_Exit_Statement => + New_Exit_Stmt (Info.Label_Exit); + when Iir_Kind_Next_Statement => + if Info.Label_Next /= O_Snode_Null then + -- For-loop. + New_Exit_Stmt (Info.Label_Next); + else + -- While-loop. + New_Next_Stmt (Info.Label_Exit); + end if; + when others => + raise Internal_Error; + end case; + if Cond /= Null_Iir then + Finish_If_Stmt (If_Blk); + end if; + end Translate_Exit_Next_Statement; + + procedure Translate_Variable_Aggregate_Assignment + (Targ : Iir; Targ_Type : Iir; Val : Mnode); + + procedure Translate_Variable_Array_Aggr + (Targ : Iir_Aggregate; + Targ_Type : Iir; + Val : Mnode; + Index : in out Unsigned_64; + Dim : Natural) + is + El : Iir; + Final : Boolean; + El_Type : Iir; + begin + Final := Dim = Get_Nbr_Elements (Get_Index_Subtype_List (Targ_Type)); + if Final then + El_Type := Get_Element_Subtype (Targ_Type); + end if; + El := Get_Association_Choices_Chain (Targ); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + if Final then + Translate_Variable_Aggregate_Assignment + (Get_Associated_Expr (El), El_Type, + Chap3.Index_Base + (Val, Targ_Type, + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Index)))); + Index := Index + 1; + else + Translate_Variable_Array_Aggr + (Get_Associated_Expr (El), + Targ_Type, Val, Index, Dim + 1); + end if; + when others => + Error_Kind ("translate_variable_array_aggr", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Variable_Array_Aggr; + + procedure Translate_Variable_Rec_Aggr + (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode) + is + Aggr_El : Iir; + El_List : Iir_List; + El_Index : Natural; + Elem : Iir; + begin + El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); + El_Index := 0; + Aggr_El := Get_Association_Choices_Chain (Targ); + while Aggr_El /= Null_Iir loop + case Get_Kind (Aggr_El) is + when Iir_Kind_Choice_By_None => + Elem := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Elem := Get_Choice_Name (Aggr_El); + when others => + Error_Kind ("translate_variable_rec_aggr", Aggr_El); + end case; + Translate_Variable_Aggregate_Assignment + (Get_Associated_Expr (Aggr_El), Get_Type (Elem), + Chap6.Translate_Selected_Element (Val, Elem)); + Aggr_El := Get_Chain (Aggr_El); + end loop; + end Translate_Variable_Rec_Aggr; + + procedure Translate_Variable_Aggregate_Assignment + (Targ : Iir; Targ_Type : Iir; Val : Mnode) + is + Index : Unsigned_64; + begin + if Get_Kind (Targ) = Iir_Kind_Aggregate then + case Get_Kind (Targ_Type) is + when Iir_Kinds_Array_Type_Definition => + Index := 0; + Translate_Variable_Array_Aggr + (Targ, Targ_Type, Val, Index, 1); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Variable_Rec_Aggr (Targ, Targ_Type, Val); + when others => + Error_Kind + ("translate_variable_aggregate_assignment", Targ_Type); + end case; + else + declare + Targ_Node : Mnode; + begin + Targ_Node := Chap6.Translate_Name (Targ); + Chap3.Translate_Object_Copy (Targ_Node, M2E (Val), Targ_Type); + end; + end if; + end Translate_Variable_Aggregate_Assignment; + + procedure Translate_Variable_Assignment_Statement + (Stmt : Iir_Variable_Assignment_Statement) + is + Target : constant Iir := Get_Target (Stmt); + Targ_Type : constant Iir := Get_Type (Target); + Expr : constant Iir := Get_Expression (Stmt); + Targ_Node : Mnode; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + declare + E : O_Enode; + Temp : Mnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Targ_Type, True); + + -- Use a temporary variable, to avoid overlap. + Temp := Create_Temp (Get_Info (Targ_Type)); + Chap4.Allocate_Complex_Object (Targ_Type, Alloc_Stack, Temp); + + E := Chap7.Translate_Expression (Expr, Targ_Type); + Chap3.Translate_Object_Copy (Temp, E, Targ_Type); + Translate_Variable_Aggregate_Assignment + (Target, Targ_Type, Temp); + return; + end; + else + Targ_Node := Chap6.Translate_Name (Target); + if Get_Kind (Expr) = Iir_Kind_Aggregate then + declare + E : O_Enode; + begin + E := Chap7.Translate_Expression (Expr, Targ_Type); + Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type); + end; + else + Chap7.Translate_Assign (Targ_Node, Expr, Targ_Type); + end if; + end if; + end Translate_Variable_Assignment_Statement; + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir) + is + Expr : Iir; + Msg : O_Enode; + Severity : O_Enode; + Assocs : O_Assoc_List; + Loc : O_Dnode; + begin + Loc := Chap4.Get_Location (Stmt); + Expr := Get_Report_Expression (Stmt); + if Expr = Null_Iir then + Msg := New_Lit (New_Null_Access (Std_String_Ptr_Node)); + else + Msg := Chap7.Translate_Expression (Expr, String_Type_Definition); + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr = Null_Iir then + Severity := New_Lit (Get_Ortho_Expr (Level)); + else + Severity := Chap7.Translate_Expression (Expr); + end if; + -- Do call. + Start_Association (Assocs, Subprg); + New_Association (Assocs, Msg); + New_Association (Assocs, Severity); + New_Association (Assocs, New_Address (New_Obj (Loc), + Ghdl_Location_Ptr_Node)); + New_Procedure_Call (Assocs); + end Translate_Report; + + -- Return True if the current library unit is part of library IEEE. + function Is_Within_Ieee_Library return Boolean + is + Design_File : Iir; + Library : Iir; + begin + -- Guard. + if Current_Library_Unit = Null_Iir then + return False; + end if; + Design_File := + Get_Design_File (Get_Design_Unit (Current_Library_Unit)); + Library := Get_Library (Design_File); + return Get_Identifier (Library) = Std_Names.Name_Ieee; + end Is_Within_Ieee_Library; + + procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) + is + Expr : Iir; + If_Blk : O_If_Block; + Subprg : O_Dnode; + begin + -- Select the procedure to call in case of assertion (so that + -- assertions within the IEEE library could be ignored). + if Is_Within_Ieee_Library then + Subprg := Ghdl_Ieee_Assert_Failed; + else + Subprg := Ghdl_Assert_Failed; + end if; + + Expr := Get_Assertion_Condition (Stmt); + if Get_Expr_Staticness (Expr) = Locally then + if Eval_Pos (Expr) = 1 then + -- Assert TRUE is a noop. + -- FIXME: generate a noop ? + return; + end if; + Translate_Report (Stmt, Subprg, Severity_Level_Error); + else + -- An assertion is reported if the condition is false! + Start_If_Stmt (If_Blk, + New_Monadic_Op (ON_Not, + Chap7.Translate_Expression (Expr))); + -- Note: it is necessary to create a declare block, to avoid bad + -- order with the if block. + Open_Temp; + Translate_Report (Stmt, Subprg, Severity_Level_Error); + Close_Temp; + Finish_If_Stmt (If_Blk); + end if; + end Translate_Assertion_Statement; + + procedure Translate_Report_Statement (Stmt : Iir_Report_Statement) is + begin + Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note); + end Translate_Report_Statement; + + -- Helper to compare a string choice with the selector. + function Translate_Simple_String_Choice + (Expr : O_Dnode; + Val : O_Enode; + Val_Node : O_Dnode; + Tinfo : Type_Info_Acc; + Func : Iir) + return O_Enode + is + Assoc : O_Assoc_List; + Func_Info : Subprg_Info_Acc; + begin + New_Assign_Stmt + (New_Selected_Element (New_Obj (Val_Node), + Tinfo.T.Base_Field (Mode_Value)), + Val); + Func_Info := Get_Info (Func); + Start_Association (Assoc, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); + New_Association (Assoc, New_Obj_Value (Expr)); + New_Association + (Assoc, New_Address (New_Obj (Val_Node), + Tinfo.Ortho_Ptr_Type (Mode_Value))); + return New_Function_Call (Assoc); + end Translate_Simple_String_Choice; + + -- Helper to evaluate the selector and preparing a choice variable. + procedure Translate_String_Case_Statement_Common + (Stmt : Iir_Case_Statement; + Expr_Type : out Iir; + Tinfo : out Type_Info_Acc; + Expr_Node : out O_Dnode; + C_Node : out O_Dnode) + is + Expr : Iir; + Base_Type : Iir; + begin + -- Translate into if/elsif statements. + -- FIXME: if the number of literals ** length of the array < 256, + -- use a case statement. + Expr := Get_Expression (Stmt); + Expr_Type := Get_Type (Expr); + Base_Type := Get_Base_Type (Expr_Type); + Tinfo := Get_Info (Base_Type); + + -- Translate selector. + Expr_Node := Create_Temp_Init + (Tinfo.Ortho_Ptr_Type (Mode_Value), + Chap7.Translate_Expression (Expr, Base_Type)); + + -- Copy the bounds for the choices. + C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (C_Node), + Tinfo.T.Bounds_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); + end Translate_String_Case_Statement_Common; + + -- Translate a string case statement using a dichotomy. + procedure Translate_String_Case_Statement_Dichotomy + (Stmt : Iir_Case_Statement) + is + -- Selector. + Expr_Type : Iir; + Tinfo : Type_Info_Acc; + Expr_Node : O_Dnode; + C_Node : O_Dnode; + + Choices_Chain : Iir; + Choice : Iir; + Has_Others : Boolean; + Func : Iir; + + -- Number of non-others choices. + Nbr_Choices : Natural; + -- Number of associations. + Nbr_Assocs : Natural; + + Info : Ortho_Info_Acc; + First, Last : Ortho_Info_Acc; + Sel_Length : Iir_Int64; + + -- Dichotomy table (table of choices). + String_Type : O_Tnode; + Table_Base_Type : O_Tnode; + Table_Type : O_Tnode; + Table : O_Dnode; + List : O_Array_Aggr_List; + Table_Cst : O_Cnode; + + -- Association table. + -- Indexed by the choice, returns an index to the associated + -- statement list. + -- Could be replaced by jump table. + Assoc_Table_Base_Type : O_Tnode; + Assoc_Table_Type : O_Tnode; + Assoc_Table : O_Dnode; + begin + Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); + + -- Count number of choices and number of associations. + Nbr_Choices := 0; + Nbr_Assocs := 0; + Choice := Choices_Chain; + First := null; + Last := null; + Has_Others := False; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + Has_Others := True; + exit; + when Iir_Kind_Choice_By_Expression => + null; + when others => + raise Internal_Error; + end case; + if not Get_Same_Alternative_Flag (Choice) then + Nbr_Assocs := Nbr_Assocs + 1; + end if; + Info := Add_Info (Choice, Kind_Str_Choice); + if First = null then + First := Info; + else + Last.Choice_Chain := Info; + end if; + Last := Info; + Info.Choice_Chain := null; + Info.Choice_Assoc := Nbr_Assocs - 1; + Info.Choice_Parent := Choice; + Info.Choice_Expr := Get_Choice_Expression (Choice); + + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); + end loop; + + -- Sort choices. + declare + procedure Merge_Sort (Head : Ortho_Info_Acc; + Nbr : Natural; + Res : out Ortho_Info_Acc; + Next : out Ortho_Info_Acc) + is + L, R, L_End, R_End : Ortho_Info_Acc; + E, Last : Ortho_Info_Acc; + Half : constant Natural := Nbr / 2; + begin + -- Sorting less than 2 elements is easy! + if Nbr < 2 then + Res := Head; + if Nbr = 0 then + Next := Head; + else + Next := Head.Choice_Chain; + end if; + return; + end if; + + Merge_Sort (Head, Half, L, L_End); + Merge_Sort (L_End, Nbr - Half, R, R_End); + Next := R_End; + + -- Merge + Last := null; + loop + if L /= L_End + and then + (R = R_End + or else + Compare_String_Literals (L.Choice_Expr, R.Choice_Expr) + = Compare_Lt) + then + E := L; + L := L.Choice_Chain; + elsif R /= R_End then + E := R; + R := R.Choice_Chain; + else + exit; + end if; + if Last = null then + Res := E; + else + Last.Choice_Chain := E; + end if; + Last := E; + end loop; + Last.Choice_Chain := R_End; + end Merge_Sort; + Next : Ortho_Info_Acc; + begin + Merge_Sort (First, Nbr_Choices, First, Next); + if Next /= null then + raise Internal_Error; + end if; + end; + + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node); + + -- Generate choices table. + Sel_Length := Eval_Discrete_Type_Length + (Get_String_Type_Bound_Type (Expr_Type)); + String_Type := New_Constrained_Array_Type + (Tinfo.T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length))); + Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type); + Table_Type := New_Constrained_Array_Type + (Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Table_Type); + New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private, + Table_Type); + Start_Const_Value (Table); + Start_Array_Aggr (List, Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El (List, Chap7.Translate_Static_Expression + (Info.Choice_Expr, Expr_Type)); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Table, Table_Cst); + + -- Generate assoc table. + Assoc_Table_Base_Type := + New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type); + Assoc_Table_Type := New_Constrained_Array_Type + (Assoc_Table_Base_Type, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); + New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type); + New_Const_Decl (Assoc_Table, Create_Uniq_Identifier, + O_Storage_Private, Assoc_Table_Type); + Start_Const_Value (Assoc_Table); + Start_Array_Aggr (List, Assoc_Table_Type); + Info := First; + while Info /= null loop + New_Array_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Choice_Assoc))); + Info := Info.Choice_Chain; + end loop; + Finish_Array_Aggr (List, Table_Cst); + Finish_Const_Value (Assoc_Table, Table_Cst); + + -- Generate dichotomy code. + declare + Var_Lo, Var_Hi, Var_Mid : O_Dnode; + Var_Cmp : O_Dnode; + Var_Idx : O_Dnode; + Label : O_Snode; + Others_Lit : O_Cnode; + If_Blk1, If_Blk2 : O_If_Block; + Case_Blk : O_Case_Block; + begin + Var_Idx := Create_Temp (Ghdl_Index_Type); + + Start_Declare_Stmt; + + New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Cmp, Wki_Cmp, + O_Storage_Local, Ghdl_Compare_Type); + + New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0)); + New_Assign_Stmt + (New_Obj (Var_Hi), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Choices)))); + + Func := Chap7.Find_Predefined_Function + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater); + + if Has_Others then + Others_Lit := New_Unsigned_Literal + (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs)); + end if; + + Start_Loop_Stmt (Label); + New_Assign_Stmt + (New_Obj (Var_Mid), + New_Dyadic_Op (ON_Div_Ov, + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Lo), + New_Obj_Value (Var_Hi)), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, 2)))); + New_Assign_Stmt + (New_Obj (Var_Cmp), + Translate_Simple_String_Choice + (Expr_Node, + New_Address (New_Indexed_Element (New_Obj (Table), + New_Obj_Value (Var_Mid)), + Tinfo.T.Base_Ptr_Type (Mode_Value)), + C_Node, Tinfo, Func)); + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Eq), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Var_Idx), + New_Value (New_Indexed_Element (New_Obj (Assoc_Table), + New_Obj_Value (Var_Mid)))); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Cmp), + New_Lit (Ghdl_Compare_Lt), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Le, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Lo), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Hi), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + New_Else_Stmt (If_Blk1); + + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_Mid), + New_Obj_Value (Var_Hi), + Ghdl_Bool_Type)); + if not Has_Others then + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + else + New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); + New_Exit_Stmt (Label); + end if; + New_Else_Stmt (If_Blk2); + New_Assign_Stmt (New_Obj (Var_Lo), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Mid), + New_Lit (Ghdl_Index_1))); + Finish_If_Stmt (If_Blk2); + + Finish_If_Stmt (If_Blk1); + + Finish_Loop_Stmt (Label); + + Finish_Declare_Stmt; + + Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx)); + + Choice := Choices_Chain; + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + Start_Choice (Case_Blk); + New_Expr_Choice (Case_Blk, Others_Lit); + Finish_Choice (Case_Blk); + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); + when Iir_Kind_Choice_By_Expression => + if not Get_Same_Alternative_Flag (Choice) then + Start_Choice (Case_Blk); + New_Expr_Choice + (Case_Blk, + New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Get_Info (Choice).Choice_Assoc))); + Finish_Choice (Case_Blk); + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); + end if; + Free_Info (Choice); + when others => + raise Internal_Error; + end case; + Choice := Get_Chain (Choice); + end loop; + + Start_Choice (Case_Blk); + New_Default_Choice (Case_Blk); + Finish_Choice (Case_Blk); + Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); + + Finish_Case_Stmt (Case_Blk); + end; + end Translate_String_Case_Statement_Dichotomy; + + -- Case statement whose expression is an unidim array. + -- Translate into if/elsif statements (linear search). + procedure Translate_String_Case_Statement_Linear + (Stmt : Iir_Case_Statement) + is + Expr_Type : Iir; + -- Node containing the address of the selector. + Expr_Node : O_Dnode; + -- Node containing the current choice. + Val_Node : O_Dnode; + Tinfo : Type_Info_Acc; + + Cond_Var : O_Dnode; + + Func : Iir; + + procedure Translate_String_Choice (Choice : Iir) + is + Cond : O_Enode; + If_Blk : O_If_Block; + Stmt_Chain : Iir; + First : Boolean; + Ch : Iir; + Ch_Expr : Iir; + begin + if Choice = Null_Iir then + return; + end if; + + First := True; + Stmt_Chain := Get_Associated_Chain (Choice); + Ch := Choice; + loop + case Get_Kind (Ch) is + when Iir_Kind_Choice_By_Expression => + Ch_Expr := Get_Choice_Expression (Ch); + Cond := Translate_Simple_String_Choice + (Expr_Node, + Chap7.Translate_Expression (Ch_Expr, + Get_Type (Ch_Expr)), + Val_Node, Tinfo, Func); + when Iir_Kind_Choice_By_Others => + Translate_Statements_Chain (Stmt_Chain); + return; + when others => + Error_Kind ("translate_string_choice", Ch); + end case; + if not First then + New_Assign_Stmt + (New_Obj (Cond_Var), + New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); + end if; + Ch := Get_Chain (Ch); + exit when Ch = Null_Iir; + exit when not Get_Same_Alternative_Flag (Ch); + exit when Get_Associated_Chain (Ch) /= Null_Iir; + if First then + New_Assign_Stmt (New_Obj (Cond_Var), Cond); + First := False; + end if; + end loop; + if not First then + Cond := New_Obj_Value (Cond_Var); + end if; + Start_If_Stmt (If_Blk, Cond); + Translate_Statements_Chain (Stmt_Chain); + New_Else_Stmt (If_Blk); + Translate_String_Choice (Ch); + Finish_If_Stmt (If_Blk); + end Translate_String_Choice; + begin + Translate_String_Case_Statement_Common + (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node); + + Func := Chap7.Find_Predefined_Function + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); + + Cond_Var := Create_Temp (Std_Boolean_Type_Node); + + Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt)); + end Translate_String_Case_Statement_Linear; + + procedure Translate_Case_Choice + (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block) + is + Expr : Iir; + begin + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + New_Default_Choice (Blk); + when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); + New_Expr_Choice + (Blk, Chap7.Translate_Static_Expression (Expr, Choice_Type)); + when Iir_Kind_Choice_By_Range => + declare + H, L : Iir; + begin + Expr := Get_Choice_Range (Choice); + Get_Low_High_Limit (Expr, L, H); + New_Range_Choice + (Blk, + Chap7.Translate_Static_Expression (L, Choice_Type), + Chap7.Translate_Static_Expression (H, Choice_Type)); + end; + when others => + Error_Kind ("translate_case_choice", Choice); + end case; + end Translate_Case_Choice; + + procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) + is + Expr : Iir; + Expr_Type : Iir; + Case_Blk : O_Case_Block; + Choice : Iir; + Stmt_Chain : Iir; + begin + Expr := Get_Expression (Stmt); + Expr_Type := Get_Type (Expr); + if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then + declare + Nbr_Choices : Natural := 0; + Choice : Iir; + begin + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + exit; + when Iir_Kind_Choice_By_Expression => + null; + when others => + raise Internal_Error; + end case; + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); + end loop; + + if Nbr_Choices < 3 then + Translate_String_Case_Statement_Linear (Stmt); + else + Translate_String_Case_Statement_Dichotomy (Stmt); + end if; + end; + return; + end if; + Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + Start_Choice (Case_Blk); + Stmt_Chain := Get_Associated_Chain (Choice); + loop + Translate_Case_Choice (Choice, Expr_Type, Case_Blk); + Choice := Get_Chain (Choice); + exit when Choice = Null_Iir; + exit when not Get_Same_Alternative_Flag (Choice); + pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); + end loop; + Finish_Choice (Case_Blk); + Translate_Statements_Chain (Stmt_Chain); + end loop; + Finish_Case_Stmt (Case_Blk); + end Translate_Case_Statement; + + procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) + is + F_Assoc : Iir; + Value_Assoc : Iir; + Value : O_Dnode; + Formal_Type : Iir; + Tinfo : Type_Info_Acc; + Assocs : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + begin + F_Assoc := Param_Chain; + Value_Assoc := Get_Chain (Param_Chain); + Formal_Type := Get_Type (Get_Formal (Value_Assoc)); + Tinfo := Get_Info (Formal_Type); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + Open_Temp; + Start_Association (Assocs, Ghdl_Write_Scalar); + -- compute file parameter (get an index) + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + -- compute the value. + Value := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Obj (Value), + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + New_Association + (Assocs, + New_Unchecked_Address (New_Obj (Value), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + Close_Temp; + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Fat_Array => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + New_Procedure_Call (Assocs); + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Write_Procedure_Call; + + procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) + is + F_Assoc : Iir; + Value_Assoc : Iir; + Value : Mnode; + Formal_Type : Iir; + Tinfo : Type_Info_Acc; + Assocs : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + begin + F_Assoc := Param_Chain; + Value_Assoc := Get_Chain (Param_Chain); + Formal_Type := Get_Type (Get_Formal (Value_Assoc)); + Tinfo := Get_Info (Formal_Type); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + Open_Temp; + Start_Association (Assocs, Ghdl_Read_Scalar); + -- compute file parameter (get an index) + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + -- value + Value := Chap6.Translate_Name (Get_Actual (Value_Assoc)); + New_Association + (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + Close_Temp; + when Type_Mode_Array + | Type_Mode_Record => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc))); + New_Procedure_Call (Assocs); + when Type_Mode_Fat_Array => + declare + Length_Assoc : Iir; + Length : Mnode; + begin + Length_Assoc := Get_Chain (Value_Assoc); + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + Length := Chap6.Translate_Name (Get_Actual (Length_Assoc)); + New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs)); + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Read_Procedure_Call; + + procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) + is + Imp : constant Iir := Get_Implementation (Call); + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call); + begin + case Kind is + when Iir_Predefined_Write => + -- Check wether text or not. + declare + File_Param : Iir; + Assocs : O_Assoc_List; + begin + File_Param := Param_Chain; + -- FIXME: do the test. + if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) + then + -- If text: + Start_Association (Assocs, Ghdl_Text_Write); + -- compute file parameter (get an index) + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (File_Param))); + -- compute string parameter (get a fat array pointer) + New_Association + (Assocs, Chap7.Translate_Expression + (Get_Actual (Get_Chain (Param_Chain)), + String_Type_Definition)); + -- call a predefined procedure + New_Procedure_Call (Assocs); + else + Translate_Write_Procedure_Call (Imp, Param_Chain); + end if; + end; + + when Iir_Predefined_Read_Length => + -- FIXME: works only for text read length. + declare + File_Param : Iir; + N_Param : Iir; + Assocs : O_Assoc_List; + Str : O_Enode; + Res : Mnode; + begin + File_Param := Param_Chain; + if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) + then + N_Param := Get_Chain (File_Param); + Str := Chap7.Translate_Expression + (Get_Actual (N_Param), String_Type_Definition); + N_Param := Get_Chain (N_Param); + Res := Chap6.Translate_Name (Get_Actual (N_Param)); + Start_Association (Assocs, Ghdl_Text_Read_Length); + -- compute file parameter (get an index) + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (File_Param))); + -- compute string parameter (get a fat array pointer) + New_Association (Assocs, Str); + -- call a predefined procedure + New_Assign_Stmt + (M2Lv (Res), New_Function_Call (Assocs)); + else + Translate_Read_Procedure_Call (Imp, Param_Chain); + end if; + end; + + when Iir_Predefined_Read => + Translate_Read_Procedure_Call (Imp, Param_Chain); + + when Iir_Predefined_Deallocate => + Chap3.Translate_Object_Deallocation (Get_Actual (Param_Chain)); + + when Iir_Predefined_File_Open => + declare + N_Param : Iir; + File_Param : Iir; + Name_Param : Iir; + Kind_Param : Iir; + Constr : O_Assoc_List; + begin + File_Param := Get_Actual (Param_Chain); + N_Param := Get_Chain (Param_Chain); + Name_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Kind_Param := Get_Actual (N_Param); + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Open); + else + Start_Association (Constr, Ghdl_File_Open); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Association + (Constr, New_Convert_Ov + (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); + New_Association + (Constr, + Chap7.Translate_Expression (Name_Param, + String_Type_Definition)); + New_Procedure_Call (Constr); + end; + + when Iir_Predefined_File_Open_Status => + declare + Std_File_Open_Status_Otype : constant O_Tnode := + Get_Ortho_Type (File_Open_Status_Type_Definition, + Mode_Value); + N_Param : Iir; + Status_Param : constant Iir := Get_Actual (Param_Chain); + File_Param : Iir; + Name_Param : Iir; + Kind_Param : Iir; + Constr : O_Assoc_List; + Status : Mnode; + begin + Status := Chap6.Translate_Name (Status_Param); + N_Param := Get_Chain (Param_Chain); + File_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Name_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Kind_Param := Get_Actual (N_Param); + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Open_Status); + else + Start_Association (Constr, Ghdl_File_Open_Status); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Association + (Constr, New_Convert_Ov + (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); + New_Association + (Constr, + Chap7.Translate_Expression (Name_Param, + String_Type_Definition)); + New_Assign_Stmt + (M2Lv (Status), + New_Convert_Ov (New_Function_Call (Constr), + Std_File_Open_Status_Otype)); + end; + + when Iir_Predefined_File_Close => + declare + File_Param : constant Iir := Get_Actual (Param_Chain); + Constr : O_Assoc_List; + begin + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Close); + else + Start_Association (Constr, Ghdl_File_Close); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Procedure_Call (Constr); + end; + + when Iir_Predefined_Flush => + declare + File_Param : constant Iir := Get_Actual (Param_Chain); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_File_Flush); + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Procedure_Call (Constr); + end; + + when others => + Ada.Text_IO.Put_Line + ("translate_implicit_procedure_call: cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + end case; + end Translate_Implicit_Procedure_Call; + + function Do_Conversion (Conv : Iir; Expr : Iir; Src : Mnode) + return O_Enode + is + Constr : O_Assoc_List; + Conv_Info : Subprg_Info_Acc; + Res : O_Dnode; + Imp : Iir; + begin + if Conv = Null_Iir then + return M2E (Src); +-- case Get_Type_Info (Dest).Type_Mode is +-- when Type_Mode_Thin => +-- New_Assign_Stmt (M2Lv (Dest), M2E (Src)); +-- when Type_Mode_Fat_Acc => +-- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src)); +-- when others => +-- raise Internal_Error; +-- end case; + else + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + -- Call conversion function. + Imp := Get_Implementation (Conv); + Conv_Info := Get_Info (Imp); + Start_Association (Constr, Conv_Info.Ortho_Func); + + if Conv_Info.Res_Interface /= O_Dnode_Null then + Res := Create_Temp (Conv_Info.Res_Record_Type); + -- Composite result. + New_Association + (Constr, + New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Conv_Info.Subprg_Instance); + + New_Association (Constr, M2E (Src)); + + if Conv_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), + Conv_Info.Res_Record_Ptr); + else + return New_Function_Call (Constr); + end if; + when Iir_Kind_Type_Conversion => + return Chap7.Translate_Type_Conversion + (M2E (Src), Get_Type (Expr), + Get_Type (Conv), Null_Iir); + when others => + Error_Kind ("do_conversion", Conv); + end case; + end if; + end Do_Conversion; + + procedure Translate_Procedure_Call (Stmt : Iir_Procedure_Call) + is + type Mnode_Array is array (Natural range <>) of Mnode; + type O_Enode_Array is array (Natural range <>) of O_Enode; + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Nbr_Assoc : constant Natural := + Iir_Chains.Get_Chain_Length (Assoc_Chain); + Params : Mnode_Array (0 .. Nbr_Assoc - 1); + E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); + Imp : constant Iir := Get_Implementation (Stmt); + Info : constant Subprg_Info_Acc := Get_Info (Imp); + Res : O_Dnode; + El : Iir; + Pos : Natural; + Constr : O_Assoc_List; + Act : Iir; + Actual_Type : Iir; + Formal : Iir; + Base_Formal : Iir; + Formal_Type : Iir; + Ftype_Info : Type_Info_Acc; + Formal_Info : Ortho_Info_Acc; + Val : O_Enode; + Param : Mnode; + Last_Individual : Natural; + Ptr : O_Lnode; + In_Conv : Iir; + In_Expr : Iir; + Out_Conv : Iir; + Out_Expr : Iir; + Formal_Object_Kind : Object_Kind_Type; + Bounds : Mnode; + Obj : Iir; + begin + -- Create an in-out result record for in-out arguments passed by + -- value. + if Info.Res_Record_Type /= O_Tnode_Null then + Res := Create_Temp (Info.Res_Record_Type); + else + Res := O_Dnode_Null; + end if; + + -- Evaluate in-out parameters and parameters passed by ref, since + -- they can add declarations. + -- Non-composite in-out parameters address are saved in order to + -- be able to assignate the result. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Params (Pos) := Mnode_Null; + E_Params (Pos) := O_Enode_Null; + + Formal := Get_Formal (El); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + Base_Formal := Get_Association_Interface (El); + Formal_Type := Get_Type (Formal); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration + then + Formal_Object_Kind := Mode_Signal; + else + Formal_Object_Kind := Mode_Value; + end if; + Ftype_Info := Get_Info (Formal_Type); + + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Act := Get_Default_Value (Formal); + In_Conv := Null_Iir; + Out_Conv := Null_Iir; + when Iir_Kind_Association_Element_By_Expression => + Act := Get_Actual (El); + In_Conv := Get_In_Conversion (El); + Out_Conv := Get_Out_Conversion (El); + when Iir_Kind_Association_Element_By_Individual => + Actual_Type := Get_Actual_Type (El); + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- A non-composite type cannot be associated by element. + raise Internal_Error; + end if; + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + Chap3.Create_Array_Subtype (Actual_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Param := Create_Temp (Ftype_Info, Formal_Object_Kind); + Chap3.Translate_Object_Allocation + (Param, Alloc_Stack, Formal_Type, Bounds); + else + Param := Create_Temp (Ftype_Info, Formal_Object_Kind); + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc_Stack, Param); + end if; + Last_Individual := Pos; + Params (Pos) := Param; + goto Continue; + when others => + Error_Kind ("translate_procedure_call", El); + end case; + Actual_Type := Get_Type (Act); + + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- Copy-out argument. + -- This is not a composite type. + Param := Chap6.Translate_Name (Act); + if Get_Object_Kind (Param) /= Mode_Value then + raise Internal_Error; + end if; + Params (Pos) := Stabilize (Param); + if In_Conv /= Null_Iir + or else Get_Mode (Formal) = Iir_Inout_Mode + then + -- Arguments may be assigned if there is an in conversion. + Ptr := New_Selected_Element + (New_Obj (Res), Formal_Info.Interface_Field); + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + if In_Conv /= Null_Iir then + In_Expr := In_Conv; + else + In_Expr := Act; + end if; + Chap7.Translate_Assign + (Param, + Do_Conversion (In_Conv, Act, Params (Pos)), + In_Expr, + Formal_Type, El); + end if; + elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then + -- Passed by reference. + case Get_Kind (Base_Formal) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + -- No conversion here. + E_Params (Pos) := Chap7.Translate_Expression + (Act, Formal_Type); + when Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Param := Chap6.Translate_Name (Act); + -- Atype may not have been set (eg: slice). + if Base_Formal /= Formal then + Stabilize (Param); + Params (Pos) := Param; + end if; + E_Params (Pos) := M2E (Param); + if Formal_Type /= Actual_Type then + -- Implicit array conversion or subtype check. + E_Params (Pos) := Chap7.Translate_Implicit_Conv + (E_Params (Pos), Actual_Type, Formal_Type, + Get_Object_Kind (Param), Stmt); + end if; + when others => + Error_Kind ("translate_procedure_call(2)", Formal); + end case; + end if; + if Base_Formal /= Formal then + -- Individual association. + if Ftype_Info.Type_Mode not in Type_Mode_By_Value then + -- Not by-value actual already translated. + Val := E_Params (Pos); + else + -- By value association. + Act := Get_Actual (El); + if Get_Kind (Base_Formal) + = Iir_Kind_Interface_Constant_Declaration + then + Val := Chap7.Translate_Expression (Act, Formal_Type); + else + Params (Pos) := Chap6.Translate_Name (Act); + -- Since signals are passed by reference, they are not + -- copied back, so do not stabilize them (furthermore, + -- it is not possible to stabilize them). + if Formal_Object_Kind = Mode_Value then + Params (Pos) := Stabilize (Params (Pos)); + end if; + Val := M2E (Params (Pos)); + end if; + end if; + -- Assign formal. + -- Change the formal variable so that it is the local variable + -- that will be passed to the subprogram. + declare + Prev_Node : O_Dnode; + begin + Prev_Node := Formal_Info.Interface_Node; + -- We need a pointer since the interface is by reference. + Formal_Info.Interface_Node := + M2Dp (Params (Last_Individual)); + Param := Chap6.Translate_Name (Formal); + Formal_Info.Interface_Node := Prev_Node; + end; + Chap7.Translate_Assign (Param, Val, Act, Formal_Type, El); + end if; + << Continue >> null; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + + -- Second stage: really perform the call. + Start_Association (Constr, Info.Ortho_Func); + if Res /= O_Dnode_Null then + New_Association (Constr, + New_Address (New_Obj (Res), Info.Res_Record_Ptr)); + end if; + + Obj := Get_Method_Object (Stmt); + if Obj /= Null_Iir then + New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + -- Parameters. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Formal := Get_Formal (El); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + Base_Formal := Get_Association_Interface (El); + Formal_Info := Get_Info (Base_Formal); + Formal_Type := Get_Type (Formal); + Ftype_Info := Get_Info (Formal_Type); + + if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then + Last_Individual := Pos; + New_Association (Constr, M2E (Params (Pos))); + elsif Base_Formal /= Formal then + -- Individual association. + null; + elsif Formal_Info.Interface_Field = O_Fnode_Null then + if Ftype_Info.Type_Mode in Type_Mode_By_Value then + -- Parameter passed by value. + if E_Params (Pos) /= O_Enode_Null then + Val := E_Params (Pos); + raise Internal_Error; + else + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Act := Get_Default_Value (Formal); + In_Conv := Null_Iir; + when Iir_Kind_Association_Element_By_Expression => + Act := Get_Actual (El); + In_Conv := Get_In_Conversion (El); + when others => + Error_Kind ("translate_procedure_call(2)", El); + end case; + case Get_Kind (Formal) is + when Iir_Kind_Interface_Signal_Declaration => + Param := Chap6.Translate_Name (Act); + -- This is a scalar. + Val := M2E (Param); + when others => + if In_Conv = Null_Iir then + Val := Chap7.Translate_Expression + (Act, Formal_Type); + else + Actual_Type := Get_Type (Act); + Val := Do_Conversion + (In_Conv, + Act, + E2M (Chap7.Translate_Expression (Act, + Actual_Type), + Get_Info (Actual_Type), + Mode_Value)); + end if; + end case; + end if; + New_Association (Constr, Val); + else + -- Parameter passed by ref, which was already computed. + New_Association (Constr, E_Params (Pos)); + end if; + end if; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + + New_Procedure_Call (Constr); + + -- Copy-out non-composite parameters. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Formal := Get_Formal (El); + Base_Formal := Get_Association_Interface (El); + Formal_Type := Get_Type (Formal); + Ftype_Info := Get_Info (Formal_Type); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Base_Formal) in Iir_Out_Modes + and then Params (Pos) /= Mnode_Null + then + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- OUT parameters. + Out_Conv := Get_Out_Conversion (El); + if Out_Conv = Null_Iir then + Out_Expr := Formal; + else + Out_Expr := Out_Conv; + end if; + Ptr := New_Selected_Element + (New_Obj (Res), Formal_Info.Interface_Field); + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + Chap7.Translate_Assign (Params (Pos), + Do_Conversion (Out_Conv, Formal, + Param), + Out_Expr, + Get_Type (Get_Actual (El)), El); + elsif Base_Formal /= Formal then + -- By individual. + -- Copy back. + Act := Get_Actual (El); + declare + Prev_Node : O_Dnode; + begin + Prev_Node := Formal_Info.Interface_Node; + -- We need a pointer since the interface is by reference. + Formal_Info.Interface_Node := + M2Dp (Params (Last_Individual)); + Val := Chap7.Translate_Expression + (Formal, Get_Type (Act)); + Formal_Info.Interface_Node := Prev_Node; + end; + Chap7.Translate_Assign + (Params (Pos), Val, Formal, Get_Type (Act), El); + end if; + end if; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + end Translate_Procedure_Call; + + procedure Translate_Wait_Statement (Stmt : Iir) + is + Sensitivity : Iir_List; + Cond : Iir; + Timeout : Iir; + Constr : O_Assoc_List; + begin + Sensitivity := Get_Sensitivity_List (Stmt); + Cond := Get_Condition_Clause (Stmt); + Timeout := Get_Timeout_Clause (Stmt); + + if Sensitivity = Null_Iir_List and Cond /= Null_Iir then + Sensitivity := Create_Iir_List; + Canon.Canon_Extract_Sensitivity (Cond, Sensitivity); + Set_Sensitivity_List (Stmt, Sensitivity); + end if; + + -- Check for simple cases. + if Sensitivity = Null_Iir_List + and then Cond = Null_Iir + then + if Timeout = Null_Iir then + -- Process exit. + Start_Association (Constr, Ghdl_Process_Wait_Exit); + New_Procedure_Call (Constr); + else + -- Wait for a timeout. + Start_Association (Constr, Ghdl_Process_Wait_Timeout); + New_Association (Constr, Chap7.Translate_Expression + (Timeout, Time_Type_Definition)); + New_Procedure_Call (Constr); + end if; + return; + end if; + + -- Evaluate the timeout (if any) and register it, + if Timeout /= Null_Iir then + Start_Association (Constr, Ghdl_Process_Wait_Set_Timeout); + New_Association (Constr, Chap7.Translate_Expression + (Timeout, Time_Type_Definition)); + New_Procedure_Call (Constr); + end if; + + -- Evaluate the sensitivity list and register it. + if Sensitivity /= Null_Iir_List then + Register_Signal_List + (Sensitivity, Ghdl_Process_Wait_Add_Sensitivity); + end if; + + if Cond = Null_Iir then + declare + V : O_Dnode; + begin + -- declare + -- v : __ghdl_bool_type_node; + -- begin + -- v := suspend (); + -- end; + Open_Temp; + V := Create_Temp (Ghdl_Bool_Type); + Start_Association (Constr, Ghdl_Process_Wait_Suspend); + New_Assign_Stmt (New_Obj (V), New_Function_Call (Constr)); + Close_Temp; + end; + else + declare + Label : O_Snode; + begin + -- start loop + Start_Loop_Stmt (Label); + + -- if suspend() then -- return true if timeout. + -- exit; + -- end if; + Start_Association (Constr, Ghdl_Process_Wait_Suspend); + Gen_Exit_When (Label, New_Function_Call (Constr)); + + -- if condition then + -- exit; + -- end if; + Open_Temp; + Gen_Exit_When + (Label, + Chap7.Translate_Expression (Cond, Boolean_Type_Definition)); + Close_Temp; + + -- end loop; + Finish_Loop_Stmt (Label); + end; + end if; + + -- wait_close; + Start_Association (Constr, Ghdl_Process_Wait_Close); + New_Procedure_Call (Constr); + end Translate_Wait_Statement; + + -- Signal assignment. + Signal_Assign_Line : Natural; + procedure Gen_Simple_Signal_Assign_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Val : O_Enode) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Simple_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Simple_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Simple_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Simple_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Simple_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Simple_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_assign_non_composite", Targ_Type); + end case; + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + Val2 : O_Dnode; + Targ2 : O_Dnode; + begin + Open_Temp; + Val2 := Create_Temp_Init + (Type_Info.Ortho_Type (Mode_Value), Val); + Targ2 := Create_Temp_Init + (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + Start_If_Stmt (If_Blk, Chap3.Not_In_Range (Val2, Targ_Type)); + Start_Association (Assoc, Ghdl_Signal_Simple_Assign_Error); + New_Association (Assoc, New_Obj_Value (Targ2)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + New_Else_Stmt (If_Blk); + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Targ2)); + New_Association + (Assoc, New_Convert_Ov (New_Obj_Value (Val2), Conv)); + New_Procedure_Call (Assoc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Convert_Ov (Val, Conv)); + New_Procedure_Call (Assoc); + end if; + end Gen_Simple_Signal_Assign_Non_Composite; + + procedure Gen_Simple_Signal_Assign is new Foreach_Non_Composite + (Data_Type => O_Enode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Gen_Simple_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite, + Update_Data_Array => Gen_Oenode_Update_Data_Array, + Finish_Data_Array => Gen_Oenode_Finish_Data_Composite, + Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite, + Update_Data_Record => Gen_Oenode_Update_Data_Record, + Finish_Data_Record => Gen_Oenode_Finish_Data_Composite); + + type Signal_Assign_Data is record + Expr : Mnode; + Reject : O_Dnode; + After : O_Dnode; + end record; + + procedure Gen_Start_Signal_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + if Data.Expr = Mnode_Null then + -- Null transaction. + Start_Association (Assoc, Ghdl_Signal_Start_Assign_Null); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + return; + end if; + + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Start_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Start_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Start_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Start_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Start_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Start_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_assign_non_composite", Targ_Type); + end case; + -- Check range. + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + V : Mnode; + Starg : O_Dnode; + begin + Open_Temp; + V := Stabilize_Value (Data.Expr); + Starg := Create_Temp_Init + (Ghdl_Signal_Ptr, + New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + Start_If_Stmt + (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); + Start_Association (Assoc, Ghdl_Signal_Start_Assign_Error); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Obj_Value (Data.After)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + New_Else_Stmt (If_Blk); + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + end if; + end Gen_Start_Signal_Assign_Non_Composite; + + function Gen_Signal_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) + return Signal_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Signal_Prepare_Data_Composite; + + function Gen_Signal_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) + return Signal_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + if Val.Expr = Mnode_Null then + return Val; + else + return Signal_Assign_Data' + (Expr => Stabilize (Val.Expr), + Reject => Val.Reject, + After => Val.After); + end if; + end Gen_Signal_Prepare_Data_Record; + + function Gen_Signal_Update_Data_Array + (Val : Signal_Assign_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Signal_Assign_Data + is + Res : Signal_Assign_Data; + begin + if Val.Expr = Mnode_Null then + -- Handle null transaction. + return Val; + end if; + Res := Signal_Assign_Data' + (Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), + Targ_Type, New_Obj_Value (Index)), + Reject => Val.Reject, + After => Val.After); + return Res; + end Gen_Signal_Update_Data_Array; + + function Gen_Signal_Update_Data_Record + (Val : Signal_Assign_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Signal_Assign_Data + is + pragma Unreferenced (Targ_Type); + Res : Signal_Assign_Data; + begin + if Val.Expr = Mnode_Null then + -- Handle null transaction. + return Val; + end if; + Res := Signal_Assign_Data' + (Expr => Chap6.Translate_Selected_Element (Val.Expr, El), + Reject => Val.Reject, + After => Val.After); + return Res; + end Gen_Signal_Update_Data_Record; + + procedure Gen_Signal_Finish_Data_Composite + (Data : in out Signal_Assign_Data) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Signal_Finish_Data_Composite; + + procedure Gen_Start_Signal_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Assign_Data, + Composite_Data_Type => Signal_Assign_Data, + Do_Non_Composite => Gen_Start_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Finish_Data_Composite); + + procedure Gen_Next_Signal_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + if Data.Expr = Mnode_Null then + -- Null transaction. + Start_Association (Assoc, Ghdl_Signal_Next_Assign_Null); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + return; + end if; + + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Next_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Next_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Next_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Next_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Next_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Next_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_next_assign_non_composite", Targ_Type); + end case; + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + V : Mnode; + Starg : O_Dnode; + begin + Open_Temp; + V := Stabilize_Value (Data.Expr); + Starg := Create_Temp_Init + (Ghdl_Signal_Ptr, + New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + Start_If_Stmt + (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); + + Start_Association (Assoc, Ghdl_Signal_Next_Assign_Error); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.After)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + + New_Else_Stmt (If_Blk); + + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + end if; + end Gen_Next_Signal_Assign_Non_Composite; + + procedure Gen_Next_Signal_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Assign_Data, + Composite_Data_Type => Signal_Assign_Data, + Do_Non_Composite => Gen_Next_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Finish_Data_Composite); + + procedure Translate_Signal_Target_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir); + + procedure Translate_Signal_Target_Array_Aggr + (Aggr : Mnode; + Target : Iir; + Target_Type : Iir; + Idx : O_Dnode; + Dim : Natural) + is + Index_List : constant Iir_List := + Get_Index_Subtype_List (Target_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Sub_Aggr : Mnode; + El : Iir; + Expr : Iir; + begin + El := Get_Association_Choices_Chain (Target); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + Sub_Aggr := Chap3.Index_Base + (Aggr, Target_Type, New_Obj_Value (Idx)); + when others => + Error_Kind ("translate_signal_target_array_aggr", El); + end case; + Expr := Get_Associated_Expr (El); + if Dim = Nbr_Dim then + Translate_Signal_Target_Aggr + (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type)); + if Get_Kind (El) = Iir_Kind_Choice_By_None then + Inc_Var (Idx); + else + raise Internal_Error; + end if; + else + Translate_Signal_Target_Array_Aggr + (Sub_Aggr, Expr, Target_Type, Idx, Dim + 1); + end if; + El := Get_Chain (El); + end loop; + end Translate_Signal_Target_Array_Aggr; + + procedure Translate_Signal_Target_Record_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir) + is + Aggr_El : Iir; + El_List : Iir_List; + El_Index : Natural; + Element : Iir_Element_Declaration; + begin + El_List := Get_Elements_Declaration_List + (Get_Base_Type (Target_Type)); + El_Index := 0; + Aggr_El := Get_Association_Choices_Chain (Target); + while Aggr_El /= Null_Iir loop + case Get_Kind (Aggr_El) is + when Iir_Kind_Choice_By_None => + Element := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Element := Get_Choice_Name (Aggr_El); + El_Index := Natural'Last; + when others => + Error_Kind ("translate_signal_target_record_aggr", Aggr_El); + end case; + Translate_Signal_Target_Aggr + (Chap6.Translate_Selected_Element (Aggr, Element), + Get_Associated_Expr (Aggr_El), Get_Type (Element)); + Aggr_El := Get_Chain (Aggr_El); + end loop; + end Translate_Signal_Target_Record_Aggr; + + procedure Translate_Signal_Target_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir) + is + Src : Mnode; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + declare + Idx : O_Dnode; + St_Aggr : Mnode; + begin + Open_Temp; + St_Aggr := Stabilize (Aggr); + case Get_Kind (Target_Type) is + when Iir_Kinds_Array_Type_Definition => + Idx := Create_Temp (Ghdl_Index_Type); + Init_Var (Idx); + Translate_Signal_Target_Array_Aggr + (St_Aggr, Target, Target_Type, Idx, 1); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Signal_Target_Record_Aggr + (St_Aggr, Target, Target_Type); + when others => + Error_Kind ("translate_signal_target_aggr", Target_Type); + end case; + Close_Temp; + end; + else + Src := Chap6.Translate_Name (Target); + Chap3.Translate_Object_Copy (Aggr, M2E (Src), Target_Type); + end if; + end Translate_Signal_Target_Aggr; + + type Signal_Direct_Assign_Data is record + -- The driver + Drv : Mnode; + + -- The value + Expr : Mnode; + + -- The node for the expression (used to locate errors). + Expr_Node : Iir; + end record; + + procedure Gen_Signal_Direct_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Direct_Assign_Data) + is + Targ_Sig : Mnode; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + Cond : O_Dnode; + Drv : Mnode; + begin + Open_Temp; + Targ_Sig := Stabilize (Targ, True); + Cond := Create_Temp (Ghdl_Bool_Type); + Drv := Stabilize (Data.Drv, False); + + -- Set driver. + Chap7.Translate_Assign + (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node); + + -- Test if the signal is active. + Start_If_Stmt + (If_Blk, + New_Value (Chap14.Get_Signal_Field + (Targ_Sig, Ghdl_Signal_Has_Active_Field))); + -- Either because has_active is true. + New_Assign_Stmt (New_Obj (Cond), + New_Lit (Ghdl_Bool_True_Node)); + New_Else_Stmt (If_Blk); + -- Or because the value is different from the current driving value. + -- FIXME: ideally, we should compare the value with the current + -- value of the driver. This is an approximation that might break + -- with weird resolution functions. + New_Assign_Stmt + (New_Obj (Cond), + New_Compare_Op (ON_Neq, + Chap7.Translate_Signal_Driving_Value + (M2E (Targ_Sig), Targ_Type), + M2E (Drv), + Ghdl_Bool_Type)); + Finish_If_Stmt (If_Blk); + + -- Put signal into active list (if not already in the list). + -- FIXME: this is not thread-safe! + Start_If_Stmt (If_Blk, New_Obj_Value (Cond)); + Start_Association (Constr, Ghdl_Signal_Direct_Assign); + New_Association (Constr, + New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + + Close_Temp; + end Gen_Signal_Direct_Assign_Non_Composite; + + function Gen_Signal_Direct_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Signal_Direct_Prepare_Data_Composite; + + function Gen_Signal_Direct_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Signal_Direct_Assign_Data' + (Drv => Stabilize (Val.Drv), + Expr => Stabilize (Val.Expr), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Prepare_Data_Record; + + function Gen_Signal_Direct_Update_Data_Array + (Val : Signal_Direct_Assign_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Signal_Direct_Assign_Data + is + begin + return Signal_Direct_Assign_Data' + (Drv => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Drv), + Targ_Type, New_Obj_Value (Index)), + Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), + Targ_Type, New_Obj_Value (Index)), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Update_Data_Array; + + function Gen_Signal_Direct_Update_Data_Record + (Val : Signal_Direct_Assign_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ_Type); + begin + return Signal_Direct_Assign_Data' + (Drv => Chap6.Translate_Selected_Element (Val.Drv, El), + Expr => Chap6.Translate_Selected_Element (Val.Expr, El), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Update_Data_Record; + + procedure Gen_Signal_Direct_Finish_Data_Composite + (Data : in out Signal_Direct_Assign_Data) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Signal_Direct_Finish_Data_Composite; + + procedure Gen_Signal_Direct_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Direct_Assign_Data, + Composite_Data_Type => Signal_Direct_Assign_Data, + Do_Non_Composite => Gen_Signal_Direct_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Direct_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Direct_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Direct_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Direct_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Direct_Finish_Data_Composite); + + procedure Translate_Direct_Signal_Assignment (Stmt : Iir; We : Iir) + is + Target : constant Iir := Get_Target (Stmt); + Target_Type : constant Iir := Get_Type (Target); + Arg : Signal_Direct_Assign_Data; + Targ_Sig : Mnode; + begin + Chap6.Translate_Direct_Driver (Target, Targ_Sig, Arg.Drv); + + Arg.Expr := E2M (Chap7.Translate_Expression (We, Target_Type), + Get_Info (Target_Type), Mode_Value); + Arg.Expr_Node := We; + Gen_Signal_Direct_Assign (Targ_Sig, Target_Type, Arg); + end Translate_Direct_Signal_Assignment; + + procedure Translate_Signal_Assignment_Statement (Stmt : Iir) + is + Target : Iir; + Target_Type : Iir; + We : Iir_Waveform_Element; + Targ : Mnode; + Val : O_Enode; + Value : Iir; + Is_Simple : Boolean; + begin + Target := Get_Target (Stmt); + Target_Type := Get_Type (Target); + We := Get_Waveform_Chain (Stmt); + + if We /= Null_Iir + and then Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay + and then Get_Reject_Time_Expression (Stmt) = Null_Iir + then + -- Simple signal assignment ? + Value := Get_We_Value (We); + Is_Simple := Get_Kind (Value) /= Iir_Kind_Null_Literal; + else + Is_Simple := False; + end if; + + if Get_Kind (Target) = Iir_Kind_Aggregate then + Chap3.Translate_Anonymous_Type_Definition (Target_Type, True); + Targ := Create_Temp (Get_Info (Target_Type), Mode_Signal); + Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ); + Translate_Signal_Target_Aggr (Targ, Target, Target_Type); + else + if Is_Simple + and then Flag_Direct_Drivers + and then Chap4.Has_Direct_Driver (Target) + then + Translate_Direct_Signal_Assignment (Stmt, Value); + return; + end if; + Targ := Chap6.Translate_Name (Target); + if Get_Object_Kind (Targ) /= Mode_Signal then + raise Internal_Error; + end if; + end if; + + if We = Null_Iir then + -- Implicit disconnect statment. + Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect); + return; + end if; + + -- Handle a simple and common case: only one waveform, inertial, + -- and no time (eg: sig <= expr). + Value := Get_We_Value (We); + Signal_Assign_Line := Get_Line_Number (Value); + if Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay + and then Get_Reject_Time_Expression (Stmt) = Null_Iir + and then Get_Kind (Value) /= Iir_Kind_Null_Literal + then + Val := Chap7.Translate_Expression (Value, Target_Type); + Gen_Simple_Signal_Assign (Targ, Target_Type, Val); + return; + end if; + + -- General case. + declare + Var_Targ : Mnode; + Targ_Tinfo : Type_Info_Acc; + begin + Open_Temp; + Targ_Tinfo := Get_Info (Target_Type); + Var_Targ := Stabilize (Targ, True); + + -- Translate the first waveform element. + declare + Reject_Time : O_Dnode; + After_Time : O_Dnode; + Del : Iir; + Rej : Iir; + Val : Mnode; + Data : Signal_Assign_Data; + begin + Open_Temp; + Reject_Time := Create_Temp (Std_Time_Otype); + After_Time := Create_Temp (Std_Time_Otype); + Del := Get_Time (We); + if Del = Null_Iir then + New_Assign_Stmt + (New_Obj (After_Time), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); + else + New_Assign_Stmt + (New_Obj (After_Time), + Chap7.Translate_Expression (Del, Time_Type_Definition)); + end if; + case Get_Delay_Mechanism (Stmt) is + when Iir_Transport_Delay => + New_Assign_Stmt + (New_Obj (Reject_Time), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); + when Iir_Inertial_Delay => + Rej := Get_Reject_Time_Expression (Stmt); + if Rej = Null_Iir then + New_Assign_Stmt (New_Obj (Reject_Time), + New_Obj_Value (After_Time)); + else + New_Assign_Stmt + (New_Obj (Reject_Time), Chap7.Translate_Expression + (Rej, Time_Type_Definition)); + end if; + end case; + if Get_Kind (Value) = Iir_Kind_Null_Literal then + Val := Mnode_Null; + else + Val := E2M (Chap7.Translate_Expression (Value, Target_Type), + Targ_Tinfo, Mode_Value); + Val := Stabilize (Val); + end if; + Data := Signal_Assign_Data'(Expr => Val, + Reject => Reject_Time, + After => After_Time); + Gen_Start_Signal_Assign (Var_Targ, Target_Type, Data); + Close_Temp; + end; + + -- Translate other waveform elements. + We := Get_Chain (We); + while We /= Null_Iir loop + declare + After_Time : O_Dnode; + Val : Mnode; + Data : Signal_Assign_Data; + begin + Open_Temp; + After_Time := Create_Temp (Std_Time_Otype); + New_Assign_Stmt + (New_Obj (After_Time), + Chap7.Translate_Expression (Get_Time (We), + Time_Type_Definition)); + Value := Get_We_Value (We); + Signal_Assign_Line := Get_Line_Number (Value); + if Get_Kind (Value) = Iir_Kind_Null_Literal then + Val := Mnode_Null; + else + Val := + E2M (Chap7.Translate_Expression (Value, Target_Type), + Targ_Tinfo, Mode_Value); + end if; + Data := Signal_Assign_Data'(Expr => Val, + Reject => O_Dnode_Null, + After => After_Time); + Gen_Next_Signal_Assign (Var_Targ, Target_Type, Data); + Close_Temp; + end; + We := Get_Chain (We); + end loop; + + Close_Temp; + end; + end Translate_Signal_Assignment_Statement; + + procedure Translate_Statement (Stmt : Iir) + is + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + Open_Temp; + case Get_Kind (Stmt) is + when Iir_Kind_Return_Statement => + Translate_Return_Statement (Stmt); + + when Iir_Kind_If_Statement => + Translate_If_Statement (Stmt); + when Iir_Kind_Assertion_Statement => + Translate_Assertion_Statement (Stmt); + when Iir_Kind_Report_Statement => + Translate_Report_Statement (Stmt); + when Iir_Kind_Case_Statement => + Translate_Case_Statement (Stmt); + + when Iir_Kind_For_Loop_Statement => + Translate_For_Loop_Statement (Stmt); + when Iir_Kind_While_Loop_Statement => + Translate_While_Loop_Statement (Stmt); + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + Translate_Exit_Next_Statement (Stmt); + + when Iir_Kind_Signal_Assignment_Statement => + Translate_Signal_Assignment_Statement (Stmt); + when Iir_Kind_Variable_Assignment_Statement => + Translate_Variable_Assignment_Statement (Stmt); + + when Iir_Kind_Null_Statement => + -- A null statement is translated to a NOP, so that the + -- statement generates code (and a breakpoint can be set on + -- it). + -- Emit_Nop; + null; + + when Iir_Kind_Procedure_Call_Statement => + declare + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Implementation (Call); + begin + Canon.Canon_Subprogram_Call (Call); + if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration + then + Translate_Implicit_Procedure_Call (Call); + else + Translate_Procedure_Call (Call); + end if; + end; + + when Iir_Kind_Wait_Statement => + Translate_Wait_Statement (Stmt); + + when others => + Error_Kind ("translate_statement", Stmt); + end case; + Close_Temp; + end Translate_Statement; + + procedure Translate_Statements_Chain (First : Iir) + is + Stmt : Iir; + begin + Stmt := First; + while Stmt /= Null_Iir loop + Translate_Statement (Stmt); + Stmt := Get_Chain (Stmt); + end loop; + end Translate_Statements_Chain; + + function Translate_Statements_Chain_Has_Return (First : Iir) + return Boolean + is + Stmt : Iir; + Has_Return : Boolean := False; + begin + Stmt := First; + while Stmt /= Null_Iir loop + Translate_Statement (Stmt); + if Get_Kind (Stmt) = Iir_Kind_Return_Statement then + Has_Return := True; + end if; + Stmt := Get_Chain (Stmt); + end loop; + return Has_Return; + end Translate_Statements_Chain_Has_Return; + end Chap8; + + package body Chap9 is + procedure Set_Direct_Drivers (Proc : Iir) + is + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Info : Ortho_Info_Acc; + Var : Var_Type; + Sig : Iir; + begin + for I in Drivers.all'Range loop + Var := Drivers (I).Var; + if Var /= Null_Var then + Sig := Get_Object_Prefix (Drivers (I).Sig); + Info := Get_Info (Sig); + case Info.Kind is + when Kind_Object => + Info.Object_Driver := Var; + when Kind_Alias => + null; + when others => + raise Internal_Error; + end case; + end if; + end loop; + end Set_Direct_Drivers; + + procedure Reset_Direct_Drivers (Proc : Iir) + is + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Info : Ortho_Info_Acc; + Var : Var_Type; + Sig : Iir; + begin + for I in Drivers.all'Range loop + Var := Drivers (I).Var; + if Var /= Null_Var then + Sig := Get_Object_Prefix (Drivers (I).Sig); + Info := Get_Info (Sig); + case Info.Kind is + when Kind_Object => + Info.Object_Driver := Null_Var; + when Kind_Alias => + null; + when others => + raise Internal_Error; + end case; + end if; + end loop; + end Reset_Direct_Drivers; + + procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc) + is + Info : constant Proc_Info_Acc := Get_Info (Proc); + Inter_List : O_Inter_List; + Instance : O_Dnode; + begin + Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Process_Subprg); + + Start_Subprogram_Body (Info.Process_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + Chap8.Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Proc)); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Process_Statement; + + procedure Translate_Implicit_Guard_Signal + (Guard : Iir; Base : Block_Info_Acc) + is + Info : Object_Info_Acc; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Guard_Expr : Iir; + begin + Guard_Expr := Get_Guard_Expression (Guard); + -- Create the subprogram to compute the value of GUARD. + Info := Get_Info (Guard); + Start_Function_Decl (Inter_List, Create_Identifier ("_GUARD_PROC"), + O_Storage_Private, Std_Boolean_Type_Node); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Object_Function); + + Start_Subprogram_Body (Info.Object_Function); + Push_Local_Factory; + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + Open_Temp; + New_Return_Stmt (Chap7.Translate_Expression (Guard_Expr)); + Close_Temp; + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Implicit_Guard_Signal; + + procedure Translate_Component_Instantiation_Statement (Inst : Iir) + is + Comp : constant Iir := Get_Instantiated_Unit (Inst); + Info : Block_Info_Acc; + Comp_Info : Comp_Info_Acc; + + Mark2 : Id_Mark_Type; + Assoc, Conv, In_Type : Iir; + Has_Conv_Record : Boolean := False; + begin + Info := Add_Info (Inst, Kind_Block); + + if Is_Component_Instantiation (Inst) then + -- Via a component declaration. + Comp_Info := Get_Info (Get_Named_Entity (Comp)); + Info.Block_Link_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Get_Scope_Type (Comp_Info.Comp_Scope)); + else + -- Direct instantiation. + Info.Block_Link_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Rtis.Ghdl_Component_Link_Type); + end if; + + -- When conversions are used, the subtype of the actual (or of the + -- formal for out conversions) may not be yet translated. This + -- can happen if the name is a slice. + -- We need to translate it and create variables in the instance + -- because it will be referenced by the conversion subprogram. + Assoc := Get_Port_Map_Aspect_Chain (Inst); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression + then + Conv := Get_In_Conversion (Assoc); + In_Type := Get_Type (Get_Actual (Assoc)); + if Conv /= Null_Iir + and then Is_Anonymous_Type_Definition (In_Type) + then + -- Lazy creation of the record. + if not Has_Conv_Record then + Has_Conv_Record := True; + Push_Instance_Factory (Info.Block_Scope'Access); + end if; + + -- FIXME: handle with overload multiple case on the same + -- formal. + Push_Identifier_Prefix + (Mark2, + Get_Identifier (Get_Association_Interface (Assoc))); + Chap3.Translate_Type_Definition (In_Type, True); + Pop_Identifier_Prefix (Mark2); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + if Has_Conv_Record then + Pop_Instance_Factory (Info.Block_Scope'Access); + New_Type_Decl + (Create_Identifier (Get_Identifier (Inst), "__CONVS"), + Get_Scope_Type (Info.Block_Scope)); + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Get_Identifier (Inst), + "__CONVS"), + Get_Scope_Type (Info.Block_Scope)); + end if; + end Translate_Component_Instantiation_Statement; + + procedure Translate_Process_Declarations (Proc : Iir) + is + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + + Drivers : Iir_List; + Nbr_Drivers : Natural; + Sig : Iir; + begin + Info := Add_Info (Proc, Kind_Process); + + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Proc)); + Push_Instance_Factory (Info.Process_Scope'Access); + Chap4.Translate_Declaration_Chain (Proc); + + if Flag_Direct_Drivers then + -- Create direct drivers. + Drivers := Trans_Analyzes.Extract_Drivers (Proc); + if Flag_Dump_Drivers then + Trans_Analyzes.Dump_Drivers (Proc, Drivers); + end if; + + Nbr_Drivers := Get_Nbr_Elements (Drivers); + Info.Process_Drivers := new Direct_Driver_Arr (1 .. Nbr_Drivers); + for I in 1 .. Nbr_Drivers loop + Sig := Get_Nth_Element (Drivers, I - 1); + Info.Process_Drivers (I) := (Sig => Sig, Var => Null_Var); + Sig := Get_Object_Prefix (Sig); + if Get_Kind (Sig) /= Iir_Kind_Object_Alias_Declaration + and then not Get_After_Drivers_Flag (Sig) + then + Info.Process_Drivers (I).Var := + Create_Var (Create_Var_Identifier (Sig, "_DDRV", I), + Chap4.Get_Object_Type + (Get_Info (Get_Type (Sig)), Mode_Value)); + + -- Do not create driver severals times. + Set_After_Drivers_Flag (Sig, True); + end if; + end loop; + Trans_Analyzes.Free_Drivers_List (Drivers); + end if; + Pop_Instance_Factory (Info.Process_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Process_Scope)); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field (Create_Identifier_Without_Prefix (Proc), + Info.Process_Scope); + end Translate_Process_Declarations; + + procedure Translate_Psl_Directive_Declarations (Stmt : Iir) + is + use PSL.Nodes; + use PSL.NFAs; + + N : constant NFA := Get_PSL_NFA (Stmt); + + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Stmt, Kind_Psl_Directive); + + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Push_Instance_Factory (Info.Psl_Scope'Access); + + Labelize_States (N, Info.Psl_Vect_Len); + Info.Psl_Vect_Type := New_Constrained_Array_Type + (Std_Boolean_Array_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))); + New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type); + Info.Psl_Vect_Var := Create_Var + (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type); + + if Get_Kind (Stmt) = Iir_Kind_Psl_Cover_Statement then + Info.Psl_Bool_Var := Create_Var + (Create_Var_Identifier ("BOOL"), Ghdl_Bool_Type); + end if; + + Pop_Instance_Factory (Info.Psl_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Psl_Scope)); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field + (Create_Identifier_Without_Prefix (Stmt), Info.Psl_Scope); + end Translate_Psl_Directive_Declarations; + + function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean) + return O_Enode + is + use PSL.Nodes; + begin + case Get_Kind (Expr) is + when N_HDL_Expr => + declare + E : Iir; + Rtype : Iir; + Res : O_Enode; + begin + E := Get_HDL_Node (Expr); + Rtype := Get_Base_Type (Get_Type (E)); + Res := Chap7.Translate_Expression (E); + if Rtype = Boolean_Type_Definition then + return Res; + elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then + return New_Value + (New_Indexed_Element + (New_Obj (Ghdl_Std_Ulogic_To_Boolean_Array), + New_Convert_Ov (Res, Ghdl_Index_Type))); + else + Error_Kind ("translate_psl_expr/hdl_expr", Expr); + end if; + end; + when N_True => + return New_Lit (Std_Boolean_True_Node); + when N_EOS => + if Eos then + return New_Lit (Std_Boolean_True_Node); + else + return New_Lit (Std_Boolean_False_Node); + end if; + when N_Not_Bool => + return New_Monadic_Op + (ON_Not, + Translate_Psl_Expr (Get_Boolean (Expr), Eos)); + when N_And_Bool => + return New_Dyadic_Op + (ON_And, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when N_Or_Bool => + return New_Dyadic_Op + (ON_Or, + Translate_Psl_Expr (Get_Left (Expr), Eos), + Translate_Psl_Expr (Get_Right (Expr), Eos)); + when others => + Error_Kind ("translate_psl_expr", Expr); + end case; + end Translate_Psl_Expr; + + -- Return TRUE iff NFA has an edge with an EOS. + -- If so, we need to create a finalizer. + function Psl_Need_Finalizer (Nfa : PSL_NFA) return Boolean + is + use PSL.NFAs; + S : NFA_State; + E : NFA_Edge; + begin + S := Get_Final_State (Nfa); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + return True; + end if; + E := Get_Next_Dest_Edge (E); + end loop; + return False; + end Psl_Need_Finalizer; + + procedure Create_Psl_Final_Proc + (Stmt : Iir; Base : Block_Info_Acc; Instance : out O_Dnode) + is + Inter_List : O_Inter_List; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + begin + Start_Procedure_Decl (Inter_List, Create_Identifier ("FINALPROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Final_Subprg); + end Create_Psl_Final_Proc; + + procedure Translate_Psl_Directive_Statement + (Stmt : Iir; Base : Block_Info_Acc) + is + use PSL.NFAs; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Var_I : O_Dnode; + Var_Nvec : O_Dnode; + Label : O_Snode; + Clk_Blk : O_If_Block; + S_Blk : O_If_Block; + E_Blk : O_If_Block; + S : NFA_State; + S_Num : Int32; + E : NFA_Edge; + Sd : NFA_State; + Cond : O_Enode; + NFA : PSL_NFA; + D_Lit : O_Cnode; + begin + Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Subprg); + + Start_Subprogram_Body (Info.Psl_Proc_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + -- New state vector. + New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type); + + -- For cover directive, return now if already covered. + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + null; + when Iir_Kind_Psl_Cover_Statement => + Start_If_Stmt (S_Blk, New_Value (Get_Var (Info.Psl_Bool_Var))); + New_Return_Stmt; + Finish_If_Stmt (S_Blk); + when others => + Error_Kind ("Translate_Psl_Directive_Statement(1)", Stmt); + end case; + + -- Initialize the new state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + -- Global if statement for the clock. + Open_Temp; + Start_If_Stmt (Clk_Blk, + Translate_Psl_Expr (Get_PSL_Clock (Stmt), False)); + + -- For each state: if set, evaluate all outgoing edges. + NFA := Get_PSL_NFA (Stmt); + S := Get_First_State (NFA); + while S /= No_State loop + S_Num := Get_State_Label (S); + Open_Temp; + + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Dest (E); + Open_Temp; + + D_Lit := New_Index_Lit (Unsigned_64 (Get_State_Label (Sd))); + Cond := New_Monadic_Op + (ON_Not, + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (D_Lit)))); + Cond := New_Dyadic_Op + (ON_And, Cond, Translate_Psl_Expr (Get_Edge_Expr (E), False)); + Start_If_Stmt (E_Blk, Cond); + New_Assign_Stmt + (New_Indexed_Element (New_Obj (Var_Nvec), New_Lit (D_Lit)), + New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (E_Blk); + + Close_Temp; + E := Get_Next_Src_Edge (E); + end loop; + + Finish_If_Stmt (S_Blk); + Close_Temp; + S := Get_Next_State (S); + end loop; + + -- Check fail state. + S := Get_Final_State (NFA); + S_Num := Get_State_Label (S); + pragma Assert (Integer (S_Num) = Info.Psl_Vect_Len - 1); + Start_If_Stmt + (S_Blk, + New_Value + (New_Indexed_Element (New_Obj (Var_Nvec), + New_Lit (New_Index_Lit + (Unsigned_64 (S_Num)))))); + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + when Iir_Kind_Psl_Cover_Statement => + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Cover, Severity_Level_Note); + New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), + New_Lit (Ghdl_Bool_True_Node)); + when others => + Error_Kind ("Translate_Psl_Directive_Statement", Stmt); + end case; + Finish_If_Stmt (S_Blk); + + -- Assign state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Value (New_Indexed_Element (New_Obj (Var_Nvec), + New_Obj_Value (Var_I)))); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + Close_Temp; + Finish_If_Stmt (Clk_Blk); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- The finalizer. + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + if Psl_Need_Finalizer (NFA) then + Create_Psl_Final_Proc (Stmt, Base, Instance); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + S := Get_Final_State (NFA); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + Sd := Get_Edge_Src (E); + + if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then + + S_Num := Get_State_Label (Sd); + Open_Temp; + + Cond := New_Value + (New_Indexed_Element + (Get_Var (Info.Psl_Vect_Var), + New_Lit (New_Index_Lit (Unsigned_64 (S_Num))))); + Cond := New_Dyadic_Op + (ON_And, Cond, + Translate_Psl_Expr (Get_Edge_Expr (E), True)); + Start_If_Stmt (E_Blk, Cond); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + New_Return_Stmt; + Finish_If_Stmt (E_Blk); + + Close_Temp; + end if; + + E := Get_Next_Dest_Edge (E); + end loop; + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + else + Info.Psl_Proc_Final_Subprg := O_Dnode_Null; + end if; + + when Iir_Kind_Psl_Cover_Statement => + Create_Psl_Final_Proc (Stmt, Base, Instance); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + Start_If_Stmt + (S_Blk, + New_Monadic_Op (ON_Not, + New_Value (Get_Var (Info.Psl_Bool_Var)))); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Cover_Failed, Severity_Level_Error); + Finish_If_Stmt (S_Blk); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + + when others => + Error_Kind ("Translate_Psl_Directive_Statement(3)", Stmt); + end case; + end Translate_Psl_Directive_Statement; + + -- Create the instance for block BLOCK. + -- BLOCK can be either an entity, an architecture or a block statement. + procedure Translate_Block_Declarations (Block : Iir; Origin : Iir) + is + El : Iir; + begin + Chap4.Translate_Declaration_Chain (Block); + + El := Get_Concurrent_Statement_Chain (Block); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Translate_Process_Declarations (El); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Translate_Psl_Directive_Declarations (El); + when Iir_Kind_Component_Instantiation_Statement => + Translate_Component_Instantiation_Statement (El); + when Iir_Kind_Block_Statement => + declare + Info : Block_Info_Acc; + Hdr : Iir_Block_Header; + Guard : Iir; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + Info := Add_Info (El, Kind_Block); + Chap1.Start_Block_Decl (El); + Push_Instance_Factory (Info.Block_Scope'Access); + + Guard := Get_Guard_Decl (El); + if Guard /= Null_Iir then + Chap4.Translate_Declaration (Guard); + end if; + + -- generics, ports. + Hdr := Get_Block_Header (El); + if Hdr /= Null_Iir then + Chap4.Translate_Generic_Chain (Hdr); + Chap4.Translate_Port_Chain (Hdr); + end if; + + Chap9.Translate_Block_Declarations (El, Origin); + + Pop_Instance_Factory (Info.Block_Scope'Access); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Scope); + end; + when Iir_Kind_Generate_Statement => + declare + Scheme : constant Iir := Get_Generation_Scheme (El); + Info : Block_Info_Acc; + Mark : Id_Mark_Type; + Iter_Type : Iir; + It_Info : Ortho_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Chap3.Translate_Object_Subtype (Scheme, True); + end if; + + Info := Add_Info (El, Kind_Block); + Chap1.Start_Block_Decl (El); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Add a parent field in the current instance. + Info.Block_Origin_Field := Add_Instance_Factory_Field + (Get_Identifier ("ORIGIN"), + Get_Info (Origin).Block_Decls_Ptr_Type); + + -- Iterator. + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Info.Block_Configured_Field := + Add_Instance_Factory_Field + (Get_Identifier ("CONFIGURED"), Ghdl_Bool_Type); + It_Info := Add_Info (Scheme, Kind_Iterator); + It_Info.Iterator_Var := Create_Var + (Create_Var_Identifier (Scheme), + Get_Info (Get_Base_Type (Iter_Type)).Ortho_Type + (Mode_Value)); + end if; + + Chap9.Translate_Block_Declarations (El, El); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + -- Create array type of block_decls_type + Info.Block_Decls_Array_Type := New_Array_Type + (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("INSTARRTYPE"), + Info.Block_Decls_Array_Type); + -- Create access to the array type. + Info.Block_Decls_Array_Ptr_Type := New_Access_Type + (Info.Block_Decls_Array_Type); + New_Type_Decl (Create_Identifier ("INSTARRPTR"), + Info.Block_Decls_Array_Ptr_Type); + -- Add a field in parent record + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Decls_Array_Ptr_Type); + else + -- Create an access field in the parent record. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Decls_Ptr_Type); + end if; + + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("translate_block_declarations", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Declarations; + + procedure Translate_Component_Instantiation_Subprogram + (Stmt : Iir; Base : Block_Info_Acc) + is + procedure Set_Component_Link (Ref_Scope : Var_Scope_Type; + Comp_Field : O_Fnode) + is + begin + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Comp_Field), + Rtis.Ghdl_Component_Link_Stmt), + New_Lit (Rtis.Get_Context_Rti (Stmt))); + end Set_Component_Link; + + Info : constant Block_Info_Acc := Get_Info (Stmt); + + Parent : constant Iir := Get_Parent (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); + + Comp : Iir; + Comp_Info : Comp_Info_Acc; + Inter_List : O_Inter_List; + Instance : O_Dnode; + begin + -- Create the elaborator for the instantiation. + Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Block_Elab_Subprg); + + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + -- Add access to the instantiation-specific data. + -- This is used only for anonymous subtype variables. + if Has_Scope_Type (Info.Block_Scope) then + Set_Scope_Via_Field (Info.Block_Scope, + Info.Block_Parent_Field, + Parent_Info.Block_Scope'Access); + end if; + + Comp := Get_Instantiated_Unit (Stmt); + if Is_Entity_Instantiation (Stmt) then + -- This is a direct instantiation. + Set_Component_Link (Parent_Info.Block_Scope, + Info.Block_Link_Field); + Translate_Entity_Instantiation (Comp, Stmt, Stmt, Null_Iir); + else + Comp := Get_Named_Entity (Comp); + Comp_Info := Get_Info (Comp); + Set_Scope_Via_Field (Comp_Info.Comp_Scope, + Info.Block_Link_Field, + Parent_Info.Block_Scope'Access); + + -- Set the link from component declaration to component + -- instantiation statement. + Set_Component_Link (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); + + Chap5.Elab_Map_Aspect (Stmt, Comp); + + Clear_Scope (Comp_Info.Comp_Scope); + end if; + + if Has_Scope_Type (Info.Block_Scope) then + Clear_Scope (Info.Block_Scope); + end if; + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Component_Instantiation_Subprogram; + + -- Translate concurrent statements into subprograms. + procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir) + is + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt : Iir; + Mark : Id_Mark_Type; + begin + Chap4.Translate_Declaration_Chain_Subprograms (Block); + + Stmt := Get_Concurrent_Statement_Chain (Block); + while Stmt /= Null_Iir loop + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + if Flag_Direct_Drivers then + Chap9.Set_Direct_Drivers (Stmt); + end if; + + Chap4.Translate_Declaration_Chain_Subprograms (Stmt); + Translate_Process_Statement (Stmt, Base_Info); + + if Flag_Direct_Drivers then + Chap9.Reset_Direct_Drivers (Stmt); + end if; + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Translate_Psl_Directive_Statement (Stmt, Base_Info); + when Iir_Kind_Component_Instantiation_Statement => + Chap4.Translate_Association_Subprograms + (Stmt, Block, Base_Block, + Get_Entity_From_Entity_Aspect + (Get_Instantiated_Unit (Stmt))); + Translate_Component_Instantiation_Subprogram + (Stmt, Base_Info); + when Iir_Kind_Block_Statement => + declare + Guard : constant Iir := Get_Guard_Decl (Stmt); + Hdr : constant Iir := Get_Block_Header (Stmt); + begin + if Guard /= Null_Iir then + Translate_Implicit_Guard_Signal (Guard, Base_Info); + end if; + if Hdr /= Null_Iir then + Chap4.Translate_Association_Subprograms + (Hdr, Block, Base_Block, Null_Iir); + end if; + Translate_Block_Subprograms (Stmt, Base_Block); + end; + when Iir_Kind_Generate_Statement => + declare + Info : constant Block_Info_Acc := Get_Info (Stmt); + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + Info.Block_Origin_Field, + Info.Block_Scope'Access); + Translate_Block_Subprograms (Stmt, Stmt); + Clear_Scope (Base_Info.Block_Scope); + Chap2.Pop_Subprg_Instance + (Wki_Instance, Prev_Subprg_Instance); + end; + when others => + Error_Kind ("translate_block_subprograms", Stmt); + end case; + Pop_Identifier_Prefix (Mark); + Stmt := Get_Chain (Stmt); + end loop; + end Translate_Block_Subprograms; + + -- Remove anonymous and implicit type definitions in a list of names. + -- Such type definitions are created during slice translations, however + -- variables created are defined in the translation scope. + -- If the type is referenced again, the variables must be reachable. + -- This is not the case for elaborator subprogram (which may references + -- slices in the sensitivity or driver list) and the process subprg. + procedure Destroy_Types_In_Name (Name : Iir) + is + El : Iir; + Atype : Iir; + Info : Type_Info_Acc; + begin + El := Name; + loop + Atype := Null_Iir; + case Get_Kind (El) is + when Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name => + El := Get_Prefix (El); + when Iir_Kind_Slice_Name => + Atype := Get_Type (El); + El := Get_Prefix (El); + when Iir_Kind_Object_Alias_Declaration => + El := Get_Name (El); + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + El := Get_Prefix (El); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + exit; + when Iir_Kinds_Denoting_Name => + El := Get_Named_Entity (El); + when others => + Error_Kind ("destroy_types_in_name", El); + end case; + if Atype /= Null_Iir + and then Is_Anonymous_Type_Definition (Atype) + then + Info := Get_Info (Atype); + if Info /= null then + Free_Type_Info (Info); + Clear_Info (Atype); + end if; + end if; + end loop; + end Destroy_Types_In_Name; + + procedure Destroy_Types_In_List (List : Iir_List) + is + El : Iir; + begin + if List = Null_Iir_List then + return; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Destroy_Types_In_Name (El); + end loop; + end Destroy_Types_In_List; + + procedure Gen_Register_Direct_Driver_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Drv : Mnode) + is + pragma Unreferenced (Targ_Type); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); + New_Association + (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Association + (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); + New_Procedure_Call (Constr); + end Gen_Register_Direct_Driver_Non_Composite; + + function Gen_Register_Direct_Driver_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Register_Direct_Driver_Prepare_Data_Composite; + + function Gen_Register_Direct_Driver_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Stabilize (Val); + end Gen_Register_Direct_Driver_Prepare_Data_Record; + + function Gen_Register_Direct_Driver_Update_Data_Array + (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) + return Mnode + is + begin + return Chap3.Index_Base (Chap3.Get_Array_Base (Val), + Targ_Type, New_Obj_Value (Index)); + end Gen_Register_Direct_Driver_Update_Data_Array; + + function Gen_Register_Direct_Driver_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return Mnode + is + pragma Unreferenced (Targ_Type); + begin + return Chap6.Translate_Selected_Element (Val, El); + end Gen_Register_Direct_Driver_Update_Data_Record; + + procedure Gen_Register_Direct_Driver_Finish_Data_Composite + (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Register_Direct_Driver_Finish_Data_Composite; + + procedure Gen_Register_Direct_Driver is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Gen_Register_Direct_Driver_Non_Composite, + Prepare_Data_Array => + Gen_Register_Direct_Driver_Prepare_Data_Composite, + Update_Data_Array => Gen_Register_Direct_Driver_Update_Data_Array, + Finish_Data_Array => Gen_Register_Direct_Driver_Finish_Data_Composite, + Prepare_Data_Record => Gen_Register_Direct_Driver_Prepare_Data_Record, + Update_Data_Record => Gen_Register_Direct_Driver_Update_Data_Record, + Finish_Data_Record => + Gen_Register_Direct_Driver_Finish_Data_Composite); + +-- procedure Register_Scalar_Direct_Driver (Sig : Mnode; +-- Sig_Type : Iir; +-- Drv : Mnode) +-- is +-- pragma Unreferenced (Sig_Type); +-- Constr : O_Assoc_List; +-- begin +-- Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); +-- New_Association +-- (Constr, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); +-- New_Association +-- (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); +-- New_Procedure_Call (Constr); +-- end Register_Scalar_Direct_Driver; + + -- PROC: the process to be elaborated + -- BASE_INFO: info for the global block + procedure Elab_Process (Proc : Iir; Base_Info : Block_Info_Acc) + is + Info : constant Proc_Info_Acc := Get_Info (Proc); + Is_Sensitized : constant Boolean := + Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement; + Subprg : O_Dnode; + Constr : O_Assoc_List; + List : Iir_List; + List_Orig : Iir_List; + Final : Boolean; + begin + New_Debug_Line_Stmt (Get_Line_Number (Proc)); + + -- Register process. + if Is_Sensitized then + if Get_Postponed_Flag (Proc) then + Subprg := Ghdl_Postponed_Sensitized_Process_Register; + else + Subprg := Ghdl_Sensitized_Process_Register; + end if; + else + if Get_Postponed_Flag (Proc) then + Subprg := Ghdl_Postponed_Process_Register; + else + Subprg := Ghdl_Process_Register; + end if; + end if; + + Start_Association (Constr, Subprg); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Process_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Proc); + New_Procedure_Call (Constr); + + -- First elaborate declarations since a driver may depend on + -- an alias declaration. + -- Also, with vhdl 08 a sensitivity element may depend on an alias. + Open_Temp; + Chap4.Elab_Declaration_Chain (Proc, Final); + Close_Temp; + + -- Register drivers. + if Flag_Direct_Drivers then + Chap9.Set_Direct_Drivers (Proc); + + declare + Sig : Iir; + Base : Iir; + Sig_Node, Drv_Node : Mnode; + begin + for I in Info.Process_Drivers.all'Range loop + Sig := Info.Process_Drivers (I).Sig; + Open_Temp; + Base := Get_Object_Prefix (Sig); + if Info.Process_Drivers (I).Var /= Null_Var then + -- Elaborate direct driver. Done only once. + Chap4.Elab_Direct_Driver_Declaration_Storage (Base); + end if; + if Chap4.Has_Direct_Driver (Base) then + -- Signal has a direct driver. + Chap6.Translate_Direct_Driver (Sig, Sig_Node, Drv_Node); + Gen_Register_Direct_Driver + (Sig_Node, Get_Type (Sig), Drv_Node); + else + Register_Signal (Chap6.Translate_Name (Sig), + Get_Type (Sig), + Ghdl_Process_Add_Driver); + end if; + Close_Temp; + end loop; + end; + + Chap9.Reset_Direct_Drivers (Proc); + else + List := Trans_Analyzes.Extract_Drivers (Proc); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Driver); + if Flag_Dump_Drivers then + Trans_Analyzes.Dump_Drivers (Proc, List); + end if; + Trans_Analyzes.Free_Drivers_List (List); + end if; + + if Is_Sensitized then + List_Orig := Get_Sensitivity_List (Proc); + if List_Orig = Iir_List_All then + List := Canon.Canon_Extract_Process_Sensitivity (Proc); + else + List := List_Orig; + end if; + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + if List_Orig = Iir_List_All then + Destroy_Iir_List (List); + end if; + end if; + end Elab_Process; + + -- PROC: the process to be elaborated + -- BLOCK: the block containing the process (its parent) + -- BASE_INFO: info for the global block + procedure Elab_Psl_Directive (Stmt : Iir; + Base_Info : Block_Info_Acc) + is + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Constr : O_Assoc_List; + List : Iir_List; + Clk : PSL_Node; + Var_I : O_Dnode; + Label : O_Snode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + -- Register process. + Start_Association (Constr, Ghdl_Sensitized_Process_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Stmt); + New_Procedure_Call (Constr); + + -- Register clock sensitivity. + Clk := Get_PSL_Clock (Stmt); + List := Create_Iir_List; + Canon_PSL.Canon_Extract_Sensitivity (Clk, List); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + Destroy_Iir_List (List); + + -- Register finalizer (if any). + if Info.Psl_Proc_Final_Subprg /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Finalize_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), + Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Psl_Proc_Final_Subprg, + Ghdl_Ptr_Type))); + New_Procedure_Call (Constr); + end if; + + -- Initialize state vector. + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Lit (Ghdl_Index_0)), + New_Lit (Std_Boolean_True_Node)); + New_Assign_Stmt (New_Obj (Var_I), New_Lit (Ghdl_Index_1)); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, + Unsigned_64 (Info.Psl_Vect_Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), + New_Obj_Value (Var_I)), + New_Lit (Std_Boolean_False_Node)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + + if Info.Psl_Bool_Var /= Null_Var then + New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), + New_Lit (Ghdl_Bool_False_Node)); + end if; + end Elab_Psl_Directive; + + procedure Elab_Implicit_Guard_Signal + (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc) + is + Guard : Iir; + Type_Info : Type_Info_Acc; + Info : Object_Info_Acc; + Constr : O_Assoc_List; + begin + -- Create the guard signal. + Guard := Get_Guard_Decl (Block); + Info := Get_Info (Guard); + Type_Info := Get_Info (Get_Type (Guard)); + Start_Association (Constr, Ghdl_Signal_Create_Guard); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Block_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Object_Function, + Ghdl_Ptr_Type))); +-- New_Association (Constr, Chap6.Get_Instance_Name_Ref (Block)); + New_Assign_Stmt (Get_Var (Info.Object_Var), + New_Convert_Ov (New_Function_Call (Constr), + Type_Info.Ortho_Type (Mode_Signal))); + + -- Register sensitivity list of the guard signal. + Register_Signal_List (Get_Guard_Sensitivity_List (Guard), + Ghdl_Signal_Guard_Dependence); + end Elab_Implicit_Guard_Signal; + + procedure Translate_Entity_Instantiation + (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir) + is + Entity_Unit : Iir_Design_Unit; + Config : Iir; + Arch : Iir; + Entity : Iir_Entity_Declaration; + Entity_Info : Block_Info_Acc; + Arch_Info : Block_Info_Acc; + + Instance_Size : O_Dnode; + Arch_Elab : O_Dnode; + Arch_Config : O_Dnode; + Arch_Config_Type : O_Tnode; + + Var_Sub : O_Dnode; + begin + -- Extract entity, architecture and configuration from + -- binding aspect. + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Aspect); + Arch := Get_Architecture (Aspect); + if Flags.Flag_Elaborate and then Arch = Null_Iir then + -- This is valid only during elaboration. + Arch := Libraries.Get_Latest_Architecture (Entity); + end if; + Config := Null_Iir; + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Configuration (Aspect); + Entity := Get_Entity (Config); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + when others => + Error_Kind ("translate_entity_instantiation", Aspect); + end case; + Entity_Unit := Get_Design_Unit (Entity); + Entity_Info := Get_Info (Entity); + if Config_Override /= Null_Iir then + Config := Config_Override; + if Get_Kind (Arch) = Iir_Kind_Simple_Name then + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + end if; + end if; + + -- 1) Create instance for the arch + if Arch /= Null_Iir then + Arch_Info := Get_Info (Arch); + if Config = Null_Iir + and then Get_Kind (Arch) = Iir_Kind_Architecture_Body + then + Config := Get_Default_Configuration_Declaration (Arch); + if Config /= Null_Iir then + Config := Get_Library_Unit (Config); + end if; + end if; + else + Arch_Info := null; + end if; + if Arch_Info = null or Config = Null_Iir then + declare + function Get_Arch_Name return String is + begin + if Arch /= Null_Iir then + return "ARCH__" & Image_Identifier (Arch); + else + return "LASTARCH"; + end if; + end Get_Arch_Name; + + Str : constant String := + Image_Identifier (Get_Library (Get_Design_File (Entity_Unit))) + & "__" & Image_Identifier (Entity) & "__" + & Get_Arch_Name & "__"; + Sub_Inter : O_Inter_List; + Arg : O_Dnode; + begin + if Arch_Info = null then + New_Const_Decl + (Instance_Size, Get_Identifier (Str & "INSTSIZE"), + O_Storage_External, Ghdl_Index_Type); + + Start_Procedure_Decl + (Sub_Inter, Get_Identifier (Str & "ELAB"), + O_Storage_External); + New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Sub_Inter, Arch_Elab); + end if; + + if Config = Null_Iir then + Start_Procedure_Decl + (Sub_Inter, Get_Identifier (Str & "DEFAULT_CONFIG"), + O_Storage_External); + New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Sub_Inter, Arch_Config); + + Arch_Config_Type := Entity_Info.Block_Decls_Ptr_Type; + end if; + end; + end if; + + if Arch_Info = null then + if Config /= Null_Iir then + -- Architecture is unknown, but we know how to configure + -- the block inside it. + raise Internal_Error; + end if; + else + Instance_Size := Arch_Info.Block_Instance_Size; + Arch_Elab := Arch_Info.Block_Elab_Subprg; + if Config /= Null_Iir then + Arch_Config := Get_Info (Config).Config_Subprg; + Arch_Config_Type := Arch_Info.Block_Decls_Ptr_Type; + end if; + end if; + + -- Create the instance variable and allocate storage. + New_Var_Decl (Var_Sub, Get_Identifier ("SUB_INSTANCE"), + O_Storage_Local, Entity_Info.Block_Decls_Ptr_Type); + + New_Assign_Stmt + (New_Obj (Var_Sub), + Gen_Alloc (Alloc_System, New_Obj_Value (Instance_Size), + Entity_Info.Block_Decls_Ptr_Type)); + + -- 1.5) link instance. + declare + procedure Set_Links (Ref_Scope : Var_Scope_Type; + Link_Field : O_Fnode) + is + begin + -- Set the ghdl_component_link_instance field. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Instance), + New_Address (New_Selected_Acc_Value + (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Acc)); + -- Set the ghdl_entity_link_parent field. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Parent), + New_Address + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Acc)); + end Set_Links; + begin + case Get_Kind (Parent) is + when Iir_Kind_Component_Declaration => + -- Instantiation via a component declaration. + declare + Comp_Info : constant Comp_Info_Acc := Get_Info (Parent); + begin + Set_Links (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); + end; + when Iir_Kind_Component_Instantiation_Statement => + -- Direct instantiation. + declare + Parent_Info : constant Block_Info_Acc := + Get_Info (Get_Parent (Parent)); + begin + Set_Links (Parent_Info.Block_Scope, + Get_Info (Parent).Block_Link_Field); + end; + when others => + Error_Kind ("translate_entity_instantiation(1)", Parent); + end case; + end; + + -- Elab entity packages. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); + New_Procedure_Call (Assoc); + end; + + -- Elab map aspects. + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Var_Sub); + Chap5.Elab_Map_Aspect (Mapping, Entity); + Clear_Scope (Entity_Info.Block_Scope); + + -- 3) Elab instance. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Arch_Elab); + New_Association (Assoc, New_Obj_Value (Var_Sub)); + New_Procedure_Call (Assoc); + end; + + -- 5) Configure + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Arch_Config); + New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Var_Sub), + Arch_Config_Type)); + New_Procedure_Call (Assoc); + end; + end Translate_Entity_Instantiation; + + procedure Elab_Conditionnal_Generate_Statement + (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); + Var : O_Dnode; + Blk : O_If_Block; + V : O_Lnode; + begin + Open_Temp; + + Var := Create_Temp (Info.Block_Decls_Ptr_Type); + Start_If_Stmt (Blk, Chap7.Translate_Expression (Scheme)); + New_Assign_Stmt + (New_Obj (Var), + Gen_Alloc (Alloc_System, + New_Lit (Get_Scope_Size (Info.Block_Scope)), + Info.Block_Decls_Ptr_Type)); + New_Else_Stmt (Blk); + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type))); + Finish_If_Stmt (Blk); + + -- Add a link to child in parent. + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Parent_Field); + New_Assign_Stmt (V, New_Obj_Value (Var)); + + Start_If_Stmt + (Blk, + New_Compare_Op + (ON_Neq, + New_Obj_Value (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), + Ghdl_Bool_Type)); + -- Add a link to parent in child. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), + Get_Instance_Access (Base_Block)); + -- Elaborate block + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Elab_Block_Declarations (Stmt, Stmt); + Clear_Scope (Info.Block_Scope); + Finish_If_Stmt (Blk); + Close_Temp; + end Elab_Conditionnal_Generate_Statement; + + procedure Elab_Iterative_Generate_Statement + (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Iter_Type : constant Iir := Get_Type (Scheme); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); +-- Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Var_Inst : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + V : O_Lnode; + Var : O_Dnode; + Range_Ptr : O_Dnode; + begin + Open_Temp; + + -- Evaluate iterator range. + Chap3.Elab_Object_Subtype (Iter_Type); + + Range_Ptr := Create_Temp_Ptr + (Iter_Type_Info.T.Range_Ptr_Type, + Get_Var (Get_Info (Iter_Type).T.Range_Var)); + + -- Allocate instances. + Var_Inst := Create_Temp (Info.Block_Decls_Array_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Inst), + Gen_Alloc + (Alloc_System, + New_Dyadic_Op (ON_Mul_Ov, + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Length), + New_Lit (Get_Scope_Size (Info.Block_Scope))), + Info.Block_Decls_Array_Ptr_Type)); + + -- Add a link to child in parent. + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Parent_Field); + New_Assign_Stmt (V, New_Obj_Value (Var_Inst)); + + -- Start loop. + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Length), + Ghdl_Bool_Type)); + + Var := Create_Temp_Ptr + (Info.Block_Decls_Ptr_Type, + New_Indexed_Element (New_Acc_Value (New_Obj (Var_Inst)), + New_Obj_Value (Var_I))); + -- Add a link to parent in child. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), + Get_Instance_Access (Base_Block)); + -- Mark the block as not (yet) configured. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_False_Node)); + + -- Elaborate block + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + -- Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + -- Info.Block_Origin_Field, + -- Info.Block_Scope'Access); + + -- Set iterator value. + -- FIXME: this could be slighly optimized... + declare + Val : O_Dnode; + If_Blk : O_If_Block; + begin + Val := Create_Temp (Iter_Type_Info.Ortho_Type (Mode_Value)); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Left)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Right)); + Finish_If_Stmt (If_Blk); + + New_Assign_Stmt + (Get_Var (Get_Info (Scheme).Iterator_Var), + New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Val), + New_Convert_Ov (New_Obj_Value (Var_I), + Iter_Type_Info.Ortho_Type (Mode_Value)))); + end; + + -- Elaboration. + Elab_Block_Declarations (Stmt, Stmt); + +-- Clear_Scope (Base_Info.Block_Scope); + Clear_Scope (Info.Block_Scope); + + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + end Elab_Iterative_Generate_Statement; + + type Merge_Signals_Data is record + Sig : Iir; + Set_Init : Boolean; + Has_Val : Boolean; + Val : Mnode; + end record; + + procedure Merge_Signals_Rti_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Merge_Signals_Data) + is + Type_Info : Type_Info_Acc; + Sig : Mnode; + + Init_Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + Init_Val : O_Enode; + begin + Type_Info := Get_Info (Targ_Type); + + Open_Temp; + + if Data.Set_Init then + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Init_Subprg := Ghdl_Signal_Init_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Init_Subprg := Ghdl_Signal_Init_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Init_Subprg := Ghdl_Signal_Init_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Init_Subprg := Ghdl_Signal_Init_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Init_Subprg := Ghdl_Signal_Init_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Init_Subprg := Ghdl_Signal_Init_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("merge_signals_rti_non_composite", Targ_Type); + end case; + + Sig := Stabilize (Targ, True); + + -- Init the signal. + Start_Association (Assoc, Init_Subprg); + New_Association + (Assoc, + New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); + if Data.Has_Val then + Init_Val := M2E (Data.Val); + else + Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); + end if; + New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); + New_Procedure_Call (Assoc); + else + Sig := Targ; + end if; + + Start_Association (Assoc, Ghdl_Signal_Merge_Rti); + + New_Association + (Assoc, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); + New_Association + (Assoc, + New_Lit (New_Global_Unchecked_Address + (Get_Info (Data.Sig).Object_Rti, + Rtis.Ghdl_Rti_Access))); + New_Procedure_Call (Assoc); + Close_Temp; + end Merge_Signals_Rti_Non_Composite; + + function Merge_Signals_Rti_Prepare (Targ : Mnode; + Targ_Type : Iir; + Data : Merge_Signals_Data) + return Merge_Signals_Data + is + pragma Unreferenced (Targ); + pragma Unreferenced (Targ_Type); + Res : Merge_Signals_Data; + begin + Res := Data; + if Data.Has_Val then + if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then + Res.Val := Stabilize (Data.Val); + else + Res.Val := Chap3.Get_Array_Base (Data.Val); + end if; + end if; + + return Res; + end Merge_Signals_Rti_Prepare; + + function Merge_Signals_Rti_Update_Data_Array + (Data : Merge_Signals_Data; Targ_Type : Iir; Index : O_Dnode) + return Merge_Signals_Data + is + begin + if not Data.Has_Val then + return Data; + else + return Merge_Signals_Data' + (Sig => Data.Sig, + Val => Chap3.Index_Base (Data.Val, Targ_Type, + New_Obj_Value (Index)), + Has_Val => True, + Set_Init => Data.Set_Init); + end if; + end Merge_Signals_Rti_Update_Data_Array; + + procedure Merge_Signals_Rti_Finish_Data_Composite + (Data : in out Merge_Signals_Data) + is + pragma Unreferenced (Data); + begin + null; + end Merge_Signals_Rti_Finish_Data_Composite; + + function Merge_Signals_Rti_Update_Data_Record + (Data : Merge_Signals_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) return Merge_Signals_Data + is + pragma Unreferenced (Targ_Type); + begin + if not Data.Has_Val then + return Data; + else + return Merge_Signals_Data' + (Sig => Data.Sig, + Val => Chap6.Translate_Selected_Element (Data.Val, El), + Has_Val => True, + Set_Init => Data.Set_Init); + end if; + end Merge_Signals_Rti_Update_Data_Record; + + pragma Inline (Merge_Signals_Rti_Finish_Data_Composite); + + procedure Merge_Signals_Rti is new Foreach_Non_Composite + (Data_Type => Merge_Signals_Data, + Composite_Data_Type => Merge_Signals_Data, + Do_Non_Composite => Merge_Signals_Rti_Non_Composite, + Prepare_Data_Array => Merge_Signals_Rti_Prepare, + Update_Data_Array => Merge_Signals_Rti_Update_Data_Array, + Finish_Data_Array => Merge_Signals_Rti_Finish_Data_Composite, + Prepare_Data_Record => Merge_Signals_Rti_Prepare, + Update_Data_Record => Merge_Signals_Rti_Update_Data_Record, + Finish_Data_Record => Merge_Signals_Rti_Finish_Data_Composite); + + procedure Merge_Signals_Rti_Of_Port_Chain (Chain : Iir) + is + Port : Iir; + Port_Type : Iir; + Data : Merge_Signals_Data; + Val : Iir; + begin + Port := Chain; + while Port /= Null_Iir loop + Port_Type := Get_Type (Port); + Data.Sig := Port; + case Get_Mode (Port) is + when Iir_Buffer_Mode + | Iir_Out_Mode + | Iir_Inout_Mode => + Data.Set_Init := True; + when others => + Data.Set_Init := False; + end case; + + Open_Temp; + Val := Get_Default_Value (Port); + if Val = Null_Iir then + Data.Has_Val := False; + else + Data.Has_Val := True; + Data.Val := E2M (Chap7.Translate_Expression (Val, Port_Type), + Get_Info (Port_Type), + Mode_Value); + end if; + + Merge_Signals_Rti (Chap6.Translate_Name (Port), Port_Type, Data); + Close_Temp; + + Port := Get_Chain (Port); + end loop; + end Merge_Signals_Rti_Of_Port_Chain; + + procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir) + is + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt : Iir; + Final : Boolean; + begin + New_Debug_Line_Stmt (Get_Line_Number (Block)); + + case Get_Kind (Block) is + when Iir_Kind_Entity_Declaration => + Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Block)); + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_Block_Statement => + declare + Header : constant Iir_Block_Header := + Get_Block_Header (Block); + Guard : constant Iir := Get_Guard_Decl (Block); + begin + if Guard /= Null_Iir then + New_Debug_Line_Stmt (Get_Line_Number (Guard)); + Elab_Implicit_Guard_Signal (Block, Base_Info); + end if; + if Header /= Null_Iir then + New_Debug_Line_Stmt (Get_Line_Number (Header)); + Chap5.Elab_Map_Aspect (Header, Block); + Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Header)); + end if; + end; + when Iir_Kind_Generate_Statement => + null; + when others => + Error_Kind ("elab_block_declarations", Block); + end case; + + Open_Temp; + Chap4.Elab_Declaration_Chain (Block, Final); + Close_Temp; + + Stmt := Get_Concurrent_Statement_Chain (Block); + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Elab_Process (Stmt, Base_Info); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Elab_Psl_Directive (Stmt, Base_Info); + when Iir_Kind_Component_Instantiation_Statement => + declare + Info : constant Block_Info_Acc := Get_Info (Stmt); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Block_Elab_Subprg); + New_Association + (Constr, Get_Instance_Access (Base_Block)); + New_Procedure_Call (Constr); + end; + when Iir_Kind_Block_Statement => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Elab_Block_Declarations (Stmt, Base_Block); + Pop_Identifier_Prefix (Mark); + end; + when Iir_Kind_Generate_Statement => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + if Get_Kind (Get_Generation_Scheme (Stmt)) + = Iir_Kind_Iterator_Declaration + then + Elab_Iterative_Generate_Statement + (Stmt, Block, Base_Block); + else + Elab_Conditionnal_Generate_Statement + (Stmt, Block, Base_Block); + end if; + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("elab_block_declarations", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Elab_Block_Declarations; + end Chap9; + + package body Chap10 is + -- Identifiers. + -- The following functions are helpers to create ortho identifiers. + Identifier_Buffer : String (1 .. 512); + Identifier_Len : Natural := 0; + Identifier_Start : Natural := 1; + Identifier_Local : Local_Identifier_Type := 0; + + + Inst_Build : Inst_Build_Acc := null; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object => Inst_Build_Type, Name => Inst_Build_Acc); + + procedure Set_Global_Storage (Storage : O_Storage) is + begin + Global_Storage := Storage; + end Set_Global_Storage; + + procedure Pop_Build_Instance + is + Old : Inst_Build_Acc; + begin + Old := Inst_Build; + Identifier_Start := Old.Prev_Id_Start; + Inst_Build := Old.Prev; + Unchecked_Deallocation (Old); + end Pop_Build_Instance; + + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return Scope.Scope_Type; + end Get_Scope_Type; + + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return New_Sizeof (Scope.Scope_Type, Ghdl_Index_Type); + end Get_Scope_Size; + + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean is + begin + return Scope.Scope_Type /= O_Tnode_Null; + end Has_Scope_Type; + + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident) + is + begin + pragma Assert (Scope.Scope_Type = O_Tnode_Null); + New_Uncomplete_Record_Type (Scope.Scope_Type); + New_Type_Decl (Name, Scope.Scope_Type); + end Predeclare_Scope_Type; + + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode) is + begin + Ptr_Type := New_Access_Type (Get_Scope_Type (Scope)); + New_Type_Decl (Name, Ptr_Type); + end Declare_Scope_Acc; + + procedure Push_Instance_Factory (Scope : Var_Scope_Acc) + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null and then Inst_Build.Kind /= Instance then + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Instance); + Inst.Prev := Inst_Build; + Inst.Prev_Id_Start := Identifier_Start; + Inst.Scope := Scope; + + Identifier_Start := Identifier_Len + 1; + + if Scope.Scope_Type /= O_Tnode_Null then + Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements); + else + Start_Record_Type (Inst.Elements); + end if; + Inst_Build := Inst; + end Push_Instance_Factory; + + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode + is + Res : O_Fnode; + begin + New_Record_Field (Inst_Build.Elements, Res, Name, Ftype); + return Res; + end Add_Instance_Factory_Field; + + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type) + is + Field : O_Fnode; + begin + Field := Add_Instance_Factory_Field (Name, Get_Scope_Type (Child)); + Set_Scope_Via_Field (Child, Field, Inst_Build.Scope); + end Add_Scope_Field; + + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode is + begin + return New_Offsetof (Get_Scope_Type (Child.Up_Link.all), + Child.Field, Otype); + end Get_Scope_Offset; + + procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc) + is + Res : O_Tnode; + begin + if Inst_Build.Kind /= Instance then + -- Not matching. + raise Internal_Error; + end if; + Finish_Record_Type (Inst_Build.Elements, Res); + Pop_Build_Instance; + Scope.Scope_Type := Res; + end Pop_Instance_Factory; + + procedure Push_Local_Factory + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null + and then (Inst_Build.Kind /= Global and Inst_Build.Kind /= Local) + then + -- Cannot create a local factory on an instance. + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Kind => Local); + Inst.Prev := Inst_Build; + Inst.Prev_Global_Storage := Global_Storage; + + Inst.Prev_Id_Start := Identifier_Start; + Identifier_Start := Identifier_Len + 1; + + Inst_Build := Inst; + case Global_Storage is + when O_Storage_Public => + Global_Storage := O_Storage_Private; + when O_Storage_Private + | O_Storage_External => + null; + when O_Storage_Local => + raise Internal_Error; + end case; + end Push_Local_Factory; + + -- Return TRUE is the current scope is local. + function Is_Local_Scope return Boolean is + begin + if Inst_Build = null then + return False; + end if; + case Inst_Build.Kind is + when Local + | Instance => + return True; + when Global => + return False; + end case; + end Is_Local_Scope; + + procedure Pop_Local_Factory is + begin + if Inst_Build.Kind /= Local then + -- Not matching. + raise Internal_Error; + end if; + Global_Storage := Inst_Build.Prev_Global_Storage; + Pop_Build_Instance; + end Pop_Local_Factory; + + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field; + + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field_Ptr, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field_Ptr; + + procedure Set_Scope_Via_Var_Ptr + (Scope : in out Var_Scope_Type; Var : Var_Type) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + pragma Assert (Var.Kind = Var_Scope); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field_Ptr, + Field => Var.I_Field, Up_Link => Var.I_Scope); + end Set_Scope_Via_Var_Ptr; + + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Ptr, D => Scope_Param); + end Set_Scope_Via_Param_Ptr; + + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Decl, D => Decl); + end Set_Scope_Via_Decl; + + procedure Clear_Scope (Scope : in out Var_Scope_Type) is + begin + pragma Assert (Scope.Kind /= Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_None); + end Clear_Scope; + + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Type + is + Var : O_Dnode; + begin + New_Var_Decl (Var, Name, Storage, Vtype); + return Var_Type'(Kind => Var_Global, E => Var); + end Create_Global_Var; + + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Type + is + Res : O_Dnode; + begin + New_Const_Decl (Res, Name, Storage, Vtype); + if Storage /= O_Storage_External + and then Initial_Value /= O_Cnode_Null + then + Start_Const_Value (Res); + Finish_Const_Value (Res, Initial_Value); + end if; + return Var_Type'(Kind => Var_Global, E => Res); + end Create_Global_Const; + + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode) is + begin + Start_Const_Value (Const.E); + Finish_Const_Value (Const.E, Val); + end Define_Global_Const; + + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Type + is + Res : O_Dnode; + Field : O_Fnode; + K : Inst_Build_Kind_Type; + begin + if Inst_Build = null then + K := Global; + else + K := Inst_Build.Kind; + end if; + case K is + when Global => + -- The global scope is in use... + return Create_Global_Var (Name.Id, Vtype, Storage); + when Local => + -- It is always possible to create a variable in a local scope. + -- Create a var. + New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype); + return Var_Type'(Kind => Var_Local, E => Res); + when Instance => + -- Create a field. + New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype); + return Var_Type'(Kind => Var_Scope, I_Field => Field, + I_Scope => Inst_Build.Scope); + end case; + end Create_Var; + + -- Get a reference to scope STYPE. If IS_PTR is set, RES is an access + -- to the scope, otherwise RES directly designates the scope. + procedure Find_Scope (Scope : Var_Scope_Type; + Res : out O_Lnode; + Is_Ptr : out Boolean) is + begin + case Scope.Kind is + when Var_Scope_None => + raise Internal_Error; + when Var_Scope_Ptr + | Var_Scope_Decl => + Res := New_Obj (Scope.D); + Is_Ptr := Scope.Kind = Var_Scope_Ptr; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + declare + Parent : O_Lnode; + Parent_Ptr : Boolean; + begin + Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr); + if Parent_Ptr then + Parent := New_Acc_Value (Parent); + end if; + Res := New_Selected_Element (Parent, Scope.Field); + Is_Ptr := Scope.Kind = Var_Scope_Field_Ptr; + end; + end case; + end Find_Scope; + + procedure Check_Not_Building is + begin + -- Variables cannot be referenced if there is an instance being + -- built. + if Inst_Build /= null and then Inst_Build.Kind = Instance then + raise Internal_Error; + end if; + end Check_Not_Building; + + function Get_Instance_Access (Block : Iir) return O_Enode + is + Info : constant Block_Info_Acc := Get_Info (Block); + Res : O_Lnode; + Is_Ptr : Boolean; + begin + Check_Not_Building; + Find_Scope (Info.Block_Scope, Res, Is_Ptr); + if Is_Ptr then + return New_Value (Res); + else + return New_Address (Res, Info.Block_Decls_Ptr_Type); + end if; + end Get_Instance_Access; + + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode + is + Res : O_Lnode; + Is_Ptr : Boolean; + begin + Check_Not_Building; + Find_Scope (Scope, Res, Is_Ptr); + if Is_Ptr then + return New_Acc_Value (Res); + else + return Res; + end if; + end Get_Instance_Ref; + + function Get_Var (Var : Var_Type) return O_Lnode + is + begin + case Var.Kind is + when Var_None => + raise Internal_Error; + when Var_Local + | Var_Global => + return New_Obj (Var.E); + when Var_Scope => + return New_Selected_Element + (Get_Instance_Ref (Var.I_Scope.all), Var.I_Field); + end case; + end Get_Var; + + function Get_Alloc_Kind_For_Var (Var : Var_Type) + return Allocation_Kind is + begin + case Var.Kind is + when Var_Local => + return Alloc_Stack; + when Var_Global + | Var_Scope => + return Alloc_System; + when Var_None => + raise Internal_Error; + end case; + end Get_Alloc_Kind_For_Var; + + function Is_Var_Stable (Var : Var_Type) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return True; + when Var_Scope => + return False; + when Var_None => + raise Internal_Error; + end case; + end Is_Var_Stable; + + function Is_Var_Field (Var : Var_Type) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return False; + when Var_Scope => + return True; + when Var_None => + raise Internal_Error; + end case; + end Is_Var_Field; + + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode + is + begin + return New_Offsetof (Get_Scope_Type (Var.I_Scope.all), + Var.I_Field, Otype); + end Get_Var_Offset; + + function Get_Var_Label (Var : Var_Type) return O_Dnode is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return Var.E; + when Var_Scope + | Var_None => + raise Internal_Error; + end case; + end Get_Var_Label; + + procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is + begin + Id := Identifier_Local; + end Save_Local_Identifier; + + procedure Restore_Local_Identifier (Id : Local_Identifier_Type) is + begin + if Identifier_Local > Id then + -- If the value is restored with a smaller value, some identifiers + -- will be reused. This is certainly an internal error. + raise Internal_Error; + end if; + Identifier_Local := Id; + end Restore_Local_Identifier; + + -- Reset the identifier. + procedure Reset_Identifier_Prefix is + begin + if Identifier_Len /= 0 or else Identifier_Local /= 0 then + raise Internal_Error; + end if; + end Reset_Identifier_Prefix; + + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is + begin + Identifier_Len := Mark.Len; + Identifier_Local := Mark.Local_Id; + end Pop_Identifier_Prefix; + + procedure Add_String (Len : in out Natural; Str : String) is + begin + Identifier_Buffer (Len + 1 .. Len + Str'Length) := Str; + Len := Len + Str'Length; + end Add_String; + + procedure Add_Nat (Len : in out Natural; Val : Natural) + is + Num : String (1 .. 10); + V : Natural; + P : Natural; + begin + P := Num'Last; + V := Val; + loop + Num (P) := Character'Val (Character'Pos ('0') + V mod 10); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + Add_String (Len, Num (P .. Num'Last)); + end Add_Nat; + + -- Convert name_id NAME to a string stored to + -- NAME_BUFFER (1 .. NAME_LENGTH). + -- + -- This encodes extended identifiers. + -- + -- Extended identifier encoding: + -- They start with 'X'. + -- Non extended character [0-9a-zA-Z] are left as is, + -- others are encoded to _XX, where XX is the character position in hex. + -- They finish with "__". + procedure Name_Id_To_String (Name : Name_Id) + is + use Name_Table; + + type Bool_Array_Type is array (Character) of Boolean; + pragma Pack (Bool_Array_Type); + Is_Extended_Char : constant Bool_Array_Type := + ('0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' => False, + others => True); + + N_Len : Natural; + P : Natural; + C : Character; + begin + if Is_Character (Name) then + P := Character'Pos (Name_Table.Get_Character (Name)); + Name_Buffer (1) := 'C'; + Name_Buffer (2) := N2hex (P / 16); + Name_Buffer (3) := N2hex (P mod 16); + Name_Length := 3; + return; + else + Image (Name); + end if; + if Name_Buffer (1) /= '\' then + return; + end if; + -- Extended identifier. + -- Supress trailing backslash. + Name_Length := Name_Length - 1; + + -- Count number of characters in the extended string. + N_Len := Name_Length; + for I in 2 .. Name_Length loop + if Is_Extended_Char (Name_Buffer (I)) then + N_Len := N_Len + 2; + end if; + end loop; + + -- Convert. + Name_Buffer (1) := 'X'; + P := N_Len; + for J in reverse 2 .. Name_Length loop + C := Name_Buffer (J); + if Is_Extended_Char (C) then + Name_Buffer (P - 0) := N2hex (Character'Pos (C) mod 16); + Name_Buffer (P - 1) := N2hex (Character'Pos (C) / 16); + Name_Buffer (P - 2) := '_'; + P := P - 3; + else + Name_Buffer (P) := C; + P := P - 1; + end if; + end loop; + Name_Buffer (N_Len + 1) := '_'; + Name_Buffer (N_Len + 2) := '_'; + Name_Length := N_Len + 2; + end Name_Id_To_String; + + procedure Add_Name (Len : in out Natural; Name : Name_Id) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Add_String (Len, Name_Buffer (1 .. Name_Length)); + end Add_Name; + + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0) + is + P : Natural; + begin + Mark.Len := Identifier_Len; + Mark.Local_Id := Identifier_Local; + Identifier_Local := 0; + P := Identifier_Len; + Add_String (P, Name); + if Val > 0 then + Add_String (P, "O"); + Add_Nat (P, Natural (Val)); + end if; + Add_String (P, "__"); + Identifier_Len := P; + end Push_Identifier_Prefix; + + -- Add a suffix to the prefix (!!!). + procedure Push_Identifier_Prefix + (Mark : out Id_Mark_Type; Name : Name_Id; Val : Iir_Int32 := 0) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Push_Identifier_Prefix (Mark, Name_Buffer (1 .. Name_Length), Val); + end Push_Identifier_Prefix; + + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type) + is + Str : String := Local_Identifier_Type'Image (Identifier_Local); + begin + Identifier_Local := Identifier_Local + 1; + Str (1) := 'U'; + Push_Identifier_Prefix (Mark, Str, 0); + end Push_Identifier_Prefix_Uniq; + + procedure Add_Identifier (Len : in out Natural; Id : Name_Id) is + begin + if Id /= Null_Identifier then + Add_Name (Len, Id); + end if; + end Add_Identifier; + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Get_Identifier (Id)); + return Get_Identifier (Name_Buffer (1 .. Name_Length)); + end Create_Identifier_Without_Prefix; + + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Id); + Name_Buffer (Name_Length + 1 .. Name_Length + Str'Length) := Str; + return Get_Identifier (Name_Buffer (1 .. Name_Length + Str'Length)); + end Create_Identifier_Without_Prefix; + + -- Create an identifier from IIR node ID with prefix. + function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean) + return O_Ident + is + L : Natural; + begin + L := Identifier_Len; + Add_Identifier (L, Id); + Add_String (L, Str); + --Identifier_Buffer (L + Str'Length + 1) := Nul; + if Is_Local then + return Get_Identifier + (Identifier_Buffer (Identifier_Start .. L)); + else + return Get_Identifier (Identifier_Buffer (1 .. L)); + end if; + end Create_Id; + + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident + is + begin + return Create_Id (Id, Str, False); + end Create_Identifier; + + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident + is + begin + return Create_Id (Get_Identifier (Id), Str, False); + end Create_Identifier; + + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_Identifier (Len, Get_Identifier (Id)); + + if Val > 0 then + Add_String (Len, "O"); + Add_Nat (Len, Natural (Val)); + end if; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier (Str : String) + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier return O_Ident + is + begin + return Get_Identifier (Identifier_Buffer (1 .. Identifier_Len - 2)); + end Create_Identifier; + + function Create_Var_Identifier_From_Buffer (L : Natural) + return Var_Ident_Type + is + Start : Natural; + begin + if Is_Local_Scope then + Start := Identifier_Start; + else + Start := 1; + end if; + return (Id => Get_Identifier (Identifier_Buffer (Start .. L))); + end Create_Var_Identifier_From_Buffer; + + function Create_Var_Identifier (Id : Iir) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_Identifier (L, Get_Identifier (Id)); + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Var_Identifier (Id : String) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_String (L, Id); + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_Identifier (L, Get_Identifier (Id)); + Add_String (L, Str); + if Val > 0 then + Add_String (L, "O"); + Add_Nat (L, Val); + end if; + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Uniq_Identifier return Var_Ident_Type + is + Res : Var_Ident_Type; + begin + Res.Id := Create_Uniq_Identifier; + return Res; + end Create_Uniq_Identifier; + + type Instantiate_Var_Stack; + type Instantiate_Var_Stack_Acc is access Instantiate_Var_Stack; + + type Instantiate_Var_Stack is record + Orig_Scope : Var_Scope_Acc; + Inst_Scope : Var_Scope_Acc; + Prev : Instantiate_Var_Stack_Acc; + end record; + + Top_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; + Free_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; + + procedure Push_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc) + is + Inst : Instantiate_Var_Stack_Acc; + begin + if Free_Instantiate_Var_Stack = null then + Inst := new Instantiate_Var_Stack; + else + Inst := Free_Instantiate_Var_Stack; + Free_Instantiate_Var_Stack := Inst.Prev; + end if; + Inst.all := (Orig_Scope => Orig_Scope, + Inst_Scope => Inst_Scope, + Prev => Top_Instantiate_Var_Stack); + Top_Instantiate_Var_Stack := Inst; + end Push_Instantiate_Var_Scope; + + procedure Pop_Instantiate_Var_Scope (Inst_Scope : Var_Scope_Acc) + is + Item : constant Instantiate_Var_Stack_Acc := + Top_Instantiate_Var_Stack; + begin + pragma Assert (Item /= null); + pragma Assert (Item.Inst_Scope = Inst_Scope); + Top_Instantiate_Var_Stack := Item.Prev; + Item.all := (Orig_Scope => null, + Inst_Scope => null, + Prev => Free_Instantiate_Var_Stack); + Free_Instantiate_Var_Stack := Item; + end Pop_Instantiate_Var_Scope; + + function Instantiated_Var_Scope (Scope : Var_Scope_Acc) + return Var_Scope_Acc + is + Item : Instantiate_Var_Stack_Acc; + begin + if Scope = null then + return null; + end if; + + Item := Top_Instantiate_Var_Stack; + loop + pragma Assert (Item /= null); + if Item.Orig_Scope = Scope then + return Item.Inst_Scope; + end if; + Item := Item.Prev; + end loop; + end Instantiated_Var_Scope; + + function Instantiate_Var (Var : Var_Type) return Var_Type is + begin + case Var.Kind is + when Var_None + | Var_Global + | Var_Local => + return Var; + when Var_Scope => + return Var_Type' + (Kind => Var_Scope, + I_Field => Var.I_Field, + I_Scope => Instantiated_Var_Scope (Var.I_Scope)); + end case; + end Instantiate_Var; + + function Instantiate_Var_Scope (Scope : Var_Scope_Type) + return Var_Scope_Type is + begin + case Scope.Kind is + when Var_Scope_None + | Var_Scope_Ptr + | Var_Scope_Decl => + return Scope; + when Var_Scope_Field => + return Var_Scope_Type' + (Kind => Var_Scope_Field, + Scope_Type => Scope.Scope_Type, + Field => Scope.Field, + Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); + when Var_Scope_Field_Ptr => + return Var_Scope_Type' + (Kind => Var_Scope_Field_Ptr, + Scope_Type => Scope.Scope_Type, + Field => Scope.Field, + Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); + end case; + end Instantiate_Var_Scope; + end Chap10; + + package body Chap14 is + function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode + is + Prefix : constant Iir := Get_Prefix (Expr); + Type_Name : constant Iir := Is_Type_Name (Prefix); + Arr : Mnode; + Dim : Natural; + begin + if Type_Name /= Null_Iir then + -- Prefix denotes a type name + Arr := T2M (Type_Name, Mode_Value); + else + -- Prefix is an object. + Arr := Chap6.Translate_Name (Prefix); + end if; + Dim := Natural (Get_Value (Get_Parameter (Expr))); + return Chap3.Get_Array_Range (Arr, Get_Type (Prefix), Dim); + end Translate_Array_Attribute_To_Range; + + function Translate_Range_Array_Attribute (Expr : Iir) + return O_Lnode is + begin + return M2Lv (Translate_Array_Attribute_To_Range (Expr)); + end Translate_Range_Array_Attribute; + + function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) + return O_Enode + is + Rng : Mnode; + Val : O_Enode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + Val := M2E (Chap3.Range_To_Length (Rng)); + if Rtype /= Null_Iir then + Val := New_Convert_Ov (Val, Get_Ortho_Type (Rtype, Mode_Value)); + end if; + return Val; + end Translate_Length_Array_Attribute; + + -- Extract high or low bound of RANGE_VAR. + function Range_To_High_Low + (Range_Var : Mnode; Range_Type : Iir; Is_High : Boolean) + return Mnode + is + Op : ON_Op_Kind; + If_Blk : O_If_Block; + Range_Svar : constant Mnode := Stabilize (Range_Var); + Res : O_Dnode; + Tinfo : constant Ortho_Info_Acc := + Get_Info (Get_Base_Type (Range_Type)); + begin + Res := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + Open_Temp; + if Is_High then + Op := ON_Neq; + else + Op := ON_Eq; + end if; + Start_If_Stmt (If_Blk, + New_Compare_Op (Op, + M2E (Chap3.Range_To_Dir (Range_Svar)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Left (Range_Svar))); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Right (Range_Svar))); + Finish_If_Stmt (If_Blk); + Close_Temp; + return Dv2M (Res, Tinfo, Mode_Value); + end Range_To_High_Low; + + function Translate_High_Low_Type_Attribute + (Atype : Iir; Is_High : Boolean) return O_Enode + is + Cons : constant Iir := Get_Range_Constraint (Atype); + begin + -- FIXME: improve code if constraint is a range expression. + if Get_Type_Staticness (Atype) = Locally then + if Get_Direction (Cons) = Iir_To xor Is_High then + return New_Lit + (Chap7.Translate_Static_Range_Left (Cons, Atype)); + else + return New_Lit + (Chap7.Translate_Static_Range_Right (Cons, Atype)); + end if; + else + return M2E (Range_To_High_Low + (Chap3.Type_To_Range (Atype), Atype, Is_High)); + end if; + end Translate_High_Low_Type_Attribute; + + function Translate_High_Low_Array_Attribute (Expr : Iir; + Is_High : Boolean) + return O_Enode + is + begin + -- FIXME: improve code if index is a range expression. + return M2E (Range_To_High_Low + (Translate_Array_Attribute_To_Range (Expr), + Get_Type (Expr), Is_High)); + end Translate_High_Low_Array_Attribute; + + function Translate_Low_Array_Attribute (Expr : Iir) + return O_Enode + is + begin + return Translate_High_Low_Array_Attribute (Expr, False); + end Translate_Low_Array_Attribute; + + function Translate_High_Array_Attribute (Expr : Iir) + return O_Enode + is + begin + return Translate_High_Low_Array_Attribute (Expr, True); + end Translate_High_Array_Attribute; + + function Translate_Left_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return M2E (Chap3.Range_To_Left (Rng)); + end Translate_Left_Array_Attribute; + + function Translate_Right_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return M2E (Chap3.Range_To_Right (Rng)); + end Translate_Right_Array_Attribute; + + function Translate_Ascending_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Lit (Ghdl_Dir_To_Node), + Std_Boolean_Type_Node); + end Translate_Ascending_Array_Attribute; + + function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode is + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Left + (Get_Range_Constraint (Atype), Atype)); + else + return M2E (Chap3.Range_To_Left (Chap3.Type_To_Range (Atype))); + end if; + end Translate_Left_Type_Attribute; + + function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode is + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Right + (Get_Range_Constraint (Atype), Atype)); + else + return M2E (Chap3.Range_To_Right (Chap3.Type_To_Range (Atype))); + end if; + end Translate_Right_Type_Attribute; + + function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode + is + Info : Type_Info_Acc; + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Dir + (Get_Range_Constraint (Atype))); + else + Info := Get_Info (Atype); + return New_Value + (New_Selected_Element (Get_Var (Info.T.Range_Var), + Info.T.Range_Dir)); + end if; + end Translate_Dir_Type_Attribute; + + function Translate_Val_Attribute (Attr : Iir) return O_Enode + is + Val : O_Enode; + Attr_Type : Iir; + Res_Var : O_Dnode; + Res_Type : O_Tnode; + begin + Attr_Type := Get_Type (Attr); + Res_Type := Get_Ortho_Type (Attr_Type, Mode_Value); + Res_Var := Create_Temp (Res_Type); + Val := Chap7.Translate_Expression (Get_Parameter (Attr)); + + case Get_Kind (Attr_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + -- For enumeration, always check the value is in the enum + -- range. + declare + Val_Type : O_Tnode; + Val_Var : O_Dnode; + If_Blk : O_If_Block; + begin + Val_Type := Get_Ortho_Type (Get_Type (Get_Parameter (Attr)), + Mode_Value); + Val_Var := Create_Temp_Init (Val_Type, Val); + Start_If_Stmt + (If_Blk, + New_Dyadic_Op + (ON_Or, + New_Compare_Op (ON_Lt, + New_Obj_Value (Val_Var), + New_Lit (New_Signed_Literal + (Val_Type, 0)), + Ghdl_Bool_Type), + New_Compare_Op (ON_Ge, + New_Obj_Value (Val_Var), + New_Lit (New_Signed_Literal + (Val_Type, + Integer_64 + (Get_Nbr_Elements + (Get_Enumeration_Literal_List + (Attr_Type))))), + Ghdl_Bool_Type))); + Chap6.Gen_Bound_Error (Attr); + Finish_If_Stmt (If_Blk); + Val := New_Obj_Value (Val_Var); + end; + when others => + null; + end case; + + New_Assign_Stmt (New_Obj (Res_Var), New_Convert_Ov (Val, Res_Type)); + Chap3.Check_Range + (Res_Var, Attr, Get_Type (Get_Prefix (Attr)), Attr); + return New_Obj_Value (Res_Var); + end Translate_Val_Attribute; + + function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) + return O_Enode + is + T : O_Dnode; + Ttype : O_Tnode; + begin + Ttype := Get_Ortho_Type (Res_Type, Mode_Value); + T := Create_Temp (Ttype); + New_Assign_Stmt + (New_Obj (T), + New_Convert_Ov (Chap7.Translate_Expression (Get_Parameter (Attr)), + Ttype)); + Chap3.Check_Range (T, Attr, Res_Type, Attr); + return New_Obj_Value (T); + end Translate_Pos_Attribute; + + function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode + is + Expr_Type : Iir; + Tinfo : Type_Info_Acc; + Ttype : O_Tnode; + Expr : O_Enode; + List : Iir_List; + Limit : Iir; + Is_Succ : Boolean; + Op : ON_Op_Kind; + begin + -- FIXME: should check bounds. + Expr_Type := Get_Type (Attr); + Tinfo := Get_Info (Expr_Type); + Expr := Chap7.Translate_Expression (Get_Parameter (Attr), Expr_Type); + Ttype := Tinfo.Ortho_Type (Mode_Value); + Is_Succ := Get_Kind (Attr) = Iir_Kind_Succ_Attribute; + if Is_Succ then + Op := ON_Add_Ov; + else + Op := ON_Sub_Ov; + end if; + case Tinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 => + -- Should check it is not the last. + declare + L : O_Dnode; + begin + List := Get_Enumeration_Literal_List (Get_Base_Type + (Expr_Type)); + L := Create_Temp_Init (Ttype, Expr); + if Is_Succ then + Limit := Get_Last_Element (List); + else + Limit := Get_First_Element (List); + end if; + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Eq, + New_Obj_Value (L), + New_Lit (Get_Ortho_Expr (Limit)), + Ghdl_Bool_Type), + Attr, 0); + return New_Convert_Ov + (New_Dyadic_Op + (Op, + New_Convert_Ov (New_Obj_Value (L), Ghdl_I32_Type), + New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1))), + Ttype); + end; + when Type_Mode_I32 + | Type_Mode_P64 => + return New_Dyadic_Op + (Op, Expr, New_Lit (New_Signed_Literal (Ttype, 1))); + when others => + raise Internal_Error; + end case; + end Translate_Succ_Pred_Attribute; + + type Bool_Sigattr_Data_Type is record + Label : O_Snode; + Field : O_Fnode; + end record; + + procedure Bool_Sigattr_Non_Composite_Signal + (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) + is + pragma Unreferenced (Targ_Type); + begin + Gen_Exit_When (Data.Label, + New_Value (Get_Signal_Field (Targ, Data.Field))); + end Bool_Sigattr_Non_Composite_Signal; + + function Bool_Sigattr_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Bool_Sigattr_Prepare_Data_Composite; + + function Bool_Sigattr_Update_Data_Array (Data : Bool_Sigattr_Data_Type; + Targ_Type : Iir; + Index : O_Dnode) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ_Type, Index); + begin + return Data; + end Bool_Sigattr_Update_Data_Array; + + function Bool_Sigattr_Update_Data_Record (Data : Bool_Sigattr_Data_Type; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ_Type, El); + begin + return Data; + end Bool_Sigattr_Update_Data_Record; + + procedure Bool_Sigattr_Finish_Data_Composite + (Data : in out Bool_Sigattr_Data_Type) + is + pragma Unreferenced (Data); + begin + null; + end Bool_Sigattr_Finish_Data_Composite; + + procedure Bool_Sigattr_Foreach is new Foreach_Non_Composite + (Data_Type => Bool_Sigattr_Data_Type, + Composite_Data_Type => Bool_Sigattr_Data_Type, + Do_Non_Composite => Bool_Sigattr_Non_Composite_Signal, + Prepare_Data_Array => Bool_Sigattr_Prepare_Data_Composite, + Update_Data_Array => Bool_Sigattr_Update_Data_Array, + Finish_Data_Array => Bool_Sigattr_Finish_Data_Composite, + Prepare_Data_Record => Bool_Sigattr_Prepare_Data_Composite, + Update_Data_Record => Bool_Sigattr_Update_Data_Record, + Finish_Data_Record => Bool_Sigattr_Finish_Data_Composite); + + function Translate_Bool_Signal_Attribute (Attr : Iir; Field : O_Fnode) + return O_Enode + is + Data : Bool_Sigattr_Data_Type; + Res : O_Dnode; + Name : Mnode; + Prefix : constant Iir := Get_Prefix (Attr); + Prefix_Type : constant Iir := Get_Type (Prefix); + begin + if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then + -- Effecient handling for a scalar signal. + Name := Chap6.Translate_Name (Prefix); + return New_Value (Get_Signal_Field (Name, Field)); + else + -- Element per element handling for composite signals. + Res := Create_Temp (Std_Boolean_Type_Node); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); + Name := Chap6.Translate_Name (Prefix); + Start_Loop_Stmt (Data.Label); + Data.Field := Field; + Bool_Sigattr_Foreach (Name, Prefix_Type, Data); + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); + New_Exit_Stmt (Data.Label); + Finish_Loop_Stmt (Data.Label); + Close_Temp; + return New_Obj_Value (Res); + end if; + end Translate_Bool_Signal_Attribute; + + function Translate_Event_Attribute (Attr : Iir) return O_Enode is + begin + return Translate_Bool_Signal_Attribute + (Attr, Ghdl_Signal_Event_Field); + end Translate_Event_Attribute; + + function Translate_Active_Attribute (Attr : Iir) return O_Enode is + begin + return Translate_Bool_Signal_Attribute + (Attr, Ghdl_Signal_Active_Field); + end Translate_Active_Attribute; + + -- Read signal value FIELD of signal SIG. + function Get_Signal_Value_Field + (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) + return O_Lnode + is + S_Type : O_Tnode; + T : O_Lnode; + begin + S_Type := Get_Ortho_Type (Sig_Type, Mode_Signal); + T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Access_Element + (New_Unchecked_Address (New_Selected_Element (T, Field), S_Type)); + end Get_Signal_Value_Field; + + function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) + return O_Lnode + is + S : O_Enode; + begin + S := New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr); + return New_Selected_Element (New_Access_Element (S), Field); + end Get_Signal_Field; + + function Read_Last_Value (Sig : O_Enode; Sig_Type : Iir) return O_Enode + is + begin + return New_Value (Get_Signal_Value_Field + (Sig, Sig_Type, Ghdl_Signal_Last_Value_Field)); + end Read_Last_Value; + + function Translate_Last_Value is new Chap7.Translate_Signal_Value + (Read_Value => Read_Last_Value); + + function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode + is + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + Name := Chap6.Translate_Name (Prefix); + if Get_Object_Kind (Name) /= Mode_Signal then + raise Internal_Error; + end if; + return Translate_Last_Value (M2E (Name), Prefix_Type); + end Translate_Last_Value_Attribute; + + function Read_Last_Time (Sig : O_Enode; Field : O_Fnode) return O_Enode + is + T : O_Lnode; + begin + T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Value (New_Selected_Element (T, Field)); + end Read_Last_Time; + + type Last_Time_Data is record + Var : O_Dnode; + Field : O_Fnode; + end record; + + procedure Translate_Last_Time_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) + is + pragma Unreferenced (Targ_Type); + Val : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + Val := Create_Temp_Init + (Std_Time_Otype, + Read_Last_Time (New_Value (M2Lv (Targ)), Data.Field)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Gt, + New_Obj_Value (Val), + New_Obj_Value (Data.Var), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Data.Var), New_Obj_Value (Val)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end Translate_Last_Time_Non_Composite; + + function Last_Time_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) + return Last_Time_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Last_Time_Prepare_Data_Composite; + + function Last_Time_Update_Data_Array (Data : Last_Time_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Last_Time_Data + is + pragma Unreferenced (Targ_Type, Index); + begin + return Data; + end Last_Time_Update_Data_Array; + + function Last_Time_Update_Data_Record (Data : Last_Time_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Last_Time_Data + is + pragma Unreferenced (Targ_Type, El); + begin + return Data; + end Last_Time_Update_Data_Record; + + procedure Last_Time_Finish_Data_Composite + (Data : in out Last_Time_Data) + is + pragma Unreferenced (Data); + begin + null; + end Last_Time_Finish_Data_Composite; + + procedure Translate_Last_Time is new Foreach_Non_Composite + (Data_Type => Last_Time_Data, + Composite_Data_Type => Last_Time_Data, + Do_Non_Composite => Translate_Last_Time_Non_Composite, + Prepare_Data_Array => Last_Time_Prepare_Data_Composite, + Update_Data_Array => Last_Time_Update_Data_Array, + Finish_Data_Array => Last_Time_Finish_Data_Composite, + Prepare_Data_Record => Last_Time_Prepare_Data_Composite, + Update_Data_Record => Last_Time_Update_Data_Record, + Finish_Data_Record => Last_Time_Finish_Data_Composite); + + function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) + return O_Enode + is + Prefix_Type : Iir; + Name : Mnode; + Info : Type_Info_Acc; + Var : O_Dnode; + Data : Last_Time_Data; + Right_Bound : Iir_Int64; + If_Blk : O_If_Block; + begin + Prefix_Type := Get_Type (Prefix); + Name := Chap6.Translate_Name (Prefix); + Info := Get_Info (Prefix_Type); + Var := Create_Temp (Std_Time_Otype); + + if Info.Type_Mode in Type_Mode_Scalar then + New_Assign_Stmt (New_Obj (Var), + Read_Last_Time (M2E (Name), Field)); + else + -- Init with a negative value. + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Signed_Literal (Std_Time_Otype, -1))); + Data := Last_Time_Data'(Var => Var, Field => Field); + Translate_Last_Time (Name, Prefix_Type, Data); + end if; + + Right_Bound := Get_Value + (Get_Right_Limit (Get_Range_Constraint (Time_Subtype_Definition))); + + -- VAR < 0 ? + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Lt, + New_Obj_Value (Var), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0)), + Ghdl_Bool_Type)); + -- LRM 14.1 Predefined attributes + -- [...]; otherwise, it returns TIME'HIGH. + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Signed_Literal + (Std_Time_Otype, Integer_64 (Right_Bound)))); + New_Else_Stmt (If_Blk); + -- Returns NOW - Var. + New_Assign_Stmt (New_Obj (Var), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Ghdl_Now), + New_Obj_Value (Var))); + Finish_If_Stmt (If_Blk); + return New_Obj_Value (Var); + end Translate_Last_Time_Attribute; + + -- Return TRUE if the scalar signal SIG is being driven. + function Read_Driving_Attribute (Sig : O_Enode) return O_Enode + is + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Driving); + New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Function_Call (Assoc); + end Read_Driving_Attribute; + + procedure Driving_Non_Composite_Signal + (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) + is + pragma Unreferenced (Targ_Type); + begin + Gen_Exit_When + (Label, + New_Monadic_Op + (ON_Not, Read_Driving_Attribute (New_Value (M2Lv (Targ))))); + end Driving_Non_Composite_Signal; + + function Driving_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) + return O_Snode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Label; + end Driving_Prepare_Data_Composite; + + function Driving_Update_Data_Array (Label : O_Snode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Snode + is + pragma Unreferenced (Targ_Type, Index); + begin + return Label; + end Driving_Update_Data_Array; + + function Driving_Update_Data_Record (Label : O_Snode; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return O_Snode + is + pragma Unreferenced (Targ_Type, El); + begin + return Label; + end Driving_Update_Data_Record; + + procedure Driving_Finish_Data_Composite (Label : in out O_Snode) + is + pragma Unreferenced (Label); + begin + null; + end Driving_Finish_Data_Composite; + + procedure Driving_Foreach is new Foreach_Non_Composite + (Data_Type => O_Snode, + Composite_Data_Type => O_Snode, + Do_Non_Composite => Driving_Non_Composite_Signal, + Prepare_Data_Array => Driving_Prepare_Data_Composite, + Update_Data_Array => Driving_Update_Data_Array, + Finish_Data_Array => Driving_Finish_Data_Composite, + Prepare_Data_Record => Driving_Prepare_Data_Composite, + Update_Data_Record => Driving_Update_Data_Record, + Finish_Data_Record => Driving_Finish_Data_Composite); + + function Translate_Driving_Attribute (Attr : Iir) return O_Enode + is + Label : O_Snode; + Res : O_Dnode; + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then + -- Effecient handling for a scalar signal. + Name := Chap6.Translate_Name (Prefix); + return Read_Driving_Attribute (New_Value (M2Lv (Name))); + else + -- Element per element handling for composite signals. + Res := Create_Temp (Std_Boolean_Type_Node); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); + Name := Chap6.Translate_Name (Prefix); + Start_Loop_Stmt (Label); + Driving_Foreach (Name, Prefix_Type, Label); + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); + New_Exit_Stmt (Label); + Finish_Loop_Stmt (Label); + Close_Temp; + return New_Obj_Value (Res); + end if; + end Translate_Driving_Attribute; + + function Read_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + Tinfo : Type_Info_Acc; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + begin + Tinfo := Get_Info (Sig_Type); + case Tinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Driving_Value_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Driving_Value_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Driving_Value_E32; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Driving_Value_I32; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Driving_Value_I64; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Driving_Value_F64; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Convert_Ov (New_Function_Call (Assoc), + Tinfo.Ortho_Type (Mode_Value)); + end Read_Driving_Value; + + function Translate_Driving_Value is new Chap7.Translate_Signal_Value + (Read_Value => Read_Driving_Value); + + function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode + is + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + Name := Chap6.Translate_Name (Prefix); + if Get_Object_Kind (Name) /= Mode_Signal then + raise Internal_Error; + end if; + return Translate_Driving_Value (M2E (Name), Prefix_Type); + end Translate_Driving_Value_Attribute; + + function Translate_Image_Attribute (Attr : Iir) return O_Enode + is + Prefix_Type : constant Iir := + Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); + Res : O_Dnode; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + Conv : O_Tnode; + begin + Res := Create_Temp (Std_String_Node); + Create_Temp_Stack2_Mark; + case Pinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Image_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Image_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Image_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 => + Subprg := Ghdl_Image_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P32 => + Subprg := Ghdl_Image_P32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_Image_P64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Image_F64; + Conv := Ghdl_Real_Type; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association (Assoc, + New_Address (New_Obj (Res), Std_String_Ptr_Node)); + New_Association + (Assoc, + New_Convert_Ov + (Chap7.Translate_Expression (Get_Parameter (Attr), Prefix_Type), + Conv)); + case Pinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 + | Type_Mode_P32 + | Type_Mode_P64 => + New_Association + (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + when Type_Mode_I32 + | Type_Mode_F64 => + null; + when others => + raise Internal_Error; + end case; + New_Procedure_Call (Assoc); + return New_Address (New_Obj (Res), Std_String_Ptr_Node); + end Translate_Image_Attribute; + + function Translate_Value_Attribute (Attr : Iir) return O_Enode + is + Prefix_Type : constant Iir := + Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); + Subprg : O_Dnode; + Assoc : O_Assoc_List; + begin + case Pinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Value_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Value_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Value_E32; + when Type_Mode_I32 => + Subprg := Ghdl_Value_I32; + when Type_Mode_P32 => + Subprg := Ghdl_Value_P32; + when Type_Mode_P64 => + Subprg := Ghdl_Value_P64; + when Type_Mode_F64 => + Subprg := Ghdl_Value_F64; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association + (Assoc, + Chap7.Translate_Expression (Get_Parameter (Attr), + String_Type_Definition)); + case Pinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 + | Type_Mode_P32 + | Type_Mode_P64 => + New_Association + (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + when Type_Mode_I32 + | Type_Mode_F64 => + null; + when others => + raise Internal_Error; + end case; + return New_Convert_Ov (New_Function_Call (Assoc), + Pinfo.Ortho_Type (Mode_Value)); + end Translate_Value_Attribute; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode + is + Name : constant Path_Instance_Name_Type := + Get_Path_Instance_Name_Suffix (Attr); + Res : O_Dnode; + Name_Cst : O_Dnode; + Str_Cst : O_Cnode; + Constr : O_Assoc_List; + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + Create_Temp_Stack2_Mark; + + Res := Create_Temp (Std_String_Node); + Str_Cst := Create_String_Len (Name.Suffix, Create_Uniq_Identifier); + New_Const_Decl (Name_Cst, Create_Uniq_Identifier, O_Storage_Private, + Ghdl_Str_Len_Type_Node); + Start_Const_Value (Name_Cst); + Finish_Const_Value (Name_Cst, Str_Cst); + if Is_Instance then + Start_Association (Constr, Ghdl_Get_Instance_Name); + else + Start_Association (Constr, Ghdl_Get_Path_Name); + end if; + New_Association + (Constr, New_Address (New_Obj (Res), Std_String_Ptr_Node)); + if Name.Path_Instance = Null_Iir then + Rtis.Associate_Null_Rti_Context (Constr); + else + Rtis.Associate_Rti_Context (Constr, Name.Path_Instance); + end if; + New_Association (Constr, + New_Address (New_Obj (Name_Cst), + Ghdl_Str_Len_Ptr_Node)); + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), Std_String_Ptr_Node); + end Translate_Path_Instance_Name_Attribute; + end Chap14; + + package body Rtis is + -- Node for package, body, entity, architecture, block, generate, + -- processes. + Ghdl_Rtin_Block : O_Tnode; + Ghdl_Rtin_Block_Common : O_Fnode; + Ghdl_Rtin_Block_Name : O_Fnode; + Ghdl_Rtin_Block_Loc : O_Fnode; + Ghdl_Rtin_Block_Parent : O_Fnode; + Ghdl_Rtin_Block_Size : O_Fnode; + Ghdl_Rtin_Block_Nbr_Child : O_Fnode; + Ghdl_Rtin_Block_Children : O_Fnode; + + -- Node for scalar type decls. + Ghdl_Rtin_Type_Scalar : O_Tnode; + Ghdl_Rtin_Type_Scalar_Common : O_Fnode; + Ghdl_Rtin_Type_Scalar_Name : O_Fnode; + + -- Node for an enumeration type definition. + Ghdl_Rtin_Type_Enum : O_Tnode; + Ghdl_Rtin_Type_Enum_Common : O_Fnode; + Ghdl_Rtin_Type_Enum_Name : O_Fnode; + Ghdl_Rtin_Type_Enum_Nbr : O_Fnode; + Ghdl_Rtin_Type_Enum_Lits : O_Fnode; + + -- Node for an unit64. + Ghdl_Rtin_Unit64 : O_Tnode; + Ghdl_Rtin_Unit64_Common : O_Fnode; + Ghdl_Rtin_Unit64_Name : O_Fnode; + Ghdl_Rtin_Unit64_Value : O_Fnode; + + -- Node for an unitptr. + Ghdl_Rtin_Unitptr : O_Tnode; + Ghdl_Rtin_Unitptr_Common : O_Fnode; + Ghdl_Rtin_Unitptr_Name : O_Fnode; + Ghdl_Rtin_Unitptr_Value : O_Fnode; + + -- Node for a physical type + Ghdl_Rtin_Type_Physical : O_Tnode; + Ghdl_Rtin_Type_Physical_Common : O_Fnode; + Ghdl_Rtin_Type_Physical_Name : O_Fnode; + Ghdl_Rtin_Type_Physical_Nbr : O_Fnode; + Ghdl_Rtin_Type_Physical_Units : O_Fnode; + + -- Node for a scalar subtype definition. + Ghdl_Rtin_Subtype_Scalar : O_Tnode; + Ghdl_Rtin_Subtype_Scalar_Common : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Name : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Base : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Range : O_Fnode; + + -- Node for an access or a file type. + Ghdl_Rtin_Type_Fileacc : O_Tnode; + Ghdl_Rtin_Type_Fileacc_Common : O_Fnode; + Ghdl_Rtin_Type_Fileacc_Name : O_Fnode; + Ghdl_Rtin_Type_Fileacc_Base : O_Fnode; + + -- Node for an array type. + Ghdl_Rtin_Type_Array : O_Tnode; + Ghdl_Rtin_Type_Array_Common : O_Fnode; + Ghdl_Rtin_Type_Array_Name : O_Fnode; + Ghdl_Rtin_Type_Array_Element : O_Fnode; + Ghdl_Rtin_Type_Array_Nbrdim : O_Fnode; + Ghdl_Rtin_Type_Array_Indexes : O_Fnode; + + -- Node for an array subtype. + Ghdl_Rtin_Subtype_Array : O_Tnode; + Ghdl_Rtin_Subtype_Array_Common : O_Fnode; + Ghdl_Rtin_Subtype_Array_Name : O_Fnode; + Ghdl_Rtin_Subtype_Array_Basetype : O_Fnode; + Ghdl_Rtin_Subtype_Array_Bounds : O_Fnode; + Ghdl_Rtin_Subtype_Array_Valsize : O_Fnode; + Ghdl_Rtin_Subtype_Array_Sigsize : O_Fnode; + + -- Node for a record element. + Ghdl_Rtin_Element : O_Tnode; + Ghdl_Rtin_Element_Common : O_Fnode; + Ghdl_Rtin_Element_Name : O_Fnode; + Ghdl_Rtin_Element_Type : O_Fnode; + Ghdl_Rtin_Element_Valoff : O_Fnode; + Ghdl_Rtin_Element_Sigoff : O_Fnode; + + -- Node for a record type. + Ghdl_Rtin_Type_Record : O_Tnode; + Ghdl_Rtin_Type_Record_Common : O_Fnode; + Ghdl_Rtin_Type_Record_Name : O_Fnode; + Ghdl_Rtin_Type_Record_Nbrel : O_Fnode; + Ghdl_Rtin_Type_Record_Elements : O_Fnode; + --Ghdl_Rtin_Type_Record_Valsize : O_Fnode; + --Ghdl_Rtin_Type_Record_Sigsize : O_Fnode; + + -- Node for an object. + Ghdl_Rtin_Object : O_Tnode; + Ghdl_Rtin_Object_Common : O_Fnode; + Ghdl_Rtin_Object_Name : O_Fnode; + Ghdl_Rtin_Object_Loc : O_Fnode; + Ghdl_Rtin_Object_Type : O_Fnode; + + -- Node for an instance. + Ghdl_Rtin_Instance : O_Tnode; + Ghdl_Rtin_Instance_Common : O_Fnode; + Ghdl_Rtin_Instance_Name : O_Fnode; + Ghdl_Rtin_Instance_Loc : O_Fnode; + Ghdl_Rtin_Instance_Parent : O_Fnode; + Ghdl_Rtin_Instance_Type : O_Fnode; + + -- Node for a component. + Ghdl_Rtin_Component : O_Tnode; + Ghdl_Rtin_Component_Common : O_Fnode; + Ghdl_Rtin_Component_Name : O_Fnode; + Ghdl_Rtin_Component_Nbr_Child : O_Fnode; + Ghdl_Rtin_Component_Children : O_Fnode; + + procedure Rti_Initialize + is + begin + -- Create type ghdl_rti_kind is (ghdl_rtik_typedef_bool, ...) + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_top"), + Ghdl_Rtik_Top); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_library"), + Ghdl_Rtik_Library); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_package"), + Ghdl_Rtik_Package); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_package_body"), + Ghdl_Rtik_Package_Body); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_entity"), + Ghdl_Rtik_Entity); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_architecture"), + Ghdl_Rtik_Architecture); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_process"), + Ghdl_Rtik_Process); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_block"), + Ghdl_Rtik_Block); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_if_generate"), + Ghdl_Rtik_If_Generate); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_for_generate"), + Ghdl_Rtik_For_Generate); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_instance"), + Ghdl_Rtik_Instance); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_constant"), + Ghdl_Rtik_Constant); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_iterator"), + Ghdl_Rtik_Iterator); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_variable"), + Ghdl_Rtik_Variable); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_signal"), + Ghdl_Rtik_Signal); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_file"), + Ghdl_Rtik_File); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_port"), + Ghdl_Rtik_Port); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_generic"), + Ghdl_Rtik_Generic); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_alias"), + Ghdl_Rtik_Alias); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_guard"), + Ghdl_Rtik_Guard); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_component"), + Ghdl_Rtik_Component); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute"), + Ghdl_Rtik_Attribute); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_b1"), + Ghdl_Rtik_Type_B1); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_e8"), + Ghdl_Rtik_Type_E8); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_e32"), + Ghdl_Rtik_Type_E32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_i32"), + Ghdl_Rtik_Type_I32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_i64"), + Ghdl_Rtik_Type_I64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_f64"), + Ghdl_Rtik_Type_F64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_p32"), + Ghdl_Rtik_Type_P32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_p64"), + Ghdl_Rtik_Type_P64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_access"), + Ghdl_Rtik_Type_Access); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_array"), + Ghdl_Rtik_Type_Array); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_record"), + Ghdl_Rtik_Type_Record); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_file"), + Ghdl_Rtik_Type_File); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_scalar"), + Ghdl_Rtik_Subtype_Scalar); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_array"), + Ghdl_Rtik_Subtype_Array); + New_Enum_Literal + (Constr, + Get_Identifier ("__ghdl_rtik_subtype_unconstrained_array"), + Ghdl_Rtik_Subtype_Unconstrained_Array); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_record"), + Ghdl_Rtik_Subtype_Record); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_access"), + Ghdl_Rtik_Subtype_Access); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_protected"), + Ghdl_Rtik_Type_Protected); + + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_element"), + Ghdl_Rtik_Element); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unit64"), + Ghdl_Rtik_Unit64); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unitptr"), + Ghdl_Rtik_Unitptr); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_transaction"), + Ghdl_Rtik_Attribute_Transaction); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_quiet"), + Ghdl_Rtik_Attribute_Quiet); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_stable"), + Ghdl_Rtik_Attribute_Stable); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_psl_assert"), + Ghdl_Rtik_Psl_Assert); + + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_error"), + Ghdl_Rtik_Error); + Finish_Enum_Type (Constr, Ghdl_Rtik); + New_Type_Decl (Get_Identifier ("__ghdl_rtik"), Ghdl_Rtik); + end; + + -- Create type ghdl_rti_depth. + Ghdl_Rti_Depth := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_rti_depth"), Ghdl_Rti_Depth); + Ghdl_Rti_U8 := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_rti_u8"), Ghdl_Rti_U8); + + -- Create type ghdl_rti_common. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rti_Common_Kind, + Get_Identifier ("kind"), Ghdl_Rtik); + New_Record_Field (Constr, Ghdl_Rti_Common_Depth, + Get_Identifier ("depth"), Ghdl_Rti_Depth); + New_Record_Field (Constr, Ghdl_Rti_Common_Mode, + Get_Identifier ("mode"), Ghdl_Rti_U8); + New_Record_Field (Constr, Ghdl_Rti_Common_Max_Depth, + Get_Identifier ("max_depth"), Ghdl_Rti_Depth); + Finish_Record_Type (Constr, Ghdl_Rti_Common); + New_Type_Decl (Get_Identifier ("__ghdl_rti_common"), + Ghdl_Rti_Common); + end; + + Ghdl_Rti_Access := New_Access_Type (Ghdl_Rti_Common); + New_Type_Decl (Get_Identifier ("__ghdl_rti_access"), Ghdl_Rti_Access); + + Ghdl_Rti_Array := New_Array_Type (Ghdl_Rti_Access, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_rti_array"), Ghdl_Rti_Array); + + Ghdl_Rti_Arr_Acc := New_Access_Type (Ghdl_Rti_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rti_arr_acc"), + Ghdl_Rti_Arr_Acc); + + -- Ghdl_Component_Link_Type. + New_Uncomplete_Record_Type (Ghdl_Component_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_component_link_type"), + Ghdl_Component_Link_Type); + + Ghdl_Component_Link_Acc := New_Access_Type (Ghdl_Component_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_component_link_acc"), + Ghdl_Component_Link_Acc); + + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Entity_Link_Rti, + Get_Identifier ("rti"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Entity_Link_Parent, + Wki_Parent, Ghdl_Component_Link_Acc); + Finish_Record_Type (Constr, Ghdl_Entity_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_entity_link_type"), + Ghdl_Entity_Link_Type); + end; + + Ghdl_Entity_Link_Acc := New_Access_Type (Ghdl_Entity_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_entity_link_acc"), + Ghdl_Entity_Link_Acc); + + declare + Constr : O_Element_List; + begin + Start_Uncomplete_Record_Type (Ghdl_Component_Link_Type, Constr); + New_Record_Field (Constr, Ghdl_Component_Link_Instance, + Wki_Instance, Ghdl_Entity_Link_Acc); + New_Record_Field (Constr, Ghdl_Component_Link_Stmt, + Get_Identifier ("stmt"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Component_Link_Type); + end; + + -- Create type ghdl_rtin_block + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Block_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Block_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Parent, + Wki_Parent, Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Block_Size, + Get_Identifier ("size"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Nbr_Child, + Get_Identifier ("nbr_child"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Children, + Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Block); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_block"), + Ghdl_Rtin_Block); + end; + + -- type (type and subtype declarations). + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Name, + Get_Identifier ("name"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Scalar); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_scalar"), + Ghdl_Rtin_Type_Scalar); + end; + + -- Type_Enum + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Nbr, + Get_Identifier ("nbr"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Lits, + Get_Identifier ("lits"), + Char_Ptr_Array_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Enum); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_enum"), + Ghdl_Rtin_Type_Enum); + end; + + -- subtype_scalar + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Base, + Get_Identifier ("base"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Range, + Get_Identifier ("range"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Scalar); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_scalar"), + Ghdl_Rtin_Subtype_Scalar); + end; + + -- Unit64 + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Value, + Wki_Val, Ghdl_I64_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Unit64); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_unit64"), + Ghdl_Rtin_Unit64); + end; + + -- Unitptr + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Value, + Get_Identifier ("addr"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Unitptr); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_unitptr"), + Ghdl_Rtin_Unitptr); + end; + + -- Physical type. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Nbr, + Get_Identifier ("nbr"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Units, + Get_Identifier ("units"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Physical); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_physical"), + Ghdl_Rtin_Type_Physical); + end; + + -- file and access type. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Base, + Get_Identifier ("base"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Fileacc); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_fileacc"), + Ghdl_Rtin_Type_Fileacc); + end; + + -- arraytype. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Element, + Get_Identifier ("element"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Nbrdim, + Get_Identifier ("nbr_dim"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Indexes, + Get_Identifier ("indexes"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_array"), + Ghdl_Rtin_Type_Array); + end; + + -- subtype_Array. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Basetype, + Get_Identifier ("basetype"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Bounds, + Get_Identifier ("bounds"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Valsize, + Get_Identifier ("val_size"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Sigsize, + Get_Identifier ("sig_size"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_array"), + Ghdl_Rtin_Subtype_Array); + end; + + -- type record. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Nbrel, + Get_Identifier ("nbrel"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Elements, + Get_Identifier ("elements"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Record); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_record"), + Ghdl_Rtin_Type_Record); + end; + + -- record element. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Element_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Element_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Element_Type, + Get_Identifier ("eltype"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Element_Valoff, + Get_Identifier ("val_off"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Element_Sigoff, + Get_Identifier ("sig_off"), Ghdl_Index_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Element); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_element"), + Ghdl_Rtin_Element); + end; + + -- Object. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Object_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Object_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Object_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Object_Type, + Get_Identifier ("obj_type"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Object); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_object"), + Ghdl_Rtin_Object); + end; + + -- Instance. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Parent, + Wki_Parent, Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Type, + Get_Identifier ("instance"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Instance); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_instance"), + Ghdl_Rtin_Instance); + end; + + -- Component + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Component_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Component_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Component_Nbr_Child, + Get_Identifier ("nbr_child"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Component_Children, + Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Component); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_component"), + Ghdl_Rtin_Component); + end; + + end Rti_Initialize; + + type Rti_Array is array (1 .. 8) of O_Dnode; + type Rti_Array_List; + type Rti_Array_List_Acc is access Rti_Array_List; + type Rti_Array_List is record + Rtis : Rti_Array; + Next : Rti_Array_List_Acc; + end record; + + type Rti_Block is record + Depth : Rti_Depth_Type; + Nbr : Integer; + List : Rti_Array_List; + Last_List : Rti_Array_List_Acc; + Last_Nbr : Integer; + end record; + + Cur_Block : Rti_Block := (Depth => 0, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + + Free_List : Rti_Array_List_Acc := null; + + procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True) + is + Ndepth : Rti_Depth_Type; + begin + if Deeper then + Ndepth := Cur_Block.Depth + 1; + else + Ndepth := Cur_Block.Depth; + end if; + Prev := Cur_Block; + Cur_Block := (Depth => Ndepth, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + end Push_Rti_Node; + + procedure Add_Rti_Node (Node : O_Dnode) + is + begin + if Node = O_Dnode_Null then + -- FIXME: temporary for not yet handled types. + return; + end if; + if Cur_Block.Last_Nbr = Rti_Array'Last then + declare + N : Rti_Array_List_Acc; + begin + if Free_List = null then + N := new Rti_Array_List; + else + N := Free_List; + Free_List := N.Next; + end if; + N.Next := null; + if Cur_Block.Last_List = null then + Cur_Block.List.Next := N; + else + Cur_Block.Last_List.Next := N; + end if; + Cur_Block.Last_List := N; + end; + Cur_Block.Last_Nbr := 1; + else + Cur_Block.Last_Nbr := Cur_Block.Last_Nbr + 1; + end if; + if Cur_Block.Last_List = null then + Cur_Block.List.Rtis (Cur_Block.Last_Nbr) := Node; + else + Cur_Block.Last_List.Rtis (Cur_Block.Last_Nbr) := Node; + end if; + Cur_Block.Nbr := Cur_Block.Nbr + 1; + end Add_Rti_Node; + + function Generate_Rti_Array (Id : O_Ident) return O_Dnode + is + Arr_Type : O_Tnode; + List : O_Array_Aggr_List; + L : Rti_Array_List_Acc; + Nbr : Integer; + Val : O_Cnode; + Res : O_Dnode; + begin + Arr_Type := New_Constrained_Array_Type + (Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr + 1))); + New_Const_Decl (Res, Id, O_Storage_Private, Arr_Type); + Start_Const_Value (Res); + Start_Array_Aggr (List, Arr_Type); + Nbr := Cur_Block.Nbr; + for I in Cur_Block.List.Rtis'Range loop + exit when I > Nbr; + New_Array_Aggr_El + (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I), + Ghdl_Rti_Access)); + end loop; + L := Cur_Block.List.Next; + while L /= null loop + Nbr := Nbr - Cur_Block.List.Rtis'Length; + for I in L.Rtis'Range loop + exit when I > Nbr; + New_Array_Aggr_El + (List, New_Global_Unchecked_Address (L.Rtis (I), + Ghdl_Rti_Access)); + end loop; + L := L.Next; + end loop; + New_Array_Aggr_El (List, New_Null_Access (Ghdl_Rti_Access)); + Finish_Array_Aggr (List, Val); + Finish_Const_Value (Res, Val); + return Res; + end Generate_Rti_Array; + + procedure Pop_Rti_Node (Prev : Rti_Block) + is + L : Rti_Array_List_Acc; + begin + L := Cur_Block.List.Next; + if L /= null then + Cur_Block.Last_List.Next := Free_List; + Free_List := Cur_Block.List.Next; + Cur_Block.List.Next := null; + end if; + Cur_Block := Prev; + end Pop_Rti_Node; + + function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type + is + begin + if Var = Null_Var or else Is_Var_Field (Var) then + return Cur_Block.Depth; + else + return 0; + end if; + end Get_Depth_From_Var; + + function Generate_Common + (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0) + return O_Cnode + is + List : O_Record_Aggr_List; + Res : O_Cnode; + Val : Unsigned_64; + begin + Start_Record_Aggr (List, Ghdl_Rti_Common); + New_Record_Aggr_El (List, Kind); + Val := Unsigned_64 (Get_Depth_From_Var (Var)); + New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, Val)); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); + New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, 0)); + Finish_Record_Aggr (List, Res); + return Res; + end Generate_Common; + + -- Same as Generat_Common but for types. + function Generate_Common_Type (Kind : O_Cnode; + Depth : Rti_Depth_Type; + Max_Depth : Rti_Depth_Type; + Mode : Natural := 0) + return O_Cnode + is + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Start_Record_Aggr (List, Ghdl_Rti_Common); + New_Record_Aggr_El (List, Kind); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Depth))); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Max_Depth))); + Finish_Record_Aggr (List, Res); + return Res; + end Generate_Common_Type; + + function Generate_Name (Node : Iir) return O_Dnode + is + use Name_Table; + Id : Name_Id; + begin + Id := Get_Identifier (Node); + if Is_Character (Id) then + Name_Buffer (1) := '''; + Name_Buffer (2) := Get_Character (Id); + Name_Buffer (3) := '''; + Name_Length := 3; + else + Image (Id); + end if; + return Create_String (Name_Buffer (1 .. Name_Length), + Create_Identifier ("RTISTR")); + end Generate_Name; + + function Get_Null_Loc return O_Cnode is + begin + return New_Null_Access (Ghdl_Ptr_Type); + end Get_Null_Loc; + + function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode + is + begin + if Is_Var_Field (Var) then + return Get_Var_Offset (Var, Ghdl_Ptr_Type); + else + return New_Global_Unchecked_Address (Get_Var_Label (Var), + Ghdl_Ptr_Type); + end if; + end Var_Acc_To_Loc; + + -- Generate a name constant for the name of type definition DEF. + -- If DEF is an anonymous subtype, returns O_LNODE_NULL. + -- Use function NEW_NAME_ADDRESS (defined below) to convert the + -- result into an address expression. + function Generate_Type_Name (Def : Iir) return O_Dnode + is + Decl : Iir; + begin + Decl := Get_Type_Declarator (Def); + if Decl /= Null_Iir then + return Generate_Name (Decl); + else + return O_Dnode_Null; + end if; + end Generate_Type_Name; + + -- Convert a name constant NAME into an address. + -- If NAME is O_LNODE_NULL, return a null address. + -- To be used with GENERATE_TYPE_NAME. + function New_Name_Address (Name : O_Dnode) return O_Cnode + is + begin + if Name = O_Dnode_Null then + return New_Null_Access (Char_Ptr_Type); + else + return New_Global_Unchecked_Address (Name, Char_Ptr_Type); + end if; + end New_Name_Address; + + function New_Rti_Address (Rti : O_Dnode) return O_Cnode is + begin + return New_Global_Unchecked_Address (Rti, Ghdl_Rti_Access); + end New_Rti_Address; + + -- Declare the RTI constant for type definition attached to INFO. + -- The only feature is not to declare it if it was already declared. + -- (due to an incomplete type declaration). + procedure Generate_Type_Rti (Info : Type_Info_Acc; Rti_Type : O_Tnode) + is + begin + if Info.Type_Rti = O_Dnode_Null then + New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + end if; + end Generate_Type_Rti; + + function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) + return O_Dnode; + + procedure Generate_Enumeration_Type_Definition (Atype : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Atype); + Val : O_Cnode; + begin + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Enum); + Info.T.Rti_Max_Depth := 0; + + if Global_Storage = O_Storage_External then + return; + end if; + + declare + Lit_List : constant Iir_List := + Get_Enumeration_Literal_List (Atype); + Nbr_Lit : constant Integer := Get_Nbr_Elements (Lit_List); + Lit : Iir; + + type Dnode_Array is array (Natural range <>) of O_Dnode; + Name_Lits : Dnode_Array (0 .. Nbr_Lit - 1); + Mark : Id_Mark_Type; + Name_Arr_Type : O_Tnode; + Name_Arr : O_Dnode; + + Arr_Aggr : O_Array_Aggr_List; + Rec_Aggr : O_Record_Aggr_List; + Kind : O_Cnode; + Name : O_Dnode; + begin + -- Generate name for each literal. + for I in Name_Lits'Range loop + Lit := Get_Nth_Element (Lit_List, I); + Push_Identifier_Prefix (Mark, Get_Identifier (Lit)); + Name_Lits (I) := Generate_Name (Lit); + Pop_Identifier_Prefix (Mark); + end loop; + + -- Generate array of names. + Name_Arr_Type := New_Constrained_Array_Type + (Char_Ptr_Array_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Lit))); + New_Const_Decl (Name_Arr, Create_Identifier ("RTINAMES"), + O_Storage_Private, Name_Arr_Type); + Start_Const_Value (Name_Arr); + Start_Array_Aggr (Arr_Aggr, Name_Arr_Type); + for I in Name_Lits'Range loop + New_Array_Aggr_El + (Arr_Aggr, New_Global_Address (Name_Lits (I), Char_Ptr_Type)); + end loop; + Finish_Array_Aggr (Arr_Aggr, Val); + Finish_Const_Value (Name_Arr, Val); + + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + case Info.Type_Mode is + when Type_Mode_B1 => + Kind := Ghdl_Rtik_Type_B1; + when Type_Mode_E8 => + Kind := Ghdl_Rtik_Type_E8; + when Type_Mode_E32 => + Kind := Ghdl_Rtik_Type_E32; + when others => + raise Internal_Error; + end case; + Start_Record_Aggr (Rec_Aggr, Ghdl_Rtin_Type_Enum); + New_Record_Aggr_El (Rec_Aggr, Generate_Common_Type (Kind, 0, 0)); + New_Record_Aggr_El (Rec_Aggr, New_Name_Address (Name)); + New_Record_Aggr_El + (Rec_Aggr, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Lit))); + New_Record_Aggr_El + (Rec_Aggr, + New_Global_Address (Name_Arr, Char_Ptr_Array_Ptr_Type)); + Finish_Record_Aggr (Rec_Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end; + end Generate_Enumeration_Type_Definition; + + procedure Generate_Scalar_Type_Definition (Atype : Iir; Name : O_Dnode) + is + Info : Type_Info_Acc; + Kind : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); + Info.T.Rti_Max_Depth := 0; + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Const_Value (Info.Type_Rti); + case Info.Type_Mode is + when Type_Mode_I32 => + Kind := Ghdl_Rtik_Type_I32; + when Type_Mode_I64 => + Kind := Ghdl_Rtik_Type_I64; + when Type_Mode_F64 => + Kind := Ghdl_Rtik_Type_F64; + when Type_Mode_P64 => + Kind := Ghdl_Rtik_Type_P64; + when others => + Error_Kind ("generate_scalar_type_definition", Atype); + end case; + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (List, Generate_Common_Type (Kind, 0, 0)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Scalar_Type_Definition; + + procedure Generate_Unit_Declaration (Unit : Iir_Unit_Declaration) + is + Name : O_Dnode; + Mark : Id_Mark_Type; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Const : O_Dnode; + Info : constant Object_Info_Acc := Get_Info (Unit); + Rti_Type : O_Tnode; + Rtik : O_Cnode; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Unit)); + Name := Generate_Name (Unit); + if Info /= null then + -- Non-static units. The only possibility is a unit of + -- std.standard.time. + Rti_Type := Ghdl_Rtin_Unitptr; + Rtik := Ghdl_Rtik_Unitptr; + else + Rti_Type := Ghdl_Rtin_Unit64; + Rtik := Ghdl_Rtik_Unit64; + end if; + New_Const_Decl (Const, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + Start_Const_Value (Const); + Start_Record_Aggr (Aggr, Rti_Type); + New_Record_Aggr_El (Aggr, Generate_Common (Rtik)); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + if Info /= null then + -- Handle non-static units. The only possibility is a unit of + -- std.standard.time. + Val := New_Global_Unchecked_Address + (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type); + else + Val := Chap7.Translate_Numeric_Literal (Unit, Ghdl_I64_Type); + end if; + New_Record_Aggr_El (Aggr, Val); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Const, Val); + Add_Rti_Node (Const); + Pop_Identifier_Prefix (Mark); + end Generate_Unit_Declaration; + + procedure Generate_Physical_Type_Definition (Atype : Iir; Name : O_Dnode) + is + Info : Type_Info_Acc; + Val : O_Cnode; + List : O_Record_Aggr_List; + Prev : Rti_Block; + Unit : Iir_Unit_Declaration; + Nbr_Units : Integer; + Unit_Arr : O_Dnode; + Rti_Kind : O_Cnode; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Physical); + + if Global_Storage = O_Storage_External then + return; + end if; + + Push_Rti_Node (Prev, False); + Unit := Get_Unit_Chain (Atype); + Nbr_Units := 0; + while Unit /= Null_Iir loop + Generate_Unit_Declaration (Unit); + Nbr_Units := Nbr_Units + 1; + Unit := Get_Chain (Unit); + end loop; + Unit_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + Pop_Rti_Node (Prev); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Physical); + case Info.Type_Mode is + when Type_Mode_P64 => + Rti_Kind := Ghdl_Rtik_Type_P64; + when Type_Mode_P32 => + Rti_Kind := Ghdl_Rtik_Type_P32; + when others => + raise Internal_Error; + end case; + New_Record_Aggr_El (List, Generate_Common_Type (Rti_Kind, 0, 0, 0)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Units))); + New_Record_Aggr_El + (List, New_Global_Address (Unit_Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Physical_Type_Definition; + + procedure Generate_Scalar_Subtype_Definition (Atype : Iir) + is + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Name : O_Dnode; + begin + Info := Get_Info (Atype); + + if Global_Storage = O_Storage_External then + Name := O_Dnode_Null; + else + Name := Generate_Type_Name (Atype); + end if; + + -- Generate base type definition, if necessary. + -- (do it even in packages). + Base_Type := Get_Base_Type (Atype); + Base_Info := Get_Info (Base_Type); + if Base_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "BT"); + if Get_Kind (Base_Type) = Iir_Kind_Physical_Type_Definition then + Generate_Physical_Type_Definition (Base_Type, Name); + else + Generate_Scalar_Type_Definition (Base_Type, Name); + end if; + Pop_Identifier_Prefix (Mark); + end; + end if; + + Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Scalar); + Info.T.Rti_Max_Depth := Get_Depth_From_Var (Info.T.Range_Var); + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Scalar); + New_Record_Aggr_El + (Aggr, Generate_Common_Type (Ghdl_Rtik_Subtype_Scalar, + Info.T.Rti_Max_Depth, + Info.T.Rti_Max_Depth)); + + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); + New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Info.T.Range_Var)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Scalar_Subtype_Definition; + + procedure Generate_Fileacc_Type_Definition (Atype : Iir) + is + Info : Type_Info_Acc; + Kind : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + Name : O_Dnode; + Base : O_Dnode; + Base_Type : Iir; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Fileacc); + + if Global_Storage = O_Storage_External then + return; + end if; + + case Get_Kind (Atype) is + when Iir_Kind_Access_Type_Definition => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "AT"); + Base := Generate_Type_Definition + (Get_Designated_Type (Atype)); + Pop_Identifier_Prefix (Mark); + end; + if Get_Kind (Atype) = Iir_Kind_Access_Subtype_Definition then + Kind := Ghdl_Rtik_Subtype_Access; + else + Kind := Ghdl_Rtik_Type_Access; + end if; + -- Don't bother with designated type. This at least avoid + -- loops. + Base_Type := Null_Iir; + when Iir_Kind_File_Type_Definition => + Base_Type := Get_Type (Get_File_Type_Mark (Atype)); + Base := Generate_Type_Definition (Base_Type); + Kind := Ghdl_Rtik_Type_File; + when Iir_Kind_Record_Subtype_Definition => + Base_Type := Get_Base_Type (Atype); + Base := Get_Info (Base_Type).Type_Rti; + Kind := Ghdl_Rtik_Subtype_Record; + when Iir_Kind_Access_Subtype_Definition => + Base_Type := Get_Base_Type (Atype); + Base := Get_Info (Base_Type).Type_Rti; + Kind := Ghdl_Rtik_Subtype_Access; + when others => + Error_Kind ("rti.generate_fileacc_type_definition", Atype); + end case; + if Base_Type = Null_Iir then + Info.T.Rti_Max_Depth := 0; + else + Info.T.Rti_Max_Depth := Get_Info (Base_Type).T.Rti_Max_Depth; + end if; + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Fileacc); + New_Record_Aggr_El + (List, Generate_Common_Type (Kind, 0, Info.T.Rti_Max_Depth)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + New_Record_Aggr_El (List, New_Rti_Address (Base)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Fileacc_Type_Definition; + + procedure Generate_Array_Type_Indexes + (Atype : Iir; Res : out O_Dnode; Max_Depth : in out Rti_Depth_Type) + is + List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Indexes : constant Natural := Get_Nbr_Elements (List); + Index : Iir; + Tmp : O_Dnode; + pragma Unreferenced (Tmp); + Arr_Type : O_Tnode; + Arr_Aggr : O_Array_Aggr_List; + Val : O_Cnode; + Mark : Id_Mark_Type; + begin + -- Translate each index. + for I in 1 .. Nbr_Indexes loop + Index := Get_Index_Type (List, I - 1); + Push_Identifier_Prefix (Mark, "DIM", Iir_Int32 (I)); + Tmp := Generate_Type_Definition (Index); + Max_Depth := Rti_Depth_Type'Max (Max_Depth, + Get_Info (Index).T.Rti_Max_Depth); + Pop_Identifier_Prefix (Mark); + end loop; + + -- Generate array of index. + Arr_Type := New_Constrained_Array_Type + (Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Indexes))); + New_Const_Decl (Res, Create_Identifier ("RTIINDEXES"), + Global_Storage, Arr_Type); + Start_Const_Value (Res); + + Start_Array_Aggr (Arr_Aggr, Arr_Type); + for I in 1 .. Nbr_Indexes loop + Index := Get_Index_Type (List, I - 1); + New_Array_Aggr_El + (Arr_Aggr, New_Rti_Address (Generate_Type_Definition (Index))); + end loop; + Finish_Array_Aggr (Arr_Aggr, Val); + Finish_Const_Value (Res, Val); + end Generate_Array_Type_Indexes; + + function Type_To_Mode (Atype : Iir) return Natural is + Res : Natural := 0; + begin + if Is_Complex_Type (Get_Info (Atype)) then + Res := Res + 1; + end if; + if Is_Anonymous_Type_Definition (Atype) + or else (Get_Kind (Get_Type_Declarator (Atype)) + = Iir_Kind_Anonymous_Type_Declaration) + then + Res := Res + 2; + end if; + return Res; + end Type_To_Mode; + + procedure Generate_Array_Type_Definition + (Atype : Iir_Array_Type_Definition) + is + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + List : Iir_List; + Arr : O_Dnode; + Element : Iir; + Name : O_Dnode; + El_Info : Type_Info_Acc; + Max_Depth : Rti_Depth_Type; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Array); + + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + Element := Get_Element_Subtype (Atype); + El_Info := Get_Info (Element); + if El_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + El_Rti : O_Dnode; + pragma Unreferenced (El_Rti); + begin + Push_Identifier_Prefix (Mark, "EL"); + El_Rti := Generate_Type_Definition (Element); + Pop_Identifier_Prefix (Mark); + end; + end if; + Max_Depth := El_Info.T.Rti_Max_Depth; + + -- Translate each index. + Generate_Array_Type_Indexes (Atype, Arr, Max_Depth); + Info.T.Rti_Max_Depth := Max_Depth; + List := Get_Index_Subtype_List (Atype); + + -- Generate node. + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Array); + New_Record_Aggr_El + (Aggr, + Generate_Common_Type + (Ghdl_Rtik_Type_Array, 0, Max_Depth, Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti)); + New_Record_Aggr_El + (Aggr, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Get_Nbr_Elements (List)))); + New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Array_Type_Definition; + + procedure Generate_Array_Subtype_Definition + (Atype : Iir_Array_Subtype_Definition) + is + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Base_Rti : O_Dnode; + pragma Unreferenced (Base_Rti); + Bounds : Var_Type; + Name : O_Dnode; + Kind : O_Cnode; + Mark : Id_Mark_Type; + Depth : Rti_Depth_Type; + begin + -- FIXME: temporary work-around + if Get_Constraint_State (Atype) /= Fully_Constrained then + return; + end if; + + Info := Get_Info (Atype); + + Base_Type := Get_Base_Type (Atype); + Base_Info := Get_Info (Base_Type); + if Base_Info.Type_Rti = O_Dnode_Null then + Push_Identifier_Prefix (Mark, "BT"); + Base_Rti := Generate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + end if; + + Bounds := Info.T.Array_Bounds; + Depth := Get_Depth_From_Var (Bounds); + Info.T.Rti_Max_Depth := + Rti_Depth_Type'Max (Depth, Base_Info.T.Rti_Max_Depth); + + -- Generate node. + Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Array); + + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Array); + case Info.Type_Mode is + when Type_Mode_Array => + Kind := Ghdl_Rtik_Subtype_Array; + when Type_Mode_Fat_Array => + Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; + New_Record_Aggr_El + (Aggr, + Generate_Common_Type + (Kind, Depth, Info.T.Rti_Max_Depth, Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); + if Bounds = Null_Var then + Val := Get_Null_Loc; + else + Val := Var_Acc_To_Loc (Bounds); + end if; + New_Record_Aggr_El (Aggr, Val); + for I in Mode_Value .. Mode_Signal loop + case Info.Type_Mode is + when Type_Mode_Array => + Val := Get_Null_Loc; + if Info.Ortho_Type (I) /= O_Tnode_Null then + if Is_Complex_Type (Info) then + if Info.C (I).Size_Var /= Null_Var then + Val := Var_Acc_To_Loc (Info.C (I).Size_Var); + end if; + else + Val := New_Sizeof (Info.Ortho_Type (I), + Ghdl_Ptr_Type); + end if; + end if; + when Type_Mode_Fat_Array => + Val := Get_Null_Loc; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; + New_Record_Aggr_El (Aggr, Val); + end loop; + + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Array_Subtype_Definition; + + procedure Generate_Record_Type_Definition (Atype : Iir) + is + El_List : Iir_List; + El : Iir; + Prev : Rti_Block; + El_Arr : O_Dnode; + Res : O_Cnode; + Info : constant Type_Info_Acc := Get_Info (Atype); + Max_Depth : Rti_Depth_Type; + begin + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Record); + if Global_Storage = O_Storage_External then + return; + end if; + + El_List := Get_Elements_Declaration_List (Atype); + Max_Depth := 0; + + -- Generate elements. + Push_Rti_Node (Prev, False); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + declare + Type_Rti : O_Dnode; + El_Name : O_Dnode; + El_Type : constant Iir := Get_Type (El); + Aggr : O_Record_Aggr_List; + Field_Info : constant Field_Info_Acc := Get_Info (El); + Val : O_Cnode; + El_Const : O_Dnode; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + Type_Rti := Generate_Type_Definition (El_Type); + Max_Depth := + Rti_Depth_Type'Max (Max_Depth, + Get_Info (El_Type).T.Rti_Max_Depth); + + El_Name := Generate_Name (El); + New_Const_Decl (El_Const, Create_Identifier ("RTIEL"), + Global_Storage, Ghdl_Rtin_Element); + Start_Const_Value (El_Const); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Element); + New_Record_Aggr_El (Aggr, + Generate_Common (Ghdl_Rtik_Element)); + New_Record_Aggr_El (Aggr, New_Name_Address (El_Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Type_Rti)); + for I in Object_Kind_Type loop + if Field_Info.Field_Node (I) /= O_Fnode_Null then + Val := New_Offsetof (Info.Ortho_Type (I), + Field_Info.Field_Node (I), + Ghdl_Index_Type); + else + Val := Ghdl_Index_0; + end if; + New_Record_Aggr_El (Aggr, Val); + end loop; + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (El_Const, Val); + Add_Rti_Node (El_Const); + + Pop_Identifier_Prefix (Mark); + end; + end loop; + El_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + Pop_Rti_Node (Prev); + + Info.T.Rti_Max_Depth := Max_Depth; + -- Generate record. + declare + Aggr : O_Record_Aggr_List; + Name : O_Dnode; + begin + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record); + New_Record_Aggr_El + (Aggr, + Generate_Common_Type (Ghdl_Rtik_Type_Record, 0, Max_Depth, + Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El + (Aggr, New_Unsigned_Literal + (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List)))); + New_Record_Aggr_El (Aggr, + New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (Aggr, Res); + Finish_Const_Value (Info.Type_Rti, Res); + end; + end Generate_Record_Type_Definition; + + procedure Generate_Protected_Type_Declaration (Atype : Iir) + is + Info : Type_Info_Acc; + Name : O_Dnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + begin + Info := Get_Info (Atype); + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El + (List, + Generate_Common_Type (Ghdl_Rtik_Type_Protected, 0, 0, + Type_To_Mode (Atype))); + New_Record_Aggr_El (List, New_Name_Address (Name)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Protected_Type_Declaration; + + -- If FORCE is true, force the creation of the type RTI. + -- Otherwise, only the declaration (and not the definition) may have + -- been created. + function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) + return O_Dnode + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if not Force and then Info.Type_Rti /= O_Dnode_Null then + return Info.Type_Rti; + end if; + case Get_Kind (Atype) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + raise Internal_Error; + when Iir_Kind_Enumeration_Type_Definition => + Generate_Enumeration_Type_Definition (Atype); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Generate_Scalar_Subtype_Definition (Atype); + when Iir_Kind_Array_Type_Definition => + Generate_Array_Type_Definition (Atype); + when Iir_Kind_Array_Subtype_Definition => + Generate_Array_Subtype_Definition (Atype); + when Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + Generate_Fileacc_Type_Definition (Atype); + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + -- FIXME: No separate infos (yet). + null; + when Iir_Kind_Record_Type_Definition => + Generate_Record_Type_Definition (Atype); + when Iir_Kind_Protected_Type_Declaration => + Generate_Protected_Type_Declaration (Atype); + when others => + Error_Kind ("rti.generate_type_definition", Atype); + return O_Dnode_Null; + end case; + return Info.Type_Rti; + end Generate_Type_Definition; + + function Generate_Incomplete_Type_Definition (Def : Iir) + return O_Dnode + is + Ndef : constant Iir := Get_Type (Get_Type_Declarator (Def)); + Info : constant Type_Info_Acc := Get_Info (Ndef); + Rti_Type : O_Tnode; + begin + case Get_Kind (Ndef) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Scalar; + when Iir_Kind_Physical_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Physical; + when Iir_Kind_Enumeration_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Enum; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Rti_Type := Ghdl_Rtin_Subtype_Scalar; + when Iir_Kind_Array_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Array; + when Iir_Kind_Array_Subtype_Definition => + Rti_Type := Ghdl_Rtin_Subtype_Array; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Fileacc; + when Iir_Kind_Record_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Record; + when others => + Error_Kind ("rti.generate_incomplete_type_definition", Ndef); + end case; + New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + return Info.Type_Rti; + end Generate_Incomplete_Type_Definition; + + function Generate_Type_Decl (Decl : Iir) return O_Dnode + is + Id : constant Name_Id := Get_Identifier (Decl); + Def : constant Iir := Get_Type (Decl); + Rti : O_Dnode; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Id); + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + Rti := Generate_Incomplete_Type_Definition (Def); + else + Rti := Generate_Type_Definition (Def, True); + end if; + Pop_Identifier_Prefix (Mark); + return Rti; + end Generate_Type_Decl; + + procedure Generate_Signal_Rti (Sig : Iir) + is + Info : Object_Info_Acc; + begin + Info := Get_Info (Sig); + New_Const_Decl (Info.Object_Rti, Create_Identifier (Sig, "__RTI"), + Global_Storage, Ghdl_Rtin_Object); + end Generate_Signal_Rti; + + procedure Generate_Object (Decl : Iir; Rti : in out O_Dnode) + is + Decl_Type : Iir; + Type_Info : Type_Info_Acc; + Name : O_Dnode; + Comm : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + Info : Ortho_Info_Acc; + Mark : Id_Mark_Type; + Var : Var_Type; + Mode : Natural; + Has_Id : Boolean; + begin + case Get_Kind (Decl) is + when Iir_Kind_Transaction_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + Has_Id := False; + Push_Identifier_Prefix_Uniq (Mark); + when others => + Has_Id := True; + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + end case; + + if Rti = O_Dnode_Null then + New_Const_Decl (Rti, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Object); + end if; + + if Global_Storage /= O_Storage_External then + Decl_Type := Get_Type (Decl); + Type_Info := Get_Info (Decl_Type); + if Type_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + Tmp : O_Dnode; + pragma Unreferenced (Tmp); + begin + Push_Identifier_Prefix (Mark, "OT"); + Tmp := Generate_Type_Definition (Decl_Type); + Pop_Identifier_Prefix (Mark); + end; + end if; + + if Has_Id then + Name := Generate_Name (Decl); + else + Name := O_Dnode_Null; + end if; + + Info := Get_Info (Decl); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Object); + Mode := 0; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration => + Comm := Ghdl_Rtik_Signal; + Var := Info.Object_Var; + when Iir_Kind_Interface_Signal_Declaration => + Comm := Ghdl_Rtik_Port; + Var := Info.Object_Var; + Mode := Iir_Mode'Pos (Get_Mode (Decl)); + when Iir_Kind_Constant_Declaration => + Comm := Ghdl_Rtik_Constant; + Var := Info.Object_Var; + when Iir_Kind_Interface_Constant_Declaration => + Comm := Ghdl_Rtik_Generic; + Var := Info.Object_Var; + when Iir_Kind_Variable_Declaration => + Comm := Ghdl_Rtik_Variable; + Var := Info.Object_Var; + when Iir_Kind_Guard_Signal_Declaration => + Comm := Ghdl_Rtik_Guard; + Var := Info.Object_Var; + when Iir_Kind_Iterator_Declaration => + Comm := Ghdl_Rtik_Iterator; + Var := Info.Iterator_Var; + when Iir_Kind_File_Declaration => + Comm := Ghdl_Rtik_File; + Var := Info.Object_Var; + when Iir_Kind_Attribute_Declaration => + Comm := Ghdl_Rtik_Attribute; + Var := Null_Var; + when Iir_Kind_Transaction_Attribute => + Comm := Ghdl_Rtik_Attribute_Transaction; + Var := Info.Object_Var; + when Iir_Kind_Quiet_Attribute => + Comm := Ghdl_Rtik_Attribute_Quiet; + Var := Info.Object_Var; + when Iir_Kind_Stable_Attribute => + Comm := Ghdl_Rtik_Attribute_Stable; + Var := Info.Object_Var; + when Iir_Kind_Object_Alias_Declaration => + Comm := Ghdl_Rtik_Alias; + Var := Info.Alias_Var; + Mode := Object_Kind_Type'Pos (Info.Alias_Kind); + when others => + Error_Kind ("rti.generate_object", Decl); + end case; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Mode := Mode + + 16 * Iir_Signal_Kind'Pos (Get_Signal_Kind (Decl)); + when others => + null; + end case; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + if Get_Has_Active_Flag (Decl) then + Mode := Mode + 64; + end if; + when others => + null; + end case; + New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + if Var = Null_Var then + Val := Get_Null_Loc; + else + Val := Var_Acc_To_Loc (Var); + end if; + New_Record_Aggr_El (List, Val); + New_Record_Aggr_El (List, New_Rti_Address (Type_Info.Type_Rti)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Rti, Val); + end if; + Pop_Identifier_Prefix (Mark); + end Generate_Object; + + procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode); + procedure Generate_Declaration_Chain (Chain : Iir); + + procedure Generate_Component_Declaration (Comp : Iir) + is + Prev : Rti_Block; + Name : O_Dnode; + Arr : O_Dnode; + List : O_Record_Aggr_List; + Res : O_Cnode; + Mark : Id_Mark_Type; + Info : Comp_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Comp)); + Info := Get_Info (Comp); + + New_Const_Decl (Info.Comp_Rti_Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Component); + + if Global_Storage /= O_Storage_External then + Push_Rti_Node (Prev); + + Generate_Declaration_Chain (Get_Generic_Chain (Comp)); + Generate_Declaration_Chain (Get_Port_Chain (Comp)); + + Name := Generate_Name (Comp); + + Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + + Start_Const_Value (Info.Comp_Rti_Const); + Start_Record_Aggr (List, Ghdl_Rtin_Component); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Component)); + New_Record_Aggr_El (List, + New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr))); + New_Record_Aggr_El (List, + New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Info.Comp_Rti_Const, Res); + Pop_Rti_Node (Prev); + end if; + + Pop_Identifier_Prefix (Mark); + Add_Rti_Node (Info.Comp_Rti_Const); + end Generate_Component_Declaration; + + -- Generate RTIs only for types. + procedure Generate_Declaration_Chain_Depleted (Chain : Iir) + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Type_Declaration => + -- FIXME: physicals ? + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Enumeration_Type_Definition + then + Add_Rti_Node (Generate_Type_Decl (Decl)); + end if; + when Iir_Kind_Subtype_Declaration => + -- In a subprogram, a subtype may depends on parameters. + -- Eg: array subtypes. + null; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Stable_Attribute => + null; + when Iir_Kind_Delayed_Attribute => + -- FIXME: to be added. + null; + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- FIXME: to be added (for foreign). + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Anonymous_Type_Declaration => + -- Handled in subtype declaration. + null; + when Iir_Kind_Configuration_Specification + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when others => + Error_Kind ("rti.generate_declaration_chain_depleted", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Generate_Declaration_Chain_Depleted; + + procedure Generate_Subprogram_Body (Bod : Iir) + is + --Decl : Iir; + --Mark : Id_Mark_Type; + begin + --Decl := Get_Subprogram_Specification (Bod); + + --Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + -- Generate RTI only for types. + Generate_Declaration_Chain_Depleted (Get_Declaration_Chain (Bod)); + --Pop_Identifier_Prefix (Mark); + end Generate_Subprogram_Body; + + procedure Generate_Instance (Stmt : Iir; Parent : O_Dnode) + is + Name : O_Dnode; + List : O_Record_Aggr_List; + Val : O_Cnode; + Inst : constant Iir := Get_Instantiated_Unit (Stmt); + Info : constant Block_Info_Acc := Get_Info (Stmt); + begin + Name := Generate_Name (Stmt); + + New_Const_Decl (Info.Block_Rti_Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Instance); + + Start_Const_Value (Info.Block_Rti_Const); + Start_Record_Aggr (List, Ghdl_Rtin_Instance); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El + (List, New_Offsetof (Get_Scope_Type + (Get_Info (Get_Parent (Stmt)).Block_Scope), + Info.Block_Link_Field, + Ghdl_Ptr_Type)); + New_Record_Aggr_El (List, New_Rti_Address (Parent)); + if Is_Component_Instantiation (Stmt) then + Val := New_Rti_Address + (Get_Info (Get_Named_Entity (Inst)).Comp_Rti_Const); + else + declare + Ent : constant Iir := Get_Entity_From_Entity_Aspect (Inst); + begin + Val := New_Rti_Address (Get_Info (Ent).Block_Rti_Const); + end; + end if; + + New_Record_Aggr_El (List, Val); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Block_Rti_Const, Val); + Add_Rti_Node (Info.Block_Rti_Const); + end Generate_Instance; + + procedure Generate_Psl_Directive (Stmt : Iir) + is + Name : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + Res : O_Cnode; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Name := Generate_Name (Stmt); + + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Type_Scalar); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Psl_Assert)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Rti, Res); + Info.Psl_Rti_Const := Rti; + Pop_Identifier_Prefix (Mark); + end Generate_Psl_Directive; + + procedure Generate_Declaration_Chain (Chain : Iir) + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Anonymous_Type_Declaration => + -- Handled in subtype declaration. + null; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Add_Rti_Node (Generate_Type_Decl (Decl)); + when Iir_Kind_Constant_Declaration => + -- Do not generate RTIs for full declarations. + -- (RTI will be generated for the deferred declaration). + if Get_Deferred_Declaration (Decl) = Null_Iir + or else Get_Deferred_Declaration_Flag (Decl) + then + declare + Info : Object_Info_Acc; + begin + Info := Get_Info (Decl); + Generate_Object (Decl, Info.Object_Rti); + Add_Rti_Node (Info.Object_Rti); + end; + end if; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Stable_Attribute => + declare + Info : Object_Info_Acc; + begin + Info := Get_Info (Decl); + Generate_Object (Decl, Info.Object_Rti); + Add_Rti_Node (Info.Object_Rti); + end; + when Iir_Kind_Delayed_Attribute => + -- FIXME: to be added. + null; + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Attribute_Declaration => + declare + Rti : O_Dnode := O_Dnode_Null; + begin + Generate_Object (Decl, Rti); + Add_Rti_Node (Rti); + end; + when Iir_Kind_Component_Declaration => + Generate_Component_Declaration (Decl); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- FIXME: to be added (for foreign). + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- Already handled by Translate_Subprogram_Body. + null; + when Iir_Kind_Configuration_Specification + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when others => + Error_Kind ("rti.generate_declaration_chain", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Generate_Declaration_Chain; + + procedure Generate_Concurrent_Statement_Chain + (Chain : Iir; Parent_Rti : O_Dnode) + is + Stmt : Iir; + Mark : Id_Mark_Type; + begin + Stmt := Chain; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Generate_Block (Stmt, Parent_Rti); + Pop_Identifier_Prefix (Mark); + when Iir_Kind_Component_Instantiation_Statement => + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Generate_Instance (Stmt, Parent_Rti); + Pop_Identifier_Prefix (Mark); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement => + Generate_Psl_Directive (Stmt); + when Iir_Kind_Psl_Cover_Statement => + Generate_Psl_Directive (Stmt); + when others => + Error_Kind ("rti.generate_concurrent_statement_chain", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Generate_Concurrent_Statement_Chain; + + procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode) + is + Name : O_Dnode; + Arr : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + + Kind : O_Cnode; + Res : O_Cnode; + + Prev : Rti_Block; + Info : Ortho_Info_Acc; + + Field_Off : O_Cnode; + Inst : O_Tnode; + begin + -- The type of a generator iterator is elaborated in the parent. + if Get_Kind (Blk) = Iir_Kind_Generate_Statement then + declare + Scheme : Iir; + Iter_Type : Iir; + Type_Info : Type_Info_Acc; + Mark : Id_Mark_Type; + Tmp : O_Dnode; + begin + Scheme := Get_Generation_Scheme (Blk); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Type_Info := Get_Info (Iter_Type); + if Type_Info.Type_Rti = O_Dnode_Null then + Push_Identifier_Prefix (Mark, "ITERATOR"); + Tmp := Generate_Type_Definition (Iter_Type); + Add_Rti_Node (Tmp); + Pop_Identifier_Prefix (Mark); + end if; + end if; + end; + end if; + + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Block); + Push_Rti_Node (Prev); + + Field_Off := O_Cnode_Null; + Inst := O_Tnode_Null; + Info := Get_Info (Blk); + case Get_Kind (Blk) is + when Iir_Kind_Package_Declaration => + Kind := Ghdl_Rtik_Package; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + when Iir_Kind_Package_Body => + Kind := Ghdl_Rtik_Package_Body; + -- Required at least for 'image + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + when Iir_Kind_Architecture_Body => + Kind := Ghdl_Rtik_Architecture; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Info.Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); + when Iir_Kind_Entity_Declaration => + Kind := Ghdl_Rtik_Entity; + Generate_Declaration_Chain (Get_Generic_Chain (Blk)); + Generate_Declaration_Chain (Get_Port_Chain (Blk)); + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Kind := Ghdl_Rtik_Process; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Field_Off := + Get_Scope_Offset (Info.Process_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Process_Scope); + when Iir_Kind_Block_Statement => + Kind := Ghdl_Rtik_Block; + declare + Guard : constant Iir := Get_Guard_Decl (Blk); + Header : constant Iir := Get_Block_Header (Blk); + Guard_Info : Object_Info_Acc; + begin + if Guard /= Null_Iir then + Guard_Info := Get_Info (Guard); + Generate_Object (Guard, Guard_Info.Object_Rti); + Add_Rti_Node (Guard_Info.Object_Rti); + end if; + if Header /= Null_Iir then + Generate_Declaration_Chain (Get_Generic_Chain (Header)); + Generate_Declaration_Chain (Get_Port_Chain (Header)); + end if; + end; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Field_Off := Get_Scope_Offset (Info.Block_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Block_Scope); + when Iir_Kind_Generate_Statement => + declare + Scheme : constant Iir := Get_Generation_Scheme (Blk); + Scheme_Rti : O_Dnode := O_Dnode_Null; + begin + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Generate_Object (Scheme, Scheme_Rti); + Add_Rti_Node (Scheme_Rti); + Kind := Ghdl_Rtik_For_Generate; + else + Kind := Ghdl_Rtik_If_Generate; + end if; + end; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); + when others => + Error_Kind ("rti.generate_block", Blk); + end case; + + Name := Generate_Name (Blk); + + Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Block); + New_Record_Aggr_El (List, Generate_Common (Kind)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + if Field_Off = O_Cnode_Null then + Field_Off := Get_Null_Loc; + end if; + New_Record_Aggr_El (List, Field_Off); + if Parent_Rti = O_Dnode_Null then + Res := New_Null_Access (Ghdl_Rti_Access); + else + Res := New_Rti_Address (Parent_Rti); + end if; + New_Record_Aggr_El (List, Res); + if Inst = O_Tnode_Null then + Res := Ghdl_Index_0; + else + Res := New_Sizeof (Inst, Ghdl_Index_Type); + end if; + New_Record_Aggr_El (List, Res); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr))); + New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Rti, Res); + + Pop_Rti_Node (Prev); + + -- Put children in the parent list. + case Get_Kind (Blk) is + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Add_Rti_Node (Rti); + when others => + null; + end case; + + -- Store the RTI. + case Get_Kind (Blk) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Info.Block_Rti_Const := Rti; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Info.Process_Rti_Const := Rti; + when Iir_Kind_Package_Declaration => + Info.Package_Rti_Const := Rti; + when Iir_Kind_Package_Body => + -- Replace package declaration RTI with the body one. + Get_Info (Get_Package (Blk)).Package_Rti_Const := Rti; + when others => + Error_Kind ("rti.generate_block", Blk); + end case; + end Generate_Block; + + procedure Generate_Library (Lib : Iir_Library_Declaration; + Public : Boolean) + is + use Name_Table; + Info : Library_Info_Acc; + Id : Name_Id; + Val : O_Cnode; + Aggr : O_Record_Aggr_List; + Name : O_Dnode; + Storage : O_Storage; + begin + Info := Get_Info (Lib); + if Info /= null then + return; + end if; + Info := Add_Info (Lib, Kind_Library); + + if Lib = Libraries.Work_Library then + Id := Libraries.Work_Library_Name; + else + Id := Get_Identifier (Lib); + end if; + + if Public then + Storage := O_Storage_Public; + else + Storage := O_Storage_External; + end if; + + New_Const_Decl (Info.Library_Rti_Const, + Create_Identifier_Without_Prefix (Id, "__RTI"), + Storage, Ghdl_Rtin_Type_Scalar); + + if Public then + Image (Id); + Name := Create_String + (Name_Buffer (1 .. Name_Length), + Create_Identifier_Without_Prefix (Id, "__RTISTR")); + Start_Const_Value (Info.Library_Rti_Const); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Library)); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Library_Rti_Const, Val); + end if; + end Generate_Library; + + procedure Generate_Unit (Lib_Unit : Iir) + is + Rti : O_Dnode; + Info : Ortho_Info_Acc; + Mark : Id_Mark_Type; + begin + Info := Get_Info (Lib_Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Configuration_Declaration => + return; + when Iir_Kind_Architecture_Body => + if Info.Block_Rti_Const /= O_Dnode_Null then + return; + end if; + when Iir_Kind_Package_Body => + Push_Identifier_Prefix (Mark, "BODY"); + when others => + null; + end case; + + -- Declare node. + if Global_Storage = O_Storage_External then + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_External, Ghdl_Rtin_Block); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration => + declare + Prev : Rti_Block; + begin + Push_Rti_Node (Prev); + Generate_Declaration_Chain + (Get_Declaration_Chain (Lib_Unit)); + Pop_Rti_Node (Prev); + end; + when others => + null; + end case; + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body => + Info.Block_Rti_Const := Rti; + when Iir_Kind_Package_Declaration => + Info.Package_Rti_Const := Rti; + when Iir_Kind_Package_Body => + -- Replace package declaration RTI with the body one. + Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const := Rti; + when others => + null; + end case; + else + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration => + declare + Lib : Iir_Library_Declaration; + begin + Lib := Get_Library (Get_Design_File + (Get_Design_Unit (Lib_Unit))); + Generate_Library (Lib, False); + Rti := Get_Info (Lib).Library_Rti_Const; + end; + when Iir_Kind_Package_Body => + Rti := Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const; + when Iir_Kind_Architecture_Body => + Rti := Get_Info (Get_Entity (Lib_Unit)).Block_Rti_Const; + when others => + raise Internal_Error; + end case; + Generate_Block (Lib_Unit, Rti); + end if; + + if Get_Kind (Lib_Unit) = Iir_Kind_Package_Body then + Pop_Identifier_Prefix (Mark); + end if; + end Generate_Unit; + + procedure Generate_Top (Nbr_Pkgs : out Natural) + is + use Configuration; + + Unit : Iir_Design_Unit; + Lib : Iir_Library_Declaration; + Prev : Rti_Block; + begin + Push_Rti_Node (Prev); + + -- Generate RTI for libraries, count number of packages. + Nbr_Pkgs := 1; -- At least std.standard. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + + -- Generate RTI for the library. + Lib := Get_Library (Get_Design_File (Unit)); + Generate_Library (Lib, True); + + if Get_Kind (Get_Library_Unit (Unit)) + = Iir_Kind_Package_Declaration + then + Nbr_Pkgs := Nbr_Pkgs + 1; + end if; + end loop; + + Pop_Rti_Node (Prev); + end Generate_Top; + + function Get_Context_Rti (Node : Iir) return O_Cnode + is + Node_Info : Ortho_Info_Acc; + + Rti_Const : O_Dnode; + begin + Node_Info := Get_Info (Node); + + case Get_Kind (Node) is + when Iir_Kind_Component_Declaration => + Rti_Const := Node_Info.Comp_Rti_Const; + when Iir_Kind_Component_Instantiation_Statement => + Rti_Const := Node_Info.Block_Rti_Const; + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Rti_Const := Node_Info.Block_Rti_Const; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + Rti_Const := Node_Info.Package_Rti_Const; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Rti_Const := Node_Info.Process_Rti_Const; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Rti_Const := Node_Info.Psl_Rti_Const; + when others => + Error_Kind ("get_context_rti", Node); + end case; + return New_Rti_Address (Rti_Const); + end Get_Context_Rti; + + function Get_Context_Addr (Node : Iir) return O_Enode + is + Node_Info : constant Ortho_Info_Acc := Get_Info (Node); + Ref : O_Lnode; + begin + case Get_Kind (Node) is + when Iir_Kind_Component_Declaration => + Ref := Get_Instance_Ref (Node_Info.Comp_Scope); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Ref := Get_Instance_Ref (Node_Info.Block_Scope); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + return New_Lit (New_Null_Access (Ghdl_Ptr_Type)); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Ref := Get_Instance_Ref (Node_Info.Process_Scope); + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Ref := Get_Instance_Ref (Node_Info.Psl_Scope); + when others => + Error_Kind ("get_context_addr", Node); + end case; + return New_Unchecked_Address (Ref, Ghdl_Ptr_Type); + end Get_Context_Addr; + + procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir) + is + begin + New_Association (Assoc, New_Lit (Get_Context_Rti (Node))); + New_Association (Assoc, Get_Context_Addr (Node)); + end Associate_Rti_Context; + + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List) is + begin + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Rti_Access))); + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end Associate_Null_Rti_Context; + end Rtis; + + procedure Gen_Filename (Design_File : Iir) + is + Info : Design_File_Info_Acc; + begin + if Current_Filename_Node /= O_Dnode_Null then + raise Internal_Error; + end if; + Info := Get_Info (Design_File); + if Info = null then + Info := Add_Info (Design_File, Kind_Design_File); + Info.Design_Filename := Create_String + (Get_Design_File_Filename (Design_File), + Create_Uniq_Identifier, O_Storage_Private); + end if; + Current_Filename_Node := Info.Design_Filename; + end Gen_Filename; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Translate (Unit : Iir_Design_Unit; Main : Boolean) + is + Design_File : Iir_Design_File; + El : Iir; + Lib : Iir_Library_Declaration; + Lib_Mark, Ent_Mark, Sep_Mark, Unit_Mark : Id_Mark_Type; + Id : Name_Id; + begin + Update_Node_Infos; + + Design_File := Get_Design_File (Unit); + + if False then + El := Get_Context_Items (Unit); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Library_Clause => + null; + when others => + Error_Kind ("translate1", El); + end case; + El := Get_Chain (El); + end loop; + end if; + + El := Get_Library_Unit (Unit); + if Flags.Verbose then + Ada.Text_IO.Put ("translating "); + if Main then + Ada.Text_IO.Put ("(with code generation) "); + end if; + Ada.Text_IO.Put_Line (Disp_Node (El)); + end if; + + -- Create the prefix for identifiers. + Lib := Get_Library (Get_Design_File (Unit)); + Reset_Identifier_Prefix; + if Lib = Libraries.Work_Library then + Id := Libraries.Work_Library_Name; + else + Id := Get_Identifier (Lib); + end if; + Push_Identifier_Prefix (Lib_Mark, Id); + + if Get_Kind (El) = Iir_Kind_Architecture_Body then + -- Put 'ARCH' between the entity name and the architecture name, to + -- avoid a name clash with names from entity (eg an entity port with + -- the same name as an architecture). + Push_Identifier_Prefix (Ent_Mark, Get_Identifier (Get_Entity (El))); + Push_Identifier_Prefix (Sep_Mark, "ARCH"); + end if; + Id := Get_Identifier (El); + if Id /= Null_Identifier then + Push_Identifier_Prefix (Unit_Mark, Id); + end if; + + if Main then + Set_Global_Storage (O_Storage_Public); + -- Create the variable containing the current file name. + Gen_Filename (Get_Design_File (Unit)); + else + Set_Global_Storage (O_Storage_External); + end if; + + New_Debug_Filename_Decl + (Name_Table.Image (Get_Design_File_Filename (Design_File))); + + Current_Library_Unit := El; + + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + New_Debug_Comment_Decl + ("package declaration " & Image_Identifier (El)); + Chap2.Translate_Package_Declaration (El); + when Iir_Kind_Package_Body => + New_Debug_Comment_Decl ("package body " & Image_Identifier (El)); + Chap2.Translate_Package_Body (El); + when Iir_Kind_Package_Instantiation_Declaration => + New_Debug_Comment_Decl + ("package instantiation " & Image_Identifier (El)); + Chap2.Translate_Package_Instantiation_Declaration (El); + when Iir_Kind_Entity_Declaration => + New_Debug_Comment_Decl ("entity " & Image_Identifier (El)); + Chap1.Translate_Entity_Declaration (El); + when Iir_Kind_Architecture_Body => + New_Debug_Comment_Decl ("architecture " & Image_Identifier (El)); + Chap1.Translate_Architecture_Body (El); + when Iir_Kind_Configuration_Declaration => + New_Debug_Comment_Decl ("configuration " & Image_Identifier (El)); + if Id = Null_Identifier then + declare + Mark : Id_Mark_Type; + Mark_Entity : Id_Mark_Type; + Mark_Arch : Id_Mark_Type; + Mark_Sep : Id_Mark_Type; + Arch : Iir; + Entity : constant Iir := Get_Entity (El); + begin + -- Note: this is done inside the architecture identifier. + Push_Identifier_Prefix + (Mark_Entity, Get_Identifier (Entity)); + Arch := Get_Block_Specification + (Get_Block_Configuration (El)); + Push_Identifier_Prefix (Mark_Sep, "ARCH"); + Push_Identifier_Prefix (Mark_Arch, Get_Identifier (Arch)); + Push_Identifier_Prefix + (Mark, Name_Table.Get_Identifier ("DEFAULT_CONFIG")); + Chap1.Translate_Configuration_Declaration (El); + Pop_Identifier_Prefix (Mark); + Pop_Identifier_Prefix (Mark_Arch); + Pop_Identifier_Prefix (Mark_Sep); + Pop_Identifier_Prefix (Mark_Entity); + end; + else + Chap1.Translate_Configuration_Declaration (El); + end if; + when others => + Error_Kind ("translate", El); + end case; + + Current_Filename_Node := O_Dnode_Null; + Current_Library_Unit := Null_Iir; + + --Pop_Global_Factory; + if Id /= Null_Identifier then + Pop_Identifier_Prefix (Unit_Mark); + end if; + if Get_Kind (El) = Iir_Kind_Architecture_Body then + Pop_Identifier_Prefix (Sep_Mark); + Pop_Identifier_Prefix (Ent_Mark); + end if; + Pop_Identifier_Prefix (Lib_Mark); + end Translate; + + procedure Initialize + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + -- Create the node extension for translate. + Node_Infos.Init; + Node_Infos.Set_Last (4); + Node_Infos.Table (0 .. 4) := (others => null); + + -- Force to unnest subprograms is the code generator doesn't support + -- nested subprograms. + if not Ortho_Nodes.Has_Nested_Subprograms then + Flag_Unnest_Subprograms := True; + end if; + + New_Debug_Comment_Decl ("internal declarations, part 1"); + + -- Create well known identifiers. + Wki_This := Get_Identifier ("this"); + Wki_Size := Get_Identifier ("size"); + Wki_Res := Get_Identifier ("res"); + Wki_Dir_To := Get_Identifier ("dir_to"); + Wki_Dir_Downto := Get_Identifier ("dir_downto"); + Wki_Left := Get_Identifier ("left"); + Wki_Right := Get_Identifier ("right"); + Wki_Dir := Get_Identifier ("dir"); + Wki_Length := Get_Identifier ("length"); + Wki_I := Get_Identifier ("I"); + Wki_Instance := Get_Identifier ("INSTANCE"); + Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE"); + Wki_Name := Get_Identifier ("NAME"); + Wki_Sig := Get_Identifier ("sig"); + Wki_Obj := Get_Identifier ("OBJ"); + Wki_Rti := Get_Identifier ("RTI"); + Wki_Parent := Get_Identifier ("parent"); + Wki_Filename := Get_Identifier ("filename"); + Wki_Line := Get_Identifier ("line"); + Wki_Lo := Get_Identifier ("lo"); + Wki_Hi := Get_Identifier ("hi"); + Wki_Mid := Get_Identifier ("mid"); + Wki_Cmp := Get_Identifier ("cmp"); + Wki_Upframe := Get_Identifier ("UPFRAME"); + Wki_Frame := Get_Identifier ("FRAME"); + Wki_Val := Get_Identifier ("val"); + Wki_L_Len := Get_Identifier ("l_len"); + Wki_R_Len := Get_Identifier ("r_len"); + + Sizetype := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); + + -- Create __ghdl_index_type, which is the type for *all* array index. + Ghdl_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_index_type"), Ghdl_Index_Type); + + Ghdl_Index_0 := New_Unsigned_Literal (Ghdl_Index_Type, 0); + Ghdl_Index_1 := New_Unsigned_Literal (Ghdl_Index_Type, 1); + + Ghdl_I32_Type := New_Signed_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_i32"), Ghdl_I32_Type); + + Ghdl_Real_Type := New_Float_Type; + New_Type_Decl (Get_Identifier ("__ghdl_real"), Ghdl_Real_Type); + + if not Flag_Only_32b then + Ghdl_I64_Type := New_Signed_Type (64); + New_Type_Decl (Get_Identifier ("__ghdl_i64"), Ghdl_I64_Type); + end if; + + -- File index for elaborated file object. + Ghdl_File_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_file_index"), + Ghdl_File_Index_Type); + Ghdl_File_Index_Ptr_Type := New_Access_Type (Ghdl_File_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_file_index_ptr"), + Ghdl_File_Index_Ptr_Type); + + -- Create char, char [] and char *. + Char_Type_Node := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_char"), Char_Type_Node); + + Chararray_Type := New_Array_Type (Char_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_chararray"), Chararray_Type); + + Char_Ptr_Type := New_Access_Type (Chararray_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr"), Char_Ptr_Type); + + Char_Ptr_Array_Type := New_Array_Type (Char_Ptr_Type, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array"), + Char_Ptr_Array_Type); + + Char_Ptr_Array_Ptr_Type := New_Access_Type (Char_Ptr_Array_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array_ptr"), + Char_Ptr_Array_Ptr_Type); + + -- Generic pointer. + Ghdl_Ptr_Type := New_Access_Type (Char_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_ptr"), Ghdl_Ptr_Type); + + -- Create record + -- len : natural; + -- str : C_String; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Str_Len_Type_Len_Field, + Get_Identifier ("len"), Ghdl_Index_Type); + New_Record_Field + (Constr, Ghdl_Str_Len_Type_Str_Field, + Get_Identifier ("str"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len"), + Ghdl_Str_Len_Type_Node); + end; + + Ghdl_Str_Len_Array_Type_Node := New_Array_Type + (Ghdl_Str_Len_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_array"), + Ghdl_Str_Len_Array_Type_Node); + + -- Create type __ghdl_str_len_ptr is access all __ghdl_str_len + Ghdl_Str_Len_Ptr_Node := New_Access_Type (Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_ptr"), + Ghdl_Str_Len_Ptr_Node); + + -- Create type __ghdl_bool_type is (false, true) + New_Boolean_Type (Ghdl_Bool_Type, + Get_Identifier ("false"), + Ghdl_Bool_False_Node, + Get_Identifier ("true"), + Ghdl_Bool_True_Node); + New_Type_Decl (Get_Identifier ("__ghdl_bool_type"), + Ghdl_Bool_Type); + + -- __ghdl_bool_array is array (ghdl_index_type) of ghdl_bool_type + Ghdl_Bool_Array_Type := + New_Array_Type (Ghdl_Bool_Type, Ghdl_Index_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_type"), Ghdl_Bool_Array_Type); + + -- __ghdl_bool_array_ptr is access __ghdl_bool_array; + Ghdl_Bool_Array_Ptr := New_Access_Type (Ghdl_Bool_Array_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_ptr"), Ghdl_Bool_Array_Ptr); + + -- Create type ghdl_compare_type is (lt, eq, ge); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Get_Identifier ("lt"), Ghdl_Compare_Lt); + New_Enum_Literal (Constr, Get_Identifier ("eq"), Ghdl_Compare_Eq); + New_Enum_Literal (Constr, Get_Identifier ("gt"), Ghdl_Compare_Gt); + Finish_Enum_Type (Constr, Ghdl_Compare_Type); + New_Type_Decl (Get_Identifier ("__ghdl_compare_type"), + Ghdl_Compare_Type); + end; + + -- Create: + -- type __ghdl_location is record + -- file : char_ptr_type; + -- line : ghdl_i32; + -- col : ghdl_i32; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field + (Constr, Ghdl_Location_Filename_Node, Wki_Filename, Char_Ptr_Type); + New_Record_Field + (Constr, Ghdl_Location_Line_Node, Wki_Line, Ghdl_I32_Type); + New_Record_Field (Constr, Ghdl_Location_Col_Node, + Get_Identifier ("col"), + Ghdl_I32_Type); + Finish_Record_Type (Constr, Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location"), + Ghdl_Location_Type_Node); + end; + -- Create type __ghdl_location_ptr is access __ghdl_location; + Ghdl_Location_Ptr_Node := New_Access_Type (Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location_ptr"), + Ghdl_Location_Ptr_Node); + + -- Create type ghdl_dir_type is (dir_to, dir_downto); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Wki_Dir_To, Ghdl_Dir_To_Node); + New_Enum_Literal (Constr, Wki_Dir_Downto, Ghdl_Dir_Downto_Node); + Finish_Enum_Type (Constr, Ghdl_Dir_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_dir_type"), + Ghdl_Dir_Type_Node); + end; + + -- Create void* __ghdl_alloc (unsigned size); + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_alloc"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Sizetype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Alloc_Ptr); + + -- procedure __ghdl_program_error (filename : char_ptr_type; + -- line : ghdl_i32; + -- code : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_program_error"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("code"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Program_Error); + + -- procedure __ghdl_bound_check_failed_l1 (filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_bound_check_failed_l1"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Bound_Check_Failed_L1); + + -- Secondary stack subprograms. + -- function __ghdl_stack2_allocate (size : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_allocate"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Allocate); + + -- function __ghdl_stack2_mark return ghdl_ptr_type; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_stack2_mark"), + O_Storage_External, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Mark); + + -- procedure __ghdl_stack2_release (mark : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_release"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mark"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Release); + + -- procedure __ghdl_memcpy (dest : ghdl_ptr_type; + -- src : ghdl_ptr_type; + -- length : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_memcpy"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("dest"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Memcpy); + + -- procedure __ghdl_deallocate (ptr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_deallocate"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Deallocate); + + -- function __ghdl_malloc (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc); + + -- function __ghdl_malloc0 (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc0"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc0); + + -- function __ghdl_text_file_elaborate return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Elaborate); + + -- function __ghdl_file_elaborate (name : char_ptr_type) + -- return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Name, Char_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Elaborate); + + -- procedure __ghdl_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Finalize); + + -- procedure __ghdl_text_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Finalize); + + declare + procedure Create_Protected_Subprg + (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Protected_Subprg; + begin + -- procedure __ghdl_protected_enter (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_enter", Ghdl_Protected_Enter); + + -- procedure __ghdl_protected_leave (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_leave", Ghdl_Protected_Leave); + + Create_Protected_Subprg + ("__ghdl_protected_init", Ghdl_Protected_Init); + + Create_Protected_Subprg + ("__ghdl_protected_fini", Ghdl_Protected_Fini); + end; + + if Flag_Rti then + Rtis.Rti_Initialize; + end if; + + -- procedure __ghdl_signal_name_rti + -- (obj : ghdl_rti_access; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_name_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Name_Rti); + + declare + -- procedure NAME (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + procedure Create_Process_Register (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Process_Register; + begin + Create_Process_Register ("__ghdl_process_register", + Ghdl_Process_Register); + Create_Process_Register ("__ghdl_sensitized_process_register", + Ghdl_Sensitized_Process_Register); + Create_Process_Register ("__ghdl_postponed_process_register", + Ghdl_Postponed_Process_Register); + Create_Process_Register + ("__ghdl_postponed_sensitized_process_register", + Ghdl_Postponed_Sensitized_Process_Register); + end; + + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_finalize_register"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Finalize_Register); + end Initialize; + + procedure Create_Signal_Subprograms + (Suffix : String; + Val_Type : O_Tnode; + Create_Signal : out O_Dnode; + Init_Signal : out O_Dnode; + Simple_Assign : out O_Dnode; + Start_Assign : out O_Dnode; + Next_Assign : out O_Dnode; + Associate_Value : out O_Dnode; + Driving_Value : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + -- function __ghdl_create_signal_XXX (init_val : VAL_TYPE) + -- resolv_func : ghdl_ptr_type; + -- resolv_inst : ghdl_ptr_type; + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_signal_" & Suffix), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("init_val"), Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_func"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_inst"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Create_Signal); + + -- procedure __ghdl_signal_init_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_init_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); + Finish_Subprogram_Decl (Interfaces, Init_Signal); + + -- procedure __ghdl_signal_simple_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); + Finish_Subprogram_Decl (Interfaces, Simple_Assign); + + -- procedure __ghdl_signal_start_assign_XXX (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Start_Assign); + + -- procedure __ghdl_signal_next_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Next_Assign); + + -- procedure __ghdl_signal_associate_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_associate_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + Finish_Subprogram_Decl (Interfaces, Associate_Value); + + -- function __ghdl_signal_driving_value_XXX (sign : __ghdl_signal_ptr) + -- return VAL_TYPE; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving_value_" & Suffix), + O_Storage_External, Val_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Driving_Value); + end Create_Signal_Subprograms; + + -- procedure __ghdl_image_NAME (res : std_string_ptr_node; + -- val : VAL_TYPE; + -- rti : ghdl_rti_access); + -- + -- function __ghdl_value_NAME (val : std_string_ptr_node; + -- rti : ghdl_rti_access); + -- return VAL_TYPE; + procedure Create_Image_Value_Subprograms (Name : String; + Val_Type : O_Tnode; + Has_Td : Boolean; + Image_Subprg : out O_Dnode; + Value_Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_image_" & Name), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("res"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Val_Type); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Image_Subprg); + + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_value_" & Name), + O_Storage_External, Val_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Std_String_Ptr_Node); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Value_Subprg); + end Create_Image_Value_Subprograms; + + -- function __ghdl_std_ulogic_match_NAME (l : __ghdl_e8; r : __ghdl_e8) + -- return __ghdl_e8; + procedure Create_Std_Ulogic_Match_Subprogram (Name : String; + Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_std_ulogic_match_" & Name), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Std_Ulogic_Match_Subprogram; + + -- function __ghdl_std_ulogic_array_match_NAME + -- (l : __ghdl_ptr; l_len : ghdl_index_type; + -- r : __ghdl_ptr; r_len : ghdl_index_type) + -- return __ghdl_i32; + procedure Create_Std_Ulogic_Array_Match_Subprogram (Name : String; + Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_std_ulogic_array_match_" & Name), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_L_Len, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_R_Len, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Std_Ulogic_Array_Match_Subprogram; + + -- procedure NAME (res : std_string_ptr_node; + -- val : VAL_TYPE; + -- ARG2_NAME : ARG2_TYPE); + procedure Create_To_String_Subprogram (Name : String; + Subprg : out O_Dnode; + Val_Type : O_Tnode; + Arg2_Type : O_Tnode := O_Tnode_Null; + Arg2_Id : O_Ident := O_Ident_Nul; + Arg3_Type : O_Tnode := O_Tnode_Null; + Arg3_Id : O_Ident := O_Ident_Nul) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Val_Type); + if Arg2_Type /= O_Tnode_Null then + New_Interface_Decl + (Interfaces, Param, Arg2_Id, Arg2_Type); + if Arg3_Type /= O_Tnode_Null then + New_Interface_Decl + (Interfaces, Param, Arg3_Id, Arg3_Type); + end if; + end if; + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_To_String_Subprogram; + + -- Do internal declarations that need std.standard declarations. + procedure Post_Initialize + is + Interfaces : O_Inter_List; + Rec : O_Element_List; + Param : O_Dnode; + Info : Type_Info_Acc; + begin + New_Debug_Comment_Decl ("internal declarations, part 2"); + + -- Remember some pervasive types. + Info := Get_Info (String_Type_Definition); + Std_String_Node := Info.Ortho_Type (Mode_Value); + Std_String_Ptr_Node := Info.Ortho_Ptr_Type (Mode_Value); + + Std_Integer_Otype := + Get_Ortho_Type (Integer_Type_Definition, Mode_Value); + Std_Real_Otype := + Get_Ortho_Type (Real_Type_Definition, Mode_Value); + Std_Time_Otype := Get_Ortho_Type (Time_Type_Definition, Mode_Value); + + -- __ghdl_now : time; + -- ??? maybe this should be a function ? + New_Var_Decl (Ghdl_Now, Get_Identifier ("__ghdl_now"), + O_Storage_External, Std_Time_Otype); + + -- procedure __ghdl_assert_failed (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + + -- procedure __ghdl_report (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + declare + procedure Create_Report_Subprg (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("msg"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("severity"), + Get_Ortho_Type (Severity_Level_Type_Definition, Mode_Value)); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("location"), + Ghdl_Location_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Report_Subprg; + begin + Create_Report_Subprg + ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg + ("__ghdl_ieee_assert_failed", Ghdl_Ieee_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_assert_failed", + Ghdl_Psl_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_cover", Ghdl_Psl_Cover); + Create_Report_Subprg ("__ghdl_psl_cover_failed", + Ghdl_Psl_Cover_Failed); + Create_Report_Subprg ("__ghdl_report", Ghdl_Report); + end; + + -- procedure __ghdl_text_write (file : __ghdl_file_index; + -- str : std_string_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_write"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Write); + + -- function __ghdl_text_read_length (file : __ghdl_file_index; + -- str : std_string_ptr) + -- return std__standard_integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_read_length"), + O_Storage_External, Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Read_Length); + + -- procedure __ghdl_write_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_write_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Write_Scalar); + + -- procedure __ghdl_read_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_read_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Read_Scalar); + + -- function __ghdl_real_exp (left : std__standard__real; + -- right : std__standard__integer) + -- return std__standard__real; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_real_exp"), O_Storage_External, + Std_Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("left"), + Std_Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("right"), + Std_Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Real_Exp); + + -- function __ghdl_integer_exp (left : std__standard__integer; + -- right : std__standard__integer) + -- return std__standard__integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_integer_exp"), O_Storage_External, + Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Left, Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Integer_Exp); + + + -- procedure __ghdl_image_b1 (res : std_string_ptr_node; + -- val : ghdl_bool_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("b1", Ghdl_Bool_Type, True, Ghdl_Image_B1, Ghdl_Value_B1); + + -- procedure __ghdl_image_e8 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("e8", Ghdl_I32_Type, True, Ghdl_Image_E8, Ghdl_Value_E8); + + -- procedure __ghdl_image_e32 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("e32", Ghdl_I32_Type, True, Ghdl_Image_E32, Ghdl_Value_E32); + + -- procedure __ghdl_image_i32 (res : std_string_ptr_node; + -- val : ghdl_i32_type); + Create_Image_Value_Subprograms + ("i32", Ghdl_I32_Type, False, Ghdl_Image_I32, Ghdl_Value_I32); + + -- procedure __ghdl_image_p32 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("p32", Ghdl_I32_Type, True, Ghdl_Image_P32, Ghdl_Value_P32); + + -- procedure __ghdl_image_p64 (res : std_string_ptr_node; + -- val : ghdl_i64_type; + -- rti : ghdl_rti_access); + if not Flag_Only_32b then + Create_Image_Value_Subprograms + ("p64", Ghdl_I64_Type, True, Ghdl_Image_P64, Ghdl_Value_P64); + end if; + + -- procedure __ghdl_image_f64 (res : std_string_ptr_node; + -- val : ghdl_real_type); + Create_Image_Value_Subprograms + ("f64", Ghdl_Real_Type, False, Ghdl_Image_F64, Ghdl_Value_F64); + + ------------- + -- files -- + ------------- + + -- procedure __ghdl_text_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open); + + -- procedure __ghdl_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open); + + -- function __ghdl_text_file_open_status + -- (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open_Status); + + -- function __ghdl_file_open_status (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open_Status); + + -- function __ghdl_file_endfile (file : file_index_type) + -- return std_boolean_type_node; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_file_endfile"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Endfile); + + -- procedure __ghdl_text_file_close (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Close); + + -- procedure __ghdl_file_close (file : file_index_type); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Close); + + -- procedure __ghdl_file_flush (file : file_index_type); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_flush"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Flush); + + --------------- + -- signals -- + --------------- + + -- procedure __ghdl_signal_create_resolution + -- (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- sig : ghdl_ptr_type; + -- nbr_sig : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_resolution"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("nbr_sig"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Resolution); + + -- Declarations for signals. + -- Max length of a scalar type. + -- type __ghdl_scalar_bytes is __ghdl_chararray (0 .. 8); + Ghdl_Scalar_Bytes := New_Constrained_Array_Type + (Chararray_Type, New_Unsigned_Literal (Ghdl_Index_Type, 8)); + New_Type_Decl (Get_Identifier ("__ghdl_scalar_bytes"), + Ghdl_Scalar_Bytes); + + New_Uncomplete_Record_Type (Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal"), Ghdl_Signal_Type); + + Ghdl_Signal_Ptr := New_Access_Type (Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr"), Ghdl_Signal_Ptr); + + -- Type __signal_signal is record + Start_Uncomplete_Record_Type (Ghdl_Signal_Type, Rec); + New_Record_Field (Rec, Ghdl_Signal_Value_Field, + Get_Identifier ("value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Driving_Value_Field, + Get_Identifier ("driving_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Value_Field, + Get_Identifier ("last_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Event_Field, + Get_Identifier ("last_event"), + Std_Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Last_Active_Field, + Get_Identifier ("last_active"), + Std_Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Event_Field, + Get_Identifier ("event"), + Std_Boolean_Type_Node); + New_Record_Field (Rec, Ghdl_Signal_Active_Field, + Get_Identifier ("active"), + Std_Boolean_Type_Node); + New_Record_Field (Rec, Ghdl_Signal_Has_Active_Field, + Get_Identifier ("has_active"), + Ghdl_Bool_Type); + Finish_Record_Type (Rec, Ghdl_Signal_Type); + + Ghdl_Signal_Ptr_Ptr := New_Access_Type (Ghdl_Signal_Ptr); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr_ptr"), + Ghdl_Signal_Ptr_Ptr); + + -- procedure __ghdl_signal_merge_rti + -- (sig : ghdl_signal_ptr; rti : ghdl_rti_access) + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_merge_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Merge_Rti); + + -- procedure __ghdl_signal_add_source (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_add_source"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Source); + + -- procedure __ghdl_signal_effective_value (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_effective_value"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Effective_Value); + + -- procedure __ghdl_signal_set_disconnect (sig : __ghdl_signal_ptr; + -- val : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_set_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("time"), Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Set_Disconnect); + + -- procedure __ghdl_signal_disconnect (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Disconnect); + + -- function __ghdl_signal_get_nbr_drivers (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_drivers"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Drivers); + + -- function __ghdl_signal_get_nbr_sources (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_ports"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Ports); + + -- function __ghdl_signal_read_driver (sig : __ghdl_signal_ptr; + -- num : ghdl_index_type) + -- return ghdl_ptr_type; + declare + procedure Create_Signal_Read (Name : String; Subprg : out O_Dnode) is + begin + Start_Function_Decl + (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("num"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Signal_Read; + begin + Create_Signal_Read + ("__ghdl_signal_read_driver", Ghdl_Signal_Read_Driver); + Create_Signal_Read + ("__ghdl_signal_read_port", Ghdl_Signal_Read_Port); + end; + + -- function __ghdl_signal_driving (sig : __ghdl_signal_ptr) + -- return std_boolean; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Driving); + + -- procedure __ghdl_signal_simple_assign_error + -- (sig : __ghdl_signal_ptr; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Simple_Assign_Error); + + -- procedure __ghdl_signal_start_assign_error (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Error); + + -- procedure __ghdl_signal_next_assign_error (sig : __ghdl_signal_ptr; + -- after : std_time; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Error); + + -- procedure __ghdl_signal_start_assign_null (sig : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Null); + + -- procedure __ghdl_signal_next_assign_null (sig : __ghdl_signal_ptr; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Null); + + -- function __ghdl_create_signal_e8 (init_val : ghdl_i32_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_e8 (sign : __ghdl_signal_ptr; + -- val : __ghdl_integer); + Create_Signal_Subprograms ("e8", Ghdl_I32_Type, + Ghdl_Create_Signal_E8, + Ghdl_Signal_Init_E8, + Ghdl_Signal_Simple_Assign_E8, + Ghdl_Signal_Start_Assign_E8, + Ghdl_Signal_Next_Assign_E8, + Ghdl_Signal_Associate_E8, + Ghdl_Signal_Driving_Value_E8); + + -- function __ghdl_create_signal_e32 (init_val : ghdl_i32_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_e32 (sign : __ghdl_signal_ptr; + -- val : __ghdl_integer); + Create_Signal_Subprograms ("e32", Ghdl_I32_Type, + Ghdl_Create_Signal_E32, + Ghdl_Signal_Init_E32, + Ghdl_Signal_Simple_Assign_E32, + Ghdl_Signal_Start_Assign_E32, + Ghdl_Signal_Next_Assign_E32, + Ghdl_Signal_Associate_E32, + Ghdl_Signal_Driving_Value_E32); + + -- function __ghdl_create_signal_b1 (init_val : ghdl_bool_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_b1 (sign : __ghdl_signal_ptr; + -- val : ghdl_bool_type); + Create_Signal_Subprograms ("b1", Ghdl_Bool_Type, + Ghdl_Create_Signal_B1, + Ghdl_Signal_Init_B1, + Ghdl_Signal_Simple_Assign_B1, + Ghdl_Signal_Start_Assign_B1, + Ghdl_Signal_Next_Assign_B1, + Ghdl_Signal_Associate_B1, + Ghdl_Signal_Driving_Value_B1); + + Create_Signal_Subprograms ("i32", Ghdl_I32_Type, + Ghdl_Create_Signal_I32, + Ghdl_Signal_Init_I32, + Ghdl_Signal_Simple_Assign_I32, + Ghdl_Signal_Start_Assign_I32, + Ghdl_Signal_Next_Assign_I32, + Ghdl_Signal_Associate_I32, + Ghdl_Signal_Driving_Value_I32); + + Create_Signal_Subprograms ("f64", Ghdl_Real_Type, + Ghdl_Create_Signal_F64, + Ghdl_Signal_Init_F64, + Ghdl_Signal_Simple_Assign_F64, + Ghdl_Signal_Start_Assign_F64, + Ghdl_Signal_Next_Assign_F64, + Ghdl_Signal_Associate_F64, + Ghdl_Signal_Driving_Value_F64); + + if not Flag_Only_32b then + Create_Signal_Subprograms ("i64", Ghdl_I64_Type, + Ghdl_Create_Signal_I64, + Ghdl_Signal_Init_I64, + Ghdl_Signal_Simple_Assign_I64, + Ghdl_Signal_Start_Assign_I64, + Ghdl_Signal_Next_Assign_I64, + Ghdl_Signal_Associate_I64, + Ghdl_Signal_Driving_Value_I64); + end if; + + -- procedure __ghdl_process_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Sensitivity); + + -- procedure __ghdl_process_add_driver (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_driver"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Driver); + + -- procedure __ghdl_signal_add_direct_driver (sig : __ghdl_signal_ptr; + -- Drv : Ghdl_Ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_add_direct_driver"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("drv"), Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Direct_Driver); + + -- procedure __ghdl_signal_direct_assign (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_direct_assign"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Direct_Assign); + + declare + procedure Create_Signal_Conversion (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src_len"), Ghdl_Index_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst_len"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Conversion; + begin + -- procedure __ghdl_signal_in_conversion (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- src : ghdl_signal_ptr; + -- src_len : ghdl_index_type; + -- dst : ghdl_signal_ptr; + -- dst_len : ghdl_index_type); + Create_Signal_Conversion + ("__ghdl_signal_in_conversion", Ghdl_Signal_In_Conversion); + Create_Signal_Conversion + ("__ghdl_signal_out_conversion", Ghdl_Signal_Out_Conversion); + end; + + declare + -- function __ghdl_create_XXX_signal (val : std_time) + -- return __ghdl_signal_ptr; + procedure Create_Signal_Attribute (Name : String; Res : out O_Dnode) + is + begin + Start_Function_Decl (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Attribute; + begin + -- function __ghdl_create_stable_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_stable_signal", Ghdl_Create_Stable_Signal); + + -- function __ghdl_create_quiet_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_quiet_signal", Ghdl_Create_Quiet_Signal); + + -- function __ghdl_create_transaction_signal + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_transaction_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Transaction_Signal); + end; + + -- procedure __ghdl_signal_attribute_register_prefix + -- (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, + Get_Identifier ("__ghdl_signal_attribute_register_prefix"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl + (Interfaces, Ghdl_Signal_Attribute_Register_Prefix); + + -- function __ghdl_create_delayed_signal (sig : __ghdl_signal_ptr; + -- val : std_time) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_delayed_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("sig"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Delayed_Signal); + + -- function __ghdl_signal_create_guard + -- (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- instance_name : __ghdl_instance_name_acc) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_guard"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("this"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("proc"), + Ghdl_Ptr_Type); +-- New_Interface_Decl (Interfaces, Param, Get_Identifier ("instance_name"), +-- Ghdl_Instance_Name_Acc); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Guard); + + -- procedure __ghdl_signal_guard_dependence (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_guard_dependence"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Guard_Dependence); + + -- procedure __ghdl_process_wait_exit (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_exit"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Exit); + + -- void __ghdl_process_wait_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Timeout); + + -- void __ghdl_process_wait_set_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_set_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Set_Timeout); + + -- void __ghdl_process_wait_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Add_Sensitivity); + + -- function __ghdl_process_wait_suspend return __ghdl_bool_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_suspend"), + O_Storage_External, Ghdl_Bool_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Suspend); + + -- void __ghdl_process_wait_close (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_close"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Close); + + declare + procedure Create_Get_Name (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("name"), + Ghdl_Str_Len_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Get_Name; + begin + -- procedure __ghdl_get_path_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_path_name", Ghdl_Get_Path_Name); + + -- procedure __ghdl_get_instance_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_instance_name", Ghdl_Get_Instance_Name); + end; + + -- procedure __ghdl_rti_add_package (rti : ghdl_rti_access) + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_rti_add_package"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Package); + + -- procedure __ghdl_rti_add_top (max_pkgs : ghdl_index_type; + -- pkgs : ghdl_rti_arr_acc); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_rti_add_top"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("max_pkgs"), + Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("pkgs"), + Rtis.Ghdl_Rti_Arr_Acc); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + New_Interface_Decl + (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Top); + + -- Create match subprograms for std_ulogic type. + Create_Std_Ulogic_Match_Subprogram ("eq", Ghdl_Std_Ulogic_Match_Eq); + Create_Std_Ulogic_Match_Subprogram ("ne", Ghdl_Std_Ulogic_Match_Ne); + Create_Std_Ulogic_Match_Subprogram ("lt", Ghdl_Std_Ulogic_Match_Lt); + Create_Std_Ulogic_Match_Subprogram ("le", Ghdl_Std_Ulogic_Match_Le); + + Create_Std_Ulogic_Array_Match_Subprogram + ("eq", Ghdl_Std_Ulogic_Array_Match_Eq); + Create_Std_Ulogic_Array_Match_Subprogram + ("ne", Ghdl_Std_Ulogic_Array_Match_Ne); + + -- Create To_String subprograms. + Create_To_String_Subprogram + ("__ghdl_to_string_i32", Ghdl_To_String_I32, Ghdl_I32_Type); + Create_To_String_Subprogram + ("__ghdl_to_string_f64", Ghdl_To_String_F64, Ghdl_Real_Type); + Create_To_String_Subprogram + ("__ghdl_to_string_f64_digits", Ghdl_To_String_F64_Digits, + Ghdl_Real_Type, Ghdl_I32_Type, Get_Identifier ("nbr_digits")); + Create_To_String_Subprogram + ("__ghdl_to_string_f64_format", Ghdl_To_String_F64_Format, + Ghdl_Real_Type, Std_String_Ptr_Node, Get_Identifier ("format")); + declare + Bv_Base_Ptr : constant O_Tnode := + Get_Info (Bit_Vector_Type_Definition).T.Base_Ptr_Type (Mode_Value); + begin + Create_To_String_Subprogram + ("__ghdl_bv_to_ostring", Ghdl_BV_To_Ostring, + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); + Create_To_String_Subprogram + ("__ghdl_bv_to_hstring", Ghdl_BV_To_Hstring, + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); + end; + Create_To_String_Subprogram + ("__ghdl_to_string_b1", Ghdl_To_String_B1, Ghdl_Bool_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_e8", Ghdl_To_String_E8, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_char", Ghdl_To_String_Char, + Get_Ortho_Type (Character_Type_Definition, Mode_Value)); + Create_To_String_Subprogram + ("__ghdl_to_string_e32", Ghdl_To_String_E32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p32", Ghdl_To_String_P32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p64", Ghdl_To_String_P64, Ghdl_I64_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_timue_to_string_unit", Ghdl_Time_To_String_Unit, + Std_Time_Otype, Std_Time_Otype, Get_Identifier ("unit"), + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_b1", Ghdl_Array_Char_To_String_B1, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e8", Ghdl_Array_Char_To_String_E8, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e32", Ghdl_Array_Char_To_String_E32, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + + end Post_Initialize; + + procedure Translate_Type_Implicit_Subprograms (Decl : in out Iir) + is + Infos : Chap7.Implicit_Subprogram_Infos; + begin + -- Skip type declaration. + pragma Assert (Get_Kind (Decl) in Iir_Kinds_Type_Declaration); + Decl := Get_Chain (Decl); + + Chap7.Init_Implicit_Subprogram_Infos (Infos); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Chap7.Translate_Implicit_Subprogram (Decl, Infos); + Decl := Get_Chain (Decl); + when others => + exit; + end case; + end loop; + end Translate_Type_Implicit_Subprograms; + + procedure Translate_Standard (Main : Boolean) + is + Lib_Mark, Unit_Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + pragma Unreferenced (Info); + Decl : Iir; + Time_Type_Staticness : Iir_Staticness; + Time_Subtype_Staticness : Iir_Staticness; + begin + Update_Node_Infos; + + New_Debug_Comment_Decl ("package std.standard"); + if Main then + Gen_Filename (Std_Standard_File); + Set_Global_Storage (O_Storage_Public); + else + Set_Global_Storage (O_Storage_External); + end if; + + Info := Add_Info (Standard_Package, Kind_Package); + + Reset_Identifier_Prefix; + Push_Identifier_Prefix + (Lib_Mark, Get_Identifier (Libraries.Std_Library)); + Push_Identifier_Prefix + (Unit_Mark, Get_Identifier (Standard_Package)); + + -- With VHDL93 and later, time type is globally static. As a result, + -- it will be elaborated at run-time (and not statically). + -- However, there is no elaboration of std.standard. Furthermore, + -- time type can be pre-elaborated without any difficulties. + -- There is a kludge here: set type staticess of time type locally + -- and then revert it just after its translation. + Time_Type_Staticness := Get_Type_Staticness (Time_Type_Definition); + Time_Subtype_Staticness := Get_Type_Staticness (Time_Subtype_Definition); + if Flags.Flag_Time_64 then + Set_Type_Staticness (Time_Type_Definition, Locally); + end if; + Set_Type_Staticness (Time_Subtype_Definition, Locally); + if Flags.Vhdl_Std > Vhdl_87 then + Set_Type_Staticness (Delay_Length_Subtype_Definition, Locally); + end if; + + Decl := Get_Declaration_Chain (Standard_Package); + + -- The first (and one of the most important) declaration is the + -- boolean type declaration. + pragma Assert (Decl = Boolean_Type_Declaration); + Chap4.Translate_Bool_Type_Declaration (Boolean_Type_Declaration); + -- We need this type very early, for predefined functions. + Std_Boolean_Type_Node := + Get_Ortho_Type (Boolean_Type_Definition, Mode_Value); + Std_Boolean_True_Node := Get_Ortho_Expr (Boolean_True); + Std_Boolean_False_Node := Get_Ortho_Expr (Boolean_False); + + Std_Boolean_Array_Type := + New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"), + Std_Boolean_Array_Type); + Translate_Type_Implicit_Subprograms (Decl); + + -- Second declaration: bit. + pragma Assert (Decl = Bit_Type_Declaration); + Chap4.Translate_Bool_Type_Declaration (Bit_Type_Declaration); + Translate_Type_Implicit_Subprograms (Decl); + + -- Nothing special for other declarations. + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Type_Declaration => + Chap4.Translate_Type_Declaration (Decl); + Translate_Type_Implicit_Subprograms (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Chap4.Translate_Anonymous_Type_Declaration (Decl); + Translate_Type_Implicit_Subprograms (Decl); + when Iir_Kind_Subtype_Declaration => + Chap4.Translate_Subtype_Declaration (Decl); + Decl := Get_Chain (Decl); + when Iir_Kind_Attribute_Declaration => + Decl := Get_Chain (Decl); + when Iir_Kind_Implicit_Function_Declaration => + case Get_Implicit_Definition (Decl) is + when Iir_Predefined_Now_Function => + null; + when Iir_Predefined_Enum_To_String + | Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + -- These are defined after the types. + null; + when others => + Error_Kind + ("translate_standard (" + & Iir_Predefined_Functions'Image + (Get_Implicit_Definition (Decl)) & ")", + Decl); + end case; + Decl := Get_Chain (Decl); + when others => + Error_Kind ("translate_standard", Decl); + end case; + -- DECL was updated by Translate_Type_Implicit_Subprograms or + -- explicitly in other branches. + end loop; + + -- These types don't appear in std.standard. + Chap4.Translate_Anonymous_Type_Declaration + (Convertible_Integer_Type_Declaration); + Chap4.Translate_Anonymous_Type_Declaration + (Convertible_Real_Type_Declaration); + + -- Restore time type staticness. + + if Flags.Vhdl_Std > Vhdl_87 then + Set_Type_Staticness (Delay_Length_Subtype_Definition, + Time_Subtype_Staticness); + end if; + Set_Type_Staticness (Time_Type_Definition, Time_Type_Staticness); + Set_Type_Staticness (Time_Subtype_Definition, Time_Subtype_Staticness); + + if Flag_Rti then + Rtis.Generate_Unit (Standard_Package); + Std_Standard_Boolean_Rti + := Get_Info (Boolean_Type_Definition).Type_Rti; + Std_Standard_Bit_Rti + := Get_Info (Bit_Type_Definition).Type_Rti; + end if; + + -- Std_Ulogic indexed array of STD.Boolean. + -- Used by PSL to convert Std_Ulogic to boolean. + Std_Ulogic_Boolean_Array_Type := + New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Index_Lit (9)); + New_Type_Decl (Get_Identifier ("__ghdl_std_ulogic_boolean_array_type"), + Std_Ulogic_Boolean_Array_Type); + New_Const_Decl (Ghdl_Std_Ulogic_To_Boolean_Array, + Get_Identifier ("__ghdl_std_ulogic_to_boolean_array"), + O_Storage_External, Std_Ulogic_Boolean_Array_Type); + + Pop_Identifier_Prefix (Unit_Mark); + Pop_Identifier_Prefix (Lib_Mark); + + Post_Initialize; + Current_Filename_Node := O_Dnode_Null; + --Pop_Global_Factory; + end Translate_Standard; + + procedure Finalize + is + Info : Ortho_Info_Acc; + Prev_Info : Ortho_Info_Acc; + begin + Prev_Info := null; + for I in Node_Infos.First .. Node_Infos.Last loop + Info := Get_Info (I); + if Info /= null and then Info /= Prev_Info then + case Get_Kind (I) is + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration_Flag (I) = False + and then Get_Deferred_Declaration (I) /= Null_Iir + then + -- Info are copied from incomplete constant declaration + -- to full constant declaration. + Clear_Info (I); + else + Free_Info (I); + end if; + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Free_Type_Info (Info); + when Iir_Kind_Array_Subtype_Definition => + if Get_Index_Constraint_Flag (I) then + Info.T := Ortho_Info_Type_Array_Init; + Free_Type_Info (Info); + end if; + when Iir_Kind_Implicit_Function_Declaration => + case Get_Implicit_Definition (I) is + when Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => + -- Not in sequence. + null; + when others => + -- By default, info are not shared. + -- The exception is infos for implicit subprograms, + -- but they are always consecutive and not free twice + -- due to prev_info mechanism. + Free_Info (I); + end case; + when others => + -- By default, info are not shared. + Free_Info (I); + end case; + Prev_Info := Info; + end if; + end loop; + Node_Infos.Free; + Free_Old_Temp; + end Finalize; + + package body Chap12 is + -- Create __ghdl_ELABORATE + procedure Gen_Main (Entity : Iir_Entity_Declaration; + Arch : Iir_Architecture_Body; + Config_Subprg : O_Dnode; + Nbr_Pkgs : Natural) + is + Entity_Info : Block_Info_Acc; + Arch_Info : Block_Info_Acc; + Inter_List : O_Inter_List; + Assoc : O_Assoc_List; + Instance : O_Dnode; + Arch_Instance : O_Dnode; + Mark : Id_Mark_Type; + Arr_Type : O_Tnode; + Arr : O_Dnode; + begin + Arch_Info := Get_Info (Arch); + Entity_Info := Get_Info (Entity); + + -- We need to create code. + Set_Global_Storage (O_Storage_Private); + + -- Create the array of RTIs for packages (as a variable, initialized + -- during elaboration). + Arr_Type := New_Constrained_Array_Type + (Rtis.Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs))); + New_Var_Decl (Arr, Get_Identifier ("__ghdl_top_RTIARRAY"), + O_Storage_Private, Arr_Type); + + -- The elaboration entry point. + Start_Procedure_Decl (Inter_List, Get_Identifier ("__ghdl_ELABORATE"), + O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Ghdl_Elaborate); + + Start_Subprogram_Body (Ghdl_Elaborate); + New_Var_Decl (Arch_Instance, Wki_Arch_Instance, + O_Storage_Local, Arch_Info.Block_Decls_Ptr_Type); + + New_Var_Decl (Instance, Wki_Instance, O_Storage_Local, + Entity_Info.Block_Decls_Ptr_Type); + + -- Create instance for the architecture. + New_Assign_Stmt + (New_Obj (Arch_Instance), + Gen_Alloc (Alloc_System, + New_Lit (Get_Scope_Size (Arch_Info.Block_Scope)), + Arch_Info.Block_Decls_Ptr_Type)); + + -- Set the top instance. + New_Assign_Stmt + (New_Obj (Instance), + New_Address (New_Selected_Acc_Value (New_Obj (Arch_Instance), + Arch_Info.Block_Parent_Field), + Entity_Info.Block_Decls_Ptr_Type)); + + -- Clear parent field of entity link. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Instance), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Parent), + New_Lit (New_Null_Access (Rtis.Ghdl_Component_Link_Acc))); + + -- Set top instances and RTI. + -- Do it before the elaboration code, since it may be used to + -- diagnose errors. + -- Call ghdl_rti_add_top + Start_Association (Assoc, Ghdl_Rti_Add_Top); + New_Association + (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Pkgs)))); + New_Association + (Assoc, New_Lit (New_Global_Address (Arr, Rtis.Ghdl_Rti_Arr_Acc))); + New_Association + (Assoc, + New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const))); + New_Association + (Assoc, New_Convert_Ov (New_Obj_Value (Arch_Instance), + Ghdl_Ptr_Type)); + New_Procedure_Call (Assoc); + + -- Add std.standard rti + Start_Association (Assoc, Ghdl_Rti_Add_Package); + New_Association + (Assoc, + New_Lit (Rtis.New_Rti_Address + (Get_Info (Standard_Package).Package_Rti_Const))); + New_Procedure_Call (Assoc); + + Gen_Filename (Get_Design_File (Get_Design_Unit (Entity))); + + -- Elab package dependences of top entity (so that default + -- expressions can be evaluated). + Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); + New_Procedure_Call (Assoc); + + -- init instance + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Instance); + Push_Identifier_Prefix (Mark, ""); + Chap1.Translate_Entity_Init (Entity); + + -- elab instance + Start_Association (Assoc, Arch_Info.Block_Elab_Subprg); + New_Association (Assoc, New_Obj_Value (Instance)); + New_Procedure_Call (Assoc); + + --Chap6.Link_Instance_Name (Null_Iir, Entity); + + -- configure instance. + Start_Association (Assoc, Config_Subprg); + New_Association (Assoc, New_Obj_Value (Arch_Instance)); + New_Procedure_Call (Assoc); + + Pop_Identifier_Prefix (Mark); + Clear_Scope (Entity_Info.Block_Scope); + Finish_Subprogram_Body; + + Current_Filename_Node := O_Dnode_Null; + end Gen_Main; + + procedure Gen_Setup_Info + is + Cst : O_Dnode; + pragma Unreferenced (Cst); + begin + Cst := Create_String (Flags.Flag_String, + Get_Identifier ("__ghdl_flag_string"), + O_Storage_Public); + end Gen_Setup_Info; + + procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration) + is + Entity_Info : Block_Info_Acc; + + Arch : Iir_Architecture_Body; + Arch_Info : Block_Info_Acc; + + Lib : Iir_Library_Declaration; + Lib_Mark, Entity_Mark, Arch_Mark : Id_Mark_Type; + + Config : Iir_Configuration_Declaration; + Config_Info : Config_Info_Acc; + + Const : O_Dnode; + Instance : O_Dnode; + Inter_List : O_Inter_List; + Constr : O_Assoc_List; + Subprg : O_Dnode; + begin + Arch := Libraries.Get_Latest_Architecture (Entity); + if Arch = Null_Iir then + Error_Msg_Elab ("no architecture for " & Disp_Node (Entity)); + end if; + Arch_Info := Get_Info (Arch); + if Arch_Info = null then + -- Nothing to do here, since the architecture is not used. + return; + end if; + Entity_Info := Get_Info (Entity); + + -- Create trampoline for elab, default_architecture + -- re-create instsize. + Reset_Identifier_Prefix; + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); + Push_Identifier_Prefix (Arch_Mark, "LASTARCH"); + + -- Instance size. + New_Const_Decl + (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public, + Ghdl_Index_Type); + Start_Const_Value (Const); + Finish_Const_Value (Const, Get_Scope_Size (Arch_Info.Block_Scope)); + + -- Elaborator. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("ELAB"), O_Storage_Public); + New_Interface_Decl + (Inter_List, Instance, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Start_Association (Constr, Arch_Info.Block_Elab_Subprg); + New_Association (Constr, New_Obj_Value (Instance)); + New_Procedure_Call (Constr); + Finish_Subprogram_Body; + + -- Default config. + Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + Config_Info := Get_Info (Config); + if Config_Info /= null then + -- Do not create a trampoline for the default_config if it is not + -- used. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), + O_Storage_Public); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Arch_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Start_Association (Constr, Config_Info.Config_Subprg); + New_Association (Constr, New_Obj_Value (Instance)); + New_Procedure_Call (Constr); + Finish_Subprogram_Body; + end if; + + Pop_Identifier_Prefix (Arch_Mark); + Pop_Identifier_Prefix (Entity_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Last_Arch; + + procedure Gen_Dummy_Default_Config (Arch : Iir_Architecture_Body) + is + Entity : Iir_Entity_Declaration; + Lib : Iir_Library_Declaration; + Lib_Mark, Entity_Mark, Sep_Mark, Arch_Mark : Id_Mark_Type; + + Inter_List : O_Inter_List; + + Subprg : O_Dnode; + begin + Reset_Identifier_Prefix; + Entity := Get_Entity (Arch); + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Arch))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); + Push_Identifier_Prefix (Sep_Mark, "ARCH"); + Push_Identifier_Prefix (Arch_Mark, Get_Identifier (Arch)); + + -- Elaborator. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), + O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Chap6.Gen_Program_Error (Arch, Chap6.Prg_Err_Dummy_Config); + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Arch_Mark); + Pop_Identifier_Prefix (Sep_Mark); + Pop_Identifier_Prefix (Entity_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Dummy_Default_Config; + + procedure Gen_Dummy_Package_Declaration (Unit : Iir_Design_Unit) + is + Pkg : Iir_Package_Declaration; + Lib : Iir_Library_Declaration; + Lib_Mark, Pkg_Mark : Id_Mark_Type; + + Decl : Iir; + begin + Libraries.Load_Design_Unit (Unit, Null_Iir); + Pkg := Get_Library_Unit (Unit); + Reset_Identifier_Prefix; + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Pkg))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Pkg_Mark, Get_Identifier (Pkg)); + + if Get_Need_Body (Pkg) then + Decl := Get_Declaration_Chain (Pkg); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- Generate empty body. + + -- Never a second spec, as this is within a package + -- declaration. + pragma Assert + (not Is_Second_Subprogram_Specification (Decl)); + + if not Get_Foreign_Flag (Decl) then + declare + Mark : Id_Mark_Type; + Inter_List : O_Inter_List; + Proc : O_Dnode; + begin + Chap2.Push_Subprg_Identifier (Decl, Mark); + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Proc); + Start_Subprogram_Body (Proc); + Finish_Subprogram_Body; + Pop_Identifier_Prefix (Mark); + end; + end if; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end if; + + -- Create the body elaborator. + declare + Inter_List : O_Inter_List; + Proc : O_Dnode; + begin + Start_Procedure_Decl + (Inter_List, Create_Identifier ("ELAB_BODY"), O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Proc); + Start_Subprogram_Body (Proc); + Finish_Subprogram_Body; + end; + + Pop_Identifier_Prefix (Pkg_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Dummy_Package_Declaration; + + procedure Write_File_List (Filelist : String) + is + use Interfaces.C_Streams; + use System; + use Configuration; + use Name_Table; + + -- Add all dependences of UNIT. + -- UNIT is not used, but added during link. + procedure Add_Unit_Dependences (Unit : Iir_Design_Unit) + is + Dep_List : Iir_List; + Dep : Iir; + Dep_Unit : Iir_Design_Unit; + Lib_Unit : Iir; + begin + -- Load the unit in memory to compute the dependence list. + Libraries.Load_Design_Unit (Unit, Null_Iir); + Update_Node_Infos; + + Set_Elab_Flag (Unit, True); + Design_Units.Append (Unit); + + if Flag_Rti then + Rtis.Generate_Library + (Get_Library (Get_Design_File (Unit)), True); + end if; + + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + -- The body may be required due to incomplete constant + -- declarations, or to call to a subprogram. + declare + Pack_Body : Iir; + begin + Pack_Body := Libraries.Find_Secondary_Unit + (Unit, Null_Identifier); + if Pack_Body /= Null_Iir then + Add_Unit_Dependences (Pack_Body); + else + Gen_Dummy_Package_Declaration (Unit); + end if; + end; + when Iir_Kind_Architecture_Body => + Gen_Dummy_Default_Config (Lib_Unit); + when others => + null; + end case; + + Dep_List := Get_Dependence_List (Unit); + for I in Natural loop + Dep := Get_Nth_Element (Dep_List, I); + exit when Dep = Null_Iir; + Dep_Unit := Libraries.Find_Design_Unit (Dep); + if Dep_Unit = Null_Iir then + Error_Msg_Elab + ("could not find design unit " & Disp_Node (Dep)); + elsif not Get_Elab_Flag (Dep_Unit) then + Add_Unit_Dependences (Dep_Unit); + end if; + end loop; + end Add_Unit_Dependences; + + -- Add not yet added units of FILE. + procedure Add_File_Units (File : Iir_Design_File) + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if not Get_Elab_Flag (Unit) then + -- Unit not used. + Add_Unit_Dependences (Unit); + end if; + Unit := Get_Chain (Unit); + end loop; + end Add_File_Units; + + Nul : constant Character := Character'Val (0); + Fname : String := Filelist & Nul; + Mode : constant String := "wt" & Nul; + F : FILEs; + R : int; + S : size_t; + pragma Unreferenced (R, S); -- FIXME + Id : Name_Id; + Lib : Iir_Library_Declaration; + File : Iir_Design_File; + Unit : Iir_Design_Unit; + J : Natural; + begin + F := fopen (Fname'Address, Mode'Address); + if F = NULL_Stream then + Error_Msg_Elab ("cannot open " & Filelist); + end if; + + -- Set elab flags on units, and remove it on design files. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Set_Elab_Flag (Unit, True); + File := Get_Design_File (Unit); + Set_Elab_Flag (File, False); + end loop; + + J := Design_Units.First; + while J <= Design_Units.Last loop + Unit := Design_Units.Table (J); + File := Get_Design_File (Unit); + if not Get_Elab_Flag (File) then + Set_Elab_Flag (File, True); + + -- Add dependences of unused design units, otherwise the object + -- link case failed. + Add_File_Units (File); + + Lib := Get_Library (File); + R := fputc (Character'Pos ('>'), F); + Id := Get_Library_Directory (Lib); + S := fwrite (Get_Address (Id), + size_t (Get_Name_Length (Id)), 1, F); + R := fputc (10, F); + + Id := Get_Design_File_Filename (File); + S := fwrite (Get_Address (Id), + size_t (Get_Name_Length (Id)), 1, F); + R := fputc (10, F); + end if; + J := J + 1; + end loop; + end Write_File_List; + + procedure Elaborate + (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean) + is + use Name_Table; + use Configuration; + + Primary_Id : Name_Id; + Secondary_Id : Name_Id; + Unit : Iir_Design_Unit; + Lib_Unit : Iir; + Config : Iir_Design_Unit; + Config_Lib : Iir_Configuration_Declaration; + Entity : Iir_Entity_Declaration; + Arch : Iir_Architecture_Body; + Conf_Info : Config_Info_Acc; + Last_Design_Unit : Natural; + Nbr_Pkgs : Natural; + begin + Primary_Id := Get_Identifier (Primary); + if Secondary /= "" then + Secondary_Id := Get_Identifier (Secondary); + else + Secondary_Id := Null_Identifier; + end if; + Config := Configure (Primary_Id, Secondary_Id); + if Config = Null_Iir then + return; + end if; + Config_Lib := Get_Library_Unit (Config); + Entity := Get_Entity (Config_Lib); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config_Lib)); + + -- Be sure the entity can be at the top of a design. + Check_Entity_Declaration_Top (Entity); + + -- If all design units are loaded, late semantic checks can be + -- performed. + if Flag_Load_All_Design_Units then + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Sem.Sem_Analysis_Checks_List (Unit, False); + -- There cannot be remaining checks to do. + pragma Assert + (Get_Analysis_Checks_List (Unit) = Null_Iir_List); + end loop; + end if; + + -- Return now in case of errors. + if Nbr_Errors /= 0 then + return; + end if; + + if Flags.Verbose then + Ada.Text_IO.Put_Line ("List of units in the hierarchy design:"); + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); + end loop; + end if; + + if Whole then + -- In compile-and-elaborate mode, do not generate code for + -- unused subprograms. + -- FIXME: should be improved by creating a span-tree. + Flag_Discard_Unused := True; + Flag_Discard_Unused_Implicit := True; + end if; + + -- Generate_Library add infos, therefore the info array must be + -- adjusted. + Update_Node_Infos; + Rtis.Generate_Library (Libraries.Std_Library, True); + Translate_Standard (Whole); + + -- Translate all configurations needed. + -- Also, set the ELAB_FLAG on package with body. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + + if Whole then + -- In whole compilation mode, force to generate RTIS of + -- libraries. + Rtis.Generate_Library + (Get_Library (Get_Design_File (Unit)), True); + end if; + + case Get_Kind (Lib_Unit) is + when Iir_Kind_Configuration_Declaration => + -- Always generate code for configuration. + -- Because default binding may be changed between analysis + -- and elaboration. + Translate (Unit, True); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + -- For package spec, mark it as 'body is not present', this + -- flag will be set below when the body is translated. + Set_Elab_Flag (Unit, False); + Translate (Unit, Whole); + when Iir_Kind_Package_Body => + -- Mark the spec with 'body is present' flag. + Set_Elab_Flag + (Get_Design_Unit (Get_Package (Lib_Unit)), True); + Translate (Unit, Whole); + when others => + Error_Kind ("elaborate", Lib_Unit); + end case; + end loop; + + -- Generate code to elaboration body-less package. + -- + -- When a package is analyzed, we don't know wether there is body + -- or not. Therefore, we assume there is always a body, and will + -- elaborate the body (which elaborates its spec). If a package + -- has no body, create the body elaboration procedure. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + if not Get_Elab_Flag (Unit) then + Chap2.Elab_Package_Body (Lib_Unit, Null_Iir); + end if; + when Iir_Kind_Entity_Declaration => + Gen_Last_Arch (Lib_Unit); + when Iir_Kind_Architecture_Body + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + null; + when others => + Error_Kind ("elaborate(2)", Lib_Unit); + end case; + end loop; + + Rtis.Generate_Top (Nbr_Pkgs); + + -- Create main code. + Conf_Info := Get_Info (Config_Lib); + Gen_Main (Entity, Arch, Conf_Info.Config_Subprg, Nbr_Pkgs); + + Gen_Setup_Info; + + -- Index of the last design unit, required by the design. + Last_Design_Unit := Design_Units.Last; + + -- Disp list of files needed. + -- FIXME: extract the link completion part of WRITE_FILE_LIST. + if Filelist /= "" then + Write_File_List (Filelist); + end if; + + if Flags.Verbose then + Ada.Text_IO.Put_Line ("List of units not used:"); + for I in Last_Design_Unit + 1 .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); + end loop; + end if; + end Elaborate; + end Chap12; +end Translation; |