aboutsummaryrefslogtreecommitdiffstats
path: root/src/vhdl/translate/translation.adb
diff options
context:
space:
mode:
Diffstat (limited to 'src/vhdl/translate/translation.adb')
-rw-r--r--src/vhdl/translate/translation.adb31355
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;