diff options
Diffstat (limited to 'src/vhdl/translate/translation.adb')
| -rw-r--r-- | src/vhdl/translate/translation.adb | 25866 |
1 files changed, 12 insertions, 25854 deletions
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 9f0e416fb..2d89a62e1 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -15,12 +15,8 @@ -- along with GCC; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -with System; -with Ada.Unchecked_Deallocation; -with Interfaces; use Interfaces; with Ortho_Nodes; use Ortho_Nodes; with Ortho_Ident; use Ortho_Ident; -with Evaluation; use Evaluation; with Flags; use Flags; with Ada.Text_IO; with Types; use Types; @@ -29,29 +25,22 @@ with Name_Table; -- use Name_Table; with Iirs_Utils; use Iirs_Utils; with Std_Package; use Std_Package; with Libraries; -with Files_Map; with Std_Names; -with Configuration; -with Interfaces.C_Streams; -with Sem_Names; -with Sem_Inst; -with Sem; -with Iir_Chains; use Iir_Chains; -with Nodes_Meta; -with Ieee.Std_Logic_1164; -with Canon; -with Canon_PSL; -with PSL.Nodes; -with PSL.NFAs; -with PSL.NFAs.Utils; with Trans; with Trans_Decls; use Trans_Decls; -with Trans_Analyzes; +with Trans.Chap1; +with Trans.Chap2; +with Trans.Chap4; +with Trans.Chap7; +with Trans.Chap12; +with Trans.Rtis; +with Trans.Helpers2; package body Translation is use Trans; use Trans.Chap10; use Trans.Helpers; + use Trans.Helpers2; function Get_Ortho_Decl (Subprg : Iir) return O_Dnode is begin @@ -71,952 +60,6 @@ package body Translation is end if; end Get_Resolv_Ortho_Decl; - package Chap1 is - -- Declare types for block BLK - procedure Start_Block_Decl (Blk : Iir); - - procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration); - - -- Generate code to initialize generics of instance INSTANCE of ENTITY - -- using the default values. - -- This is used when ENTITY is at the top of a design hierarchy. - procedure Translate_Entity_Init (Entity : Iir); - - procedure Translate_Architecture_Body (Arch : Iir); - - -- CONFIG may be one of: - -- * configuration_declaration - -- * component_configuration - procedure Translate_Configuration_Declaration (Config : Iir); - end Chap1; - - package Chap2 is - -- Subprogram specification being currently translated. This is used - -- for the return statement. - Current_Subprogram : Iir := Null_Iir; - - procedure Translate_Subprogram_Interfaces (Spec : Iir); - procedure Elab_Subprogram_Interfaces (Spec : Iir); - - procedure Translate_Subprogram_Declaration (Spec : Iir); - procedure Translate_Subprogram_Body (Subprg : Iir); - - -- Set the identifier prefix with the subprogram identifier and - -- overload number if any. - procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type); - - procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration); - procedure Translate_Package_Body (Decl : Iir_Package_Body); - procedure Translate_Package_Instantiation_Declaration (Inst : Iir); - - procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir); - - -- Add info for an interface_package_declaration or a - -- package_instantiation_declaration - procedure Instantiate_Info_Package (Inst : Iir); - - -- Elaborate packages that DESIGN_UNIT depends on (except std.standard). - procedure Elab_Dependence (Design_Unit: Iir_Design_Unit); - - -- Declare an incomplete record type DECL_TYPE and access PTR_TYPE to - -- it. The names are respectively INSTTYPE and INSTPTR. - procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; - Ptr_Type : out O_Tnode); - end Chap2; - - package Chap5 is - -- Attribute specification. - procedure Translate_Attribute_Specification - (Spec : Iir_Attribute_Specification); - procedure Elab_Attribute_Specification - (Spec : Iir_Attribute_Specification); - - -- Disconnection specification. - procedure Elab_Disconnection_Specification - (Spec : Iir_Disconnection_Specification); - - -- Elab an unconstrained port. - procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir); - - procedure Elab_Generic_Map_Aspect (Mapping : Iir); - - -- There are 4 cases of generic/port map: - -- 1) component instantiation - -- 2) component configuration (association of a component with an entity - -- / architecture) - -- 3) block header - -- 4) direct (entity + architecture or configuration) instantiation - -- - -- MAPPING is the node containing the generic/port map aspects. - procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir); - end Chap5; - - - package Chap8 is - procedure Translate_Statements_Chain (First : Iir); - - -- Return true if there is a return statement in the chain. - function Translate_Statements_Chain_Has_Return (First : Iir) - return Boolean; - - -- Create a case branch for CHOICE. - -- Used by case statement and aggregates. - procedure Translate_Case_Choice - (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block); - - -- Inc or dec by VAL ITERATOR according to DIR. - -- Used for loop statements. - procedure Gen_Update_Iterator (Iterator : O_Dnode; - Dir : Iir_Direction; - Val : Unsigned_64; - Itype : Iir); - - procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir); - end Chap8; - - package Chap9 is - procedure Translate_Block_Declarations (Block : Iir; Origin : Iir); - procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir); - procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir); - - -- Generate code to instantiate an entity. - -- ASPECT must be an entity_aspect. - -- MAPPING must be a node with get_port/generic_map_aspect_list. - -- PARENT is the block in which the instantiation is done. - -- CONFIG_OVERRIDE, if set, is the configuration to use; if not set, the - -- configuration to use is determined from ASPECT. - procedure Translate_Entity_Instantiation - (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir); - - end Chap9; - - package Rtis is - -- Run-Time Information (RTI) Kind. - Ghdl_Rtik : O_Tnode; - Ghdl_Rtik_Top : O_Cnode; - Ghdl_Rtik_Library : O_Cnode; - Ghdl_Rtik_Package : O_Cnode; - Ghdl_Rtik_Package_Body : O_Cnode; - Ghdl_Rtik_Entity : O_Cnode; - Ghdl_Rtik_Architecture : O_Cnode; - Ghdl_Rtik_Process : O_Cnode; - Ghdl_Rtik_Block : O_Cnode; - Ghdl_Rtik_If_Generate : O_Cnode; - Ghdl_Rtik_For_Generate : O_Cnode; - Ghdl_Rtik_Instance : O_Cnode; - Ghdl_Rtik_Constant : O_Cnode; - Ghdl_Rtik_Iterator : O_Cnode; - Ghdl_Rtik_Variable : O_Cnode; - Ghdl_Rtik_Signal : O_Cnode; - Ghdl_Rtik_File : O_Cnode; - Ghdl_Rtik_Port : O_Cnode; - Ghdl_Rtik_Generic : O_Cnode; - Ghdl_Rtik_Alias : O_Cnode; - Ghdl_Rtik_Guard : O_Cnode; - Ghdl_Rtik_Component : O_Cnode; - Ghdl_Rtik_Attribute : O_Cnode; - Ghdl_Rtik_Type_B1 : O_Cnode; - Ghdl_Rtik_Type_E8 : O_Cnode; - Ghdl_Rtik_Type_E32 : O_Cnode; - Ghdl_Rtik_Type_I32 : O_Cnode; - Ghdl_Rtik_Type_I64 : O_Cnode; - Ghdl_Rtik_Type_F64 : O_Cnode; - Ghdl_Rtik_Type_P32 : O_Cnode; - Ghdl_Rtik_Type_P64 : O_Cnode; - Ghdl_Rtik_Type_Access : O_Cnode; - Ghdl_Rtik_Type_Array : O_Cnode; - Ghdl_Rtik_Type_Record : O_Cnode; - Ghdl_Rtik_Type_File : O_Cnode; - Ghdl_Rtik_Subtype_Scalar : O_Cnode; - Ghdl_Rtik_Subtype_Array : O_Cnode; - Ghdl_Rtik_Subtype_Unconstrained_Array : O_Cnode; - Ghdl_Rtik_Subtype_Record : O_Cnode; - Ghdl_Rtik_Subtype_Access : O_Cnode; - Ghdl_Rtik_Type_Protected : O_Cnode; - Ghdl_Rtik_Element : O_Cnode; - Ghdl_Rtik_Unit64 : O_Cnode; - Ghdl_Rtik_Unitptr : O_Cnode; - Ghdl_Rtik_Attribute_Transaction : O_Cnode; - Ghdl_Rtik_Attribute_Quiet : O_Cnode; - Ghdl_Rtik_Attribute_Stable : O_Cnode; - Ghdl_Rtik_Psl_Assert : O_Cnode; - Ghdl_Rtik_Error : O_Cnode; - - -- RTI types. - Ghdl_Rti_Depth : O_Tnode; - Ghdl_Rti_U8 : O_Tnode; - - -- Common node. - Ghdl_Rti_Common : O_Tnode; - Ghdl_Rti_Common_Kind : O_Fnode; - Ghdl_Rti_Common_Depth : O_Fnode; - Ghdl_Rti_Common_Mode : O_Fnode; - Ghdl_Rti_Common_Max_Depth : O_Fnode; - - -- Node accesses and arrays. - Ghdl_Rti_Access : O_Tnode; - Ghdl_Rti_Array : O_Tnode; - Ghdl_Rti_Arr_Acc : O_Tnode; - - -- Instance link. - -- This is a structure at the beginning of each entity/architecture - -- instance. This allow the run-time to find the parent of an instance. - Ghdl_Entity_Link_Type : O_Tnode; - -- RTI for this instance. - Ghdl_Entity_Link_Rti : O_Fnode; - -- RTI of the parent, which has instancied the instance. - Ghdl_Entity_Link_Parent : O_Fnode; - - Ghdl_Component_Link_Type : O_Tnode; - -- Pointer to a Ghdl_Entity_Link_Type, which is the entity instantiated. - Ghdl_Component_Link_Instance : O_Fnode; - -- RTI for the component instantiation statement. - Ghdl_Component_Link_Stmt : O_Fnode; - - -- Access to Ghdl_Entity_Link_Type. - Ghdl_Entity_Link_Acc : O_Tnode; - -- Access to a Ghdl_Component_Link_Type. - Ghdl_Component_Link_Acc : O_Tnode; - - -- Generate initial rti declarations. - procedure Rti_Initialize; - - -- Get address (as Ghdl_Rti_Access) of constant RTI. - function New_Rti_Address (Rti : O_Dnode) return O_Cnode; - - -- Generate rtis for a library unit. - procedure Generate_Unit (Lib_Unit : Iir); - - -- Generate a constant declaration for SIG; but do not set its value. - procedure Generate_Signal_Rti (Sig : Iir); - - -- Generate RTIs for subprogram body BOD. - procedure Generate_Subprogram_Body (Bod : Iir); - - -- Generate RTI for LIB. If PUBLIC is FALSE, only generate the - -- declaration as external. - procedure Generate_Library (Lib : Iir_Library_Declaration; - Public : Boolean); - - -- Generate RTI for the top of the hierarchy. Return the maximum number - -- of packages. - procedure Generate_Top (Nbr_Pkgs : out Natural); - - -- Add two associations to ASSOC to add an rti_context for NODE. - procedure Associate_Rti_Context - (Assoc : in out O_Assoc_List; Node : Iir); - procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List); - - function Get_Context_Rti (Node : Iir) return O_Cnode; - function Get_Context_Addr (Node : Iir) return O_Enode; - end Rtis; - - package Chap3 is - -- Translate the subtype of an object, since an object can define - -- a subtype. - -- This can be done only for a declaration. - -- DECL must have an identifier and a type. - procedure Translate_Object_Subtype - (Decl : Iir; With_Vars : Boolean := True); - procedure Elab_Object_Subtype (Def : Iir); - - -- Translate the subtype of a literal. - -- This can be done not at declaration time, ie no variables are created - -- for this subtype. - --procedure Translate_Literal_Subtype (Def : Iir); - - -- Translation of a type definition or subtype indication. - -- 1. Create corresponding Ortho type. - -- 2. Create bounds type - -- 3. Create bounds declaration - -- 4. Create bounds constructor - -- 5. Create type descriptor declaration - -- 6. Create type descriptor constructor - procedure Translate_Type_Definition - (Def : Iir; With_Vars : Boolean := True); - - procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id); - procedure Translate_Anonymous_Type_Definition - (Def : Iir; Transient : Boolean); - - -- Translate subprograms for types. - procedure Translate_Type_Subprograms (Decl : Iir); - - procedure Create_Type_Definition_Type_Range (Def : Iir); - function Create_Static_Array_Subtype_Bounds - (Def : Iir_Array_Subtype_Definition) - return O_Cnode; - - -- Same as Translate_type_definition only for std.standard.boolean and - -- std.standard.bit. - procedure Translate_Bool_Type_Definition (Def : Iir); - - -- Call lock or unlock on a protected object. - procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode); - - procedure Translate_Protected_Type_Body (Bod : Iir); - procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir); - - -- Translate_type_definition_Elab do 4 and 6. - -- It generates code to do type elaboration. - procedure Elab_Type_Declaration (Decl : Iir); - procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration); - - -- Builders. - -- A complex type is a type whose size is not locally static. - -- - -- The most simple example is an unidimensionnl array whose range - -- depends on generics. - -- - -- We call first order complex type any array whose bounds are not - -- locally static and whose sub-element size is locally static. - -- - -- First order complex type objects are represented by a pointer to an - -- array of sub-element, and the storage area for the array is - -- allocated at run-time. - -- - -- Since a sub-element type may be a complex type, a type may be - -- complex because one of its sub-element type is complex. - -- EG, a record type whose one element is a complex array. - -- - -- A type may be complex either because it is a first order complex - -- type (ie an array whose bounds are not locally static) or because - -- one of its sub-element type is such a type (this is recursive). - -- - -- We call second order complex type a complex type that is not of first - -- order. - -- We call third order complex type a second order complex type which is - -- an array whose bounds are not locally static. - -- - -- In a complex type, sub-element of first order complex type are - -- represented by a pointer. - -- Any complex type object (constant, signal, variable, port, generic) - -- is represented by a pointer. - -- - -- Creation of a second or third order complex type object consists in - -- allocating the memory and building the object. - -- Building a object consists in setting internal pointers. - -- - -- A complex type has always a non-null INFO.C, and its size is computed - -- during elaboration. - -- - -- For a second or third order complex type, INFO.C.BUILDER_NEED_FUNC - -- is set to TRUE. - - -- Call builder for variable pointed VAR of type VAR_TYPE. - procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir); - - -- Functions for fat array. - -- Fat array are array whose size is not known at compilation time. - -- This corresponds to an unconstrained array or a non locally static - -- constrained array. - -- A fat array is a structure containing 2 fields: - -- * base: a pointer to the data of the array. - -- * bounds: a pointer to a structure containing as many fields as - -- number of dimensions; these fields are a structure describing the - -- range of the dimension. - - -- Index array BASE of type ATYPE with INDEX. - -- INDEX must be of type ghdl_index_type, thus no bounds checks are - -- performed. - function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) - return Mnode; - - -- Same for for slicing. - function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) - return Mnode; - - -- Get the length of the array (the number of elements). - function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode; - - -- Get the number of elements for bounds BOUNDS. BOUNDS are - -- automatically stabilized if necessary. - function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode; - - -- Get the number of elements in array ATYPE. - function Get_Array_Type_Length (Atype : Iir) return O_Enode; - - -- Get the base of array ARR. - function Get_Array_Base (Arr : Mnode) return Mnode; - - -- Get the bounds of array ARR. - function Get_Array_Bounds (Arr : Mnode) return Mnode; - - -- Get the range ot ATYPE. - function Type_To_Range (Atype : Iir) return Mnode; - - -- Get length of range R. - function Range_To_Length (R : Mnode) return Mnode; - - -- Get direction of range R. - function Range_To_Dir (R : Mnode) return Mnode; - - -- Get left/right bounds for range R. - function Range_To_Left (R : Mnode) return Mnode; - function Range_To_Right (R : Mnode) return Mnode; - - -- Get range for dimension DIM (1 based) of array bounds B or type - -- ATYPE. - function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) - return Mnode; - - -- Get the range of dimension DIM (1 based) of array ARR of type ATYPE. - function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) - return Mnode; - - -- Get array bounds for type ATYPE. - function Get_Array_Type_Bounds (Atype : Iir) return Mnode; - - -- Deallocate OBJ. - procedure Gen_Deallocate (Obj : O_Enode); - - -- Performs deallocation of PARAM (the parameter of a deallocate call). - procedure Translate_Object_Deallocation (Param : Iir); - - -- Allocate an object of type OBJ_TYPE and set RES. - -- RES must be a stable access of type ortho_ptr_type. - -- For an unconstrained array, BOUNDS is a pointer to the boundaries of - -- the object, which are copied. - procedure Translate_Object_Allocation - (Res : in out Mnode; - Alloc_Kind : Allocation_Kind; - Obj_Type : Iir; - Bounds : Mnode); - - -- Copy SRC to DEST. - -- Both have the same type, OTYPE. - -- Furthermore, arrays are of the same length. - procedure Translate_Object_Copy - (Dest : Mnode; Src : O_Enode; Obj_Type : Iir); - - -- Get size (in bytes with type ghdl_index_type) of object OBJ. - -- For an unconstrained array, OBJ must be really an object, otherwise, - -- it may be a null_mnode, created by T2M. - function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode; - - -- Allocate the base of a fat array, whose length is determined from - -- the bounds. - -- RES_PTR is a pointer to the fat pointer (must be a variable that - -- can be referenced several times). - -- ARR_TYPE is the type of the array. - procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; - Res : Mnode; - Arr_Type : Iir); - - -- Create the bounds for SUB_TYPE. - -- SUB_TYPE is expected to be a non-static, anonymous array type. - procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean); - - -- Return TRUE if VALUE is not is the range specified by ATYPE. - -- VALUE must be stable. - function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode; - - -- Return TRUE if base type of ATYPE is larger than its bounds, ie - -- if a value of type ATYPE may be out of range. - function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean; - - -- Generate an error if VALUE (computed from EXPR which may be NULL_IIR - -- if not from a tree) is not in range specified by ATYPE. - procedure Check_Range - (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir); - - -- Insert a scalar check for VALUE of type ATYPE. EXPR may be NULL_IIR. - function Insert_Scalar_Check - (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) - return O_Enode; - - -- The base type of EXPR and the base type of ATYPE must be the same. - -- If the type is a scalar type, and if a range check is needed, this - -- function inserts the check. Otherwise, it returns VALUE. - function Maybe_Insert_Scalar_Check - (Value : O_Enode; Expr : Iir; Atype : Iir) - return O_Enode; - - -- Return True iff all indexes of L_TYPE and R_TYPE have the same - -- length. They must be locally static. - function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean; - - -- Check bounds length of L match bounds length of R. - -- If L_TYPE (resp. R_TYPE) is not a thin array, then L_NODE - -- (resp. R_NODE) are not used (and may be Mnode_Null). - -- If L_TYPE (resp. T_TYPE) is a fat array, then L_NODE (resp. R_NODE) - -- must designate the array. - procedure Check_Array_Match (L_Type : Iir; - L_Node : Mnode; - R_Type : Iir; - R_Node : Mnode; - Loc : Iir); - - -- Create a subtype range to be stored into the location pointed by - -- RANGE_PTR from length LENGTH, which is of type INDEX_TYPE. - -- This is done according to rules 7.2.4 of LRM93, ie: - -- direction and left bound of the range is the same of INDEX_TYPE. - -- LENGTH and RANGE_PTR are variables. LOC is the location in case of - -- error. - procedure Create_Range_From_Length - (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir); - - end Chap3; - - package Chap4 is - -- Translate of a type declaration corresponds to the translation of - -- its definition. - procedure Translate_Type_Declaration (Decl : Iir); - procedure Translate_Anonymous_Type_Declaration (Decl : Iir); - procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration); - procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration); - - -- Translate declaration DECL, which must not be a subprogram - -- specification. - procedure Translate_Declaration (Decl : Iir); - - -- Translate declarations, except subprograms spec and bodies. - procedure Translate_Declaration_Chain (Parent : Iir); - - -- Translate subprograms in declaration chain of PARENT. - procedure Translate_Declaration_Chain_Subprograms (Parent : Iir); - - -- Create subprograms for type/function conversion of signal - -- associations. - -- ENTITY is the entity instantiated, which can be either - -- an entity_declaration (for component configuration or direct - -- component instantiation), a component declaration (for a component - -- instantiation) or Null_Iir (for a block header). - -- BLOCK is the block/architecture containing the instantiation stmt. - -- STMT is either the instantiation stmt or the block header. - procedure Translate_Association_Subprograms - (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir); - - -- Elaborate In/Out_Conversion for ASSOC (signals only). - -- NDEST is the data structure to be registered. - procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode); - procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode); - - -- Create code to elaborate declarations. - -- NEED_FINAL is set when at least one declaration needs to be - -- finalized (eg: file declaration, protected objects). - procedure Elab_Declaration_Chain - (Parent : Iir; Need_Final : out Boolean); - - -- Finalize declarations. - procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean); - - -- Translate port or generic declarations of PARENT. - procedure Translate_Port_Chain (Parent : Iir); - procedure Translate_Generic_Chain (Parent : Iir); - - -- Elaborate signal subtypes and allocate the storage for the object. - procedure Elab_Signal_Declaration_Storage (Decl : Iir); - - -- Create signal object. - -- Note: SIG can be a signal sub-element (used when signals are - -- collapsed). - -- If CHECK_NULL is TRUE, create the signal only if it was not yet - -- created. - -- PARENT is used to link the signal to its parent by rti. - procedure Elab_Signal_Declaration_Object - (Sig : Iir; Parent : Iir; Check_Null : Boolean); - - -- True of SIG has a direct driver. - function Has_Direct_Driver (Sig : Iir) return Boolean; - - -- Allocate memory for direct driver if necessary. - procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir); - - -- Generate code to create object OBJ and initialize it with value VAL. - procedure Elab_Object_Value (Obj : Iir; Value : Iir); - - -- Allocate the storage for OBJ, if necessary. - procedure Elab_Object_Storage (Obj : Iir); - - -- Initialize NAME/OBJ with VALUE. - procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir); - - -- Get the ortho type for an object of type TINFO. - function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) - return O_Tnode; - - -- Allocate (and build) a complex object of type OBJ_TYPE. - -- VAR is the object to be allocated. - procedure Allocate_Complex_Object (Obj_Type : Iir; - Alloc_Kind : Allocation_Kind; - Var : in out Mnode); - - --function Translate_Interface_Declaration - -- (Decl : Iir; Subprg : Iir) return Tree; - - -- Create a record that describe thes location of an IIR node and - -- returns the address of it. - function Get_Location (N : Iir) return O_Dnode; - - -- Set default value to OBJ. - procedure Init_Object (Obj : Mnode; Obj_Type : Iir); - end Chap4; - - package Chap6 is - -- Translate NAME. - -- RES contains a lnode for the result. This is the object. - -- RES can be a tree, so it may be referenced only once. - -- SIG is true if RES is a signal object. - function Translate_Name (Name : Iir) return Mnode; - - -- Translate signal NAME into its node (SIG) and its direct driver - -- node (DRV). - procedure Translate_Direct_Driver - (Name : Iir; Sig : out Mnode; Drv : out Mnode); - - -- Same as Translate_Name, but only for formal names. - -- If SCOPE_TYPE and SCOPE_PARAM are not null, use them for the scope - -- of the base name. - -- Indeed, for recursive instantiation, NAME can designates the actual - -- and the formal. --- function Translate_Formal_Name (Scope_Type : O_Tnode; --- Scope_Param : O_Lnode; --- Name : Iir) --- return Mnode; - - -- Get record element EL of PREFIX. - function Translate_Selected_Element (Prefix : Mnode; - El : Iir_Element_Declaration) - return Mnode; - - function Get_Array_Bound_Length (Arr : Mnode; - Arr_Type : Iir; - Dim : Natural) - return O_Enode; - - procedure Gen_Bound_Error (Loc : Iir); - - -- Generate code to emit a program error. - Prg_Err_Missing_Return : constant Natural := 1; - Prg_Err_Block_Configured : constant Natural := 2; - Prg_Err_Dummy_Config : constant Natural := 3; - Prg_Err_No_Choice : constant Natural := 4; - Prg_Err_Bad_Choice : constant Natural := 5; - procedure Gen_Program_Error (Loc : Iir; Code : Natural); - - -- Generate code to emit a failure if COND is TRUE, indicating an - -- index violation for dimension DIM of an array. LOC is usually - -- the expression which has computed the index and is used only for - -- its location. - procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural); - - -- Get the deepest range_expression of ATYPE. - -- This follows 'range and 'reverse_range. - -- Set IS_REVERSE to true if the range must be reversed. - procedure Get_Deep_Range_Expression - (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean); - - -- Get the offset of INDEX in the range RNG. - -- This checks INDEX belongs to the range. - -- RANGE_TYPE is the subtype of the array index (or the subtype of RNG). - -- For unconstrained ranges, INDEX_EXPR must be NULL_IIR and RANGE_TYPE - -- must be set. - function Translate_Index_To_Offset (Rng : Mnode; - Index : O_Enode; - Index_Expr : Iir; - Range_Type : Iir; - Loc : Iir) - return O_Enode; - end Chap6; - - package Chap7 is - -- Generic function to extract a value from a signal. - generic - with function Read_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode; - function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode; - - -- Extract the effective value of SIG. - function Translate_Signal_Effective_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode; - function Translate_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode; - - -- Directly set the effective value of SIG with VAL. - -- Used only by conversion. - procedure Set_Effective_Value - (Sig : Mnode; Sig_Type : Iir; Val : Mnode); - - procedure Set_Driving_Value - (Sig : Mnode; Sig_Type : Iir; Val : Mnode); - - -- Translate expression EXPR into ortho tree. - function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) - return O_Enode; - - -- Translate call to function IMP. - -- ASSOC_CHAIN is the chain of a associations for this call. - -- OBJ, if not NULL_IIR is the protected object. - function Translate_Function_Call - (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) - return O_Enode; - - -- Translate range and return an lvalue containing the range. - -- The node returned can be used only one time. - function Translate_Range (Arange : Iir; Range_Type : Iir) - return O_Lnode; - - -- Translate range expression EXPR and store the result into the node - -- pointed by RES_PTR, of type RANGE_TYPE. - procedure Translate_Range_Ptr - (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir); - function Translate_Static_Range (Arange : Iir; Range_Type : Iir) - return O_Cnode; - - -- Same as Translate_Range_Ptr, but for a discrete range (ie: ARANGE - -- can be a discrete subtype indication). - procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir); - - -- Return TRUE iff constant declaration DECL can be staticly defined. - -- This is of course true if its expression is a locally static literal, - -- but can be true in a few cases for aggregates. - -- This function belongs to Translation, since it is defined along - -- with the translate_static_aggregate procedure. - function Is_Static_Constant (Decl : Iir_Constant_Declaration) - return Boolean; - - -- Translate the static expression EXPR into an ortho expression whose - -- type must be RES_TYPE. Therefore, an implicite conversion might - -- occurs. - function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) - return O_Cnode; - function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) - return O_Cnode; - - -- Convert (if necessary) EXPR of type EXPR_TYPE to type ATYPE. - function Translate_Implicit_Conv - (Expr : O_Enode; - Expr_Type : Iir; - Atype : Iir; - Is_Sig : Object_Kind_Type; - Loc : Iir) - return O_Enode; - - function Translate_Type_Conversion - (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) - return O_Enode; - - -- Convert range EXPR into ortho tree. - -- If RANGE_TYPE /= NULL_IIR, convert bounds to RANGE_TYPE. - --function Translate_Range (Expr : Iir; Range_Type : Iir) return O_Enode; - function Translate_Static_Range_Left - (Expr : Iir; Range_Type : Iir := Null_Iir) - return O_Cnode; - function Translate_Static_Range_Right - (Expr : Iir; Range_Type : Iir := Null_Iir) - return O_Cnode; - function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode; - function Translate_Static_Range_Length (Expr : Iir) return O_Cnode; - - -- These functions evaluates left bound/right bound/length of the - -- range expression EXPR. - function Translate_Range_Expression_Left (Expr : Iir; - Range_Type : Iir := Null_Iir) - return O_Enode; - function Translate_Range_Expression_Right (Expr : Iir; - Range_Type : Iir := Null_Iir) - return O_Enode; - function Translate_Range_Expression_Length (Expr : Iir) return O_Enode; - - -- Get the length of any range expression (ie maybe an attribute). - function Translate_Range_Length (Expr : Iir) return O_Enode; - - -- Assign AGGR to TARGET of type TARGET_TYPE. - procedure Translate_Aggregate - (Target : Mnode; Target_Type : Iir; Aggr : Iir); - - -- Translate implicit functions defined by a type. - type Implicit_Subprogram_Infos is private; - procedure Init_Implicit_Subprogram_Infos - (Infos : out Implicit_Subprogram_Infos); - procedure Translate_Implicit_Subprogram - (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos); - - -- Assign EXPR to TARGET. LOC is the location used to report errors. - -- FIXME: do the checks. - procedure Translate_Assign - (Target : Mnode; Expr : Iir; Target_Type : Iir); - procedure Translate_Assign - (Target : Mnode; - Val: O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir); - - -- Find the declaration of the predefined function IMP in type - -- definition BASE_TYPE. - function Find_Predefined_Function - (Base_Type : Iir; Imp : Iir_Predefined_Functions) - return Iir; - - function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) - return O_Enode; - private - type Implicit_Subprogram_Infos is record - Arr_Eq_Info : Subprg_Info_Acc; - Rec_Eq_Info : Subprg_Info_Acc; - Arr_Cmp_Info : Subprg_Info_Acc; - Arr_Concat_Info : Subprg_Info_Acc; - Arr_Shl_Info : Subprg_Info_Acc; - Arr_Sha_Info : Subprg_Info_Acc; - Arr_Rot_Info : Subprg_Info_Acc; - end record; - end Chap7; - - package Chap14 is - function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode; - - -- Read signal value FIELD of signal SIG. - function Get_Signal_Value_Field - (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) - return O_Lnode; - - function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) return O_Lnode; - - function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) - return O_Enode; - function Translate_Low_Array_Attribute (Expr : Iir) return O_Enode; - function Translate_High_Array_Attribute (Expr : Iir) return O_Enode; - function Translate_Range_Array_Attribute (Expr : Iir) return O_Lnode; - function Translate_Right_Array_Attribute (Expr : Iir) return O_Enode; - function Translate_Left_Array_Attribute (Expr : Iir) return O_Enode; - function Translate_Ascending_Array_Attribute (Expr : Iir) return O_Enode; - - function Translate_High_Low_Type_Attribute - (Atype : Iir; Is_High : Boolean) return O_Enode; - - -- Return the value of the left bound/right bound/direction of scalar - -- type ATYPE. - function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode; - function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode; - function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode; - - function Translate_Val_Attribute (Attr : Iir) return O_Enode; - function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) - return O_Enode; - - function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode; - - function Translate_Image_Attribute (Attr : Iir) return O_Enode; - function Translate_Value_Attribute (Attr : Iir) return O_Enode; - - function Translate_Event_Attribute (Attr : Iir) return O_Enode; - function Translate_Active_Attribute (Attr : Iir) return O_Enode; - function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode; - - function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) - return O_Enode; - - function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode; - - function Translate_Driving_Attribute (Attr : Iir) return O_Enode; - - function Translate_Path_Instance_Name_Attribute (Attr : Iir) - return O_Enode; - end Chap14; - - package Helpers is - -- Copy a fat pointer. - -- D and S are stabilized fat pointers. - procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); - - -- Create a constant (of name ID) for string STR. - -- Append a NUL terminator (to make interfaces with C easier). - function Create_String (Str : String; Id : O_Ident) return O_Dnode; - - function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) - return O_Dnode; - - function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) - return O_Dnode; - - function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode; - - procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode); - - -- Allocate SIZE bytes aligned on the biggest alignment and return a - -- pointer of type PTYPE. - function Gen_Alloc - (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) - return O_Enode; - - -- Allocate on the heap LENGTH bytes aligned on the biggest alignment, - -- and returns a pointer of type PTYPE. - --function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode; - - -- Handle a composite type TARG/TARG_TYPE and apply DO_NON_COMPOSITE - -- on each non composite type. - -- There is a generic parameter DATA which may be updated - -- before indexing an array by UPDATE_DATA_ARRAY. - generic - type Data_Type is private; - type Composite_Data_Type is private; - with procedure Do_Non_Composite (Targ : Mnode; - Targ_Type : Iir; - Data : Data_Type); - - -- This function should extract the base of DATA. - with function Prepare_Data_Array (Targ : Mnode; - Targ_Type : Iir; - Data : Data_Type) - return Composite_Data_Type; - - -- This function should index DATA. - with function Update_Data_Array (Data : Composite_Data_Type; - Targ_Type : Iir; - Index : O_Dnode) - return Data_Type; - - -- This function is called at the end of a record process. - with procedure Finish_Data_Array (Data : in out Composite_Data_Type); - - -- This function should stabilize DATA. - with function Prepare_Data_Record (Targ : Mnode; - Targ_Type : Iir; - Data : Data_Type) - return Composite_Data_Type; - - -- This function should extract field EL of DATA. - with function Update_Data_Record (Data : Composite_Data_Type; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Data_Type; - - -- This function is called at the end of a record process. - with procedure Finish_Data_Record (Data : in out Composite_Data_Type); - - procedure Foreach_Non_Composite (Targ : Mnode; - Targ_Type : Iir; - Data : Data_Type); - - -- Call a procedure (DATA_TYPE) for each signal of TARG. - procedure Register_Signal - (Targ : Mnode; Targ_Type : Iir; Proc : O_Dnode); - - -- Call PROC for each scalar signal of list LIST. - procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode); - - -- Often used subprograms for Foreach_non_composite - -- when DATA_TYPE is o_enode. - function Gen_Oenode_Prepare_Data_Composite - (Targ: Mnode; Targ_Type : Iir; Val : O_Enode) - return Mnode; - function Gen_Oenode_Update_Data_Array (Val : Mnode; - Targ_Type : Iir; - Index : O_Dnode) - return O_Enode; - function Gen_Oenode_Update_Data_Record - (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) - return O_Enode; - procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode); - - function Get_Line_Number (Target: Iir) return Natural; - - procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; - Line : Natural); - end Helpers; - use Helpers; - - function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type is use Name_Table; @@ -1152,24278 +195,6 @@ package body Translation is end if; end Translate_Foreign_Id; - package body Helpers is - procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) - is - begin - New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)), - M2Addr (Chap3.Get_Array_Base (S))); - New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (D)), - M2Addr (Chap3.Get_Array_Bounds (S))); - end Copy_Fat_Pointer; - - -- Convert NAME into a STRING_CST. - -- Append a NUL terminator (to make interfaces with C easier). - function Create_String_Type (Str : String) return O_Tnode is - begin - return New_Constrained_Array_Type - (Chararray_Type, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Str'Length + 1))); - end Create_String_Type; - - procedure Create_String_Value - (Const : in out O_Dnode; Const_Type : O_Tnode; Str : String) - is - Res : O_Cnode; - List : O_Array_Aggr_List; - begin - Start_Const_Value (Const); - Start_Array_Aggr (List, Const_Type); - for I in Str'Range loop - New_Array_Aggr_El - (List, - New_Unsigned_Literal (Char_Type_Node, Character'Pos (Str (I)))); - end loop; - New_Array_Aggr_El (List, New_Unsigned_Literal (Char_Type_Node, 0)); - Finish_Array_Aggr (List, Res); - Finish_Const_Value (Const, Res); - end Create_String_Value; - - function Create_String (Str : String; Id : O_Ident) return O_Dnode - is - Atype : O_Tnode; - Const : O_Dnode; - begin - Atype := Create_String_Type (Str); - New_Const_Decl (Const, Id, O_Storage_Private, Atype); - Create_String_Value (Const, Atype, Str); - return Const; - end Create_String; - - function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) - return O_Dnode - is - Atype : O_Tnode; - Const : O_Dnode; - begin - Atype := Create_String_Type (Str); - New_Const_Decl (Const, Id, Storage, Atype); - if Storage /= O_Storage_External then - Create_String_Value (Const, Atype, Str); - end if; - return Const; - end Create_String; - - function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) - return O_Dnode - is - use Name_Table; - begin - if Name_Table.Is_Character (Str) then - raise Internal_Error; - end if; - Image (Str); - return Create_String (Name_Buffer (1 .. Name_Length), Id, Storage); - end Create_String; - - function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode - is - Str_Cst : O_Dnode; - Str_Len : O_Cnode; - List : O_Record_Aggr_List; - Res : O_Cnode; - begin - Str_Cst := Create_String (Str, Id); - Str_Len := New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Str'Length)); - Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node); - New_Record_Aggr_El (List, Str_Len); - New_Record_Aggr_El (List, New_Global_Address (Str_Cst, - Char_Ptr_Type)); - Finish_Record_Aggr (List, Res); - return Res; - end Create_String_Len; - - procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode) - is - Constr : O_Assoc_List; - begin - Start_Association (Constr, Ghdl_Memcpy); - New_Association (Constr, New_Convert_Ov (Dest, Ghdl_Ptr_Type)); - New_Association (Constr, New_Convert_Ov (Src, Ghdl_Ptr_Type)); - New_Association (Constr, Length); - New_Procedure_Call (Constr); - end Gen_Memcpy; - --- function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode --- is --- Constr : O_Assoc_List; --- begin --- Start_Association (Constr, Ghdl_Malloc); --- New_Association (Constr, Length); --- return New_Convert_Ov (New_Function_Call (Constr), Ptype); --- end Gen_Malloc; - - function Gen_Alloc - (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) - return O_Enode - is - Constr : O_Assoc_List; - begin - case Kind is - when Alloc_Heap => - Start_Association (Constr, Ghdl_Malloc); - New_Association (Constr, Size); - return New_Convert_Ov (New_Function_Call (Constr), Ptype); - when Alloc_System => - Start_Association (Constr, Ghdl_Malloc0); - New_Association (Constr, Size); - return New_Convert_Ov (New_Function_Call (Constr), Ptype); - when Alloc_Stack => - return New_Alloca (Ptype, Size); - when Alloc_Return => - Start_Association (Constr, Ghdl_Stack2_Allocate); - New_Association (Constr, Size); - return New_Convert_Ov (New_Function_Call (Constr), Ptype); - end case; - end Gen_Alloc; - - procedure Foreach_Non_Composite (Targ : Mnode; - Targ_Type : Iir; - Data : Data_Type) - is - Type_Info : Type_Info_Acc; - begin - Type_Info := Get_Info (Targ_Type); - case Type_Info.Type_Mode is - when Type_Mode_Scalar => - Do_Non_Composite (Targ, Targ_Type, Data); - when Type_Mode_Fat_Array - | Type_Mode_Array => - declare - Var_Array : Mnode; - Var_Base : Mnode; - Var_Length : O_Dnode; - Var_I : O_Dnode; - Label : O_Snode; - Sub_Data : Data_Type; - Composite_Data : Composite_Data_Type; - begin - Open_Temp; - Var_Array := Stabilize (Targ); - Var_Length := Create_Temp (Ghdl_Index_Type); - Var_Base := Stabilize (Chap3.Get_Array_Base (Var_Array)); - New_Assign_Stmt - (New_Obj (Var_Length), - Chap3.Get_Array_Length (Var_Array, Targ_Type)); - Composite_Data := - Prepare_Data_Array (Var_Array, Targ_Type, Data); - if True then - Var_I := Create_Temp (Ghdl_Index_Type); - else - New_Var_Decl - (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - end if; - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, New_Compare_Op (ON_Ge, - New_Value (New_Obj (Var_I)), - New_Value (New_Obj (Var_Length)), - Ghdl_Bool_Type)); - Sub_Data := Update_Data_Array - (Composite_Data, Targ_Type, Var_I); - Foreach_Non_Composite - (Chap3.Index_Base (Var_Base, Targ_Type, - New_Value (New_Obj (Var_I))), - Get_Element_Subtype (Targ_Type), - Sub_Data); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Data_Array (Composite_Data); - Close_Temp; - end; - when Type_Mode_Record => - declare - Var_Record : Mnode; - Sub_Data : Data_Type; - Composite_Data : Composite_Data_Type; - List : Iir_List; - El : Iir_Element_Declaration; - begin - Open_Temp; - Var_Record := Stabilize (Targ); - Composite_Data := - Prepare_Data_Record (Var_Record, Targ_Type, Data); - List := Get_Elements_Declaration_List - (Get_Base_Type (Targ_Type)); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Sub_Data := Update_Data_Record - (Composite_Data, Targ_Type, El); - Foreach_Non_Composite - (Chap6.Translate_Selected_Element (Var_Record, El), - Get_Type (El), - Sub_Data); - end loop; - Finish_Data_Record (Composite_Data); - Close_Temp; - end; - when others => - Error_Kind ("foreach_non_composite/" - & Type_Mode_Type'Image (Type_Info.Type_Mode), - Targ_Type); - end case; - end Foreach_Non_Composite; - - procedure Register_Non_Composite_Signal (Targ : Mnode; - Targ_Type : Iir; - Proc : O_Dnode) - is - pragma Unreferenced (Targ_Type); - Constr : O_Assoc_List; - begin - Start_Association (Constr, Proc); - New_Association - (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); - New_Procedure_Call (Constr); - end Register_Non_Composite_Signal; - - function Register_Update_Data_Array - (Data : O_Dnode; Targ_Type : Iir; Index : O_Dnode) - return O_Dnode - is - pragma Unreferenced (Targ_Type); - pragma Unreferenced (Index); - begin - return Data; - end Register_Update_Data_Array; - - function Register_Prepare_Data_Composite (Targ : Mnode; - Targ_Type : Iir; - Data : O_Dnode) - return O_Dnode - is - pragma Unreferenced (Targ); - pragma Unreferenced (Targ_Type); - begin - return Data; - end Register_Prepare_Data_Composite; - - function Register_Update_Data_Record - (Data : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) - return O_Dnode - is - pragma Unreferenced (Targ_Type); - pragma Unreferenced (El); - begin - return Data; - end Register_Update_Data_Record; - - procedure Register_Finish_Data_Composite (D : in out O_Dnode) - is - pragma Unreferenced (D); - begin - null; - end Register_Finish_Data_Composite; - - procedure Register_Signal_1 is new Foreach_Non_Composite - (Data_Type => O_Dnode, - Composite_Data_Type => O_Dnode, - Do_Non_Composite => Register_Non_Composite_Signal, - Prepare_Data_Array => Register_Prepare_Data_Composite, - Update_Data_Array => Register_Update_Data_Array, - Finish_Data_Array => Register_Finish_Data_Composite, - Prepare_Data_Record => Register_Prepare_Data_Composite, - Update_Data_Record => Register_Update_Data_Record, - Finish_Data_Record => Register_Finish_Data_Composite); - - procedure Register_Signal (Targ : Mnode; - Targ_Type : Iir; - Proc : O_Dnode) - renames Register_Signal_1; - - procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode) - is - El : Iir; - Sig : Mnode; - begin - if List = Null_Iir_List then - return; - end if; - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Open_Temp; - Sig := Chap6.Translate_Name (El); - Register_Signal (Sig, Get_Type (El), Proc); - Close_Temp; - end loop; - end Register_Signal_List; - - function Gen_Oenode_Prepare_Data_Composite - (Targ : Mnode; Targ_Type : Iir; Val : O_Enode) - return Mnode - is - pragma Unreferenced (Targ); - Res : Mnode; - Type_Info : Type_Info_Acc; - begin - Type_Info := Get_Info (Targ_Type); - Res := E2M (Val, Type_Info, Mode_Value); - case Type_Info.Type_Mode is - when Type_Mode_Array - | Type_Mode_Fat_Array => - Res := Chap3.Get_Array_Base (Res); - when Type_Mode_Record => - Res := Stabilize (Res); - when others => - -- Not a composite type! - raise Internal_Error; - end case; - return Res; - end Gen_Oenode_Prepare_Data_Composite; - - function Gen_Oenode_Update_Data_Array (Val : Mnode; - Targ_Type : Iir; - Index : O_Dnode) - return O_Enode - is - begin - return M2E (Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index))); - end Gen_Oenode_Update_Data_Array; - - function Gen_Oenode_Update_Data_Record - (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) - return O_Enode - is - pragma Unreferenced (Targ_Type); - begin - return M2E (Chap6.Translate_Selected_Element (Val, El)); - end Gen_Oenode_Update_Data_Record; - - procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode) - is - pragma Unreferenced (Data); - begin - null; - end Gen_Oenode_Finish_Data_Composite; - - function Get_Line_Number (Target: Iir) return Natural - is - Line, Col: Natural; - Name : Name_Id; - begin - Files_Map.Location_To_Position - (Get_Location (Target), Name, Line, Col); - return Line; - end Get_Line_Number; - - procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; - Line : Natural) is - begin - New_Association (Assoc, - New_Lit (New_Global_Address (Current_Filename_Node, - Char_Ptr_Type))); - New_Association (Assoc, New_Lit (New_Signed_Literal - (Ghdl_I32_Type, Integer_64 (Line)))); - end Assoc_Filename_Line; - end Helpers; - - package body Chap1 is - procedure Start_Block_Decl (Blk : Iir) - is - Info : constant Block_Info_Acc := Get_Info (Blk); - begin - Chap2.Declare_Inst_Type_And_Ptr - (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type); - end Start_Block_Decl; - - procedure Translate_Entity_Init (Entity : Iir) - is - El : Iir; - El_Type : Iir; - begin - Push_Local_Factory; - - -- Generics. - El := Get_Generic_Chain (Entity); - while El /= Null_Iir loop - Open_Temp; - Chap4.Elab_Object_Value (El, Get_Default_Value (El)); - Close_Temp; - El := Get_Chain (El); - end loop; - - -- Ports. - El := Get_Port_Chain (Entity); - while El /= Null_Iir loop - Open_Temp; - El_Type := Get_Type (El); - if not Is_Fully_Constrained_Type (El_Type) then - Chap5.Elab_Unconstrained_Port (El, Get_Default_Value (El)); - end if; - Chap4.Elab_Signal_Declaration_Storage (El); - Chap4.Elab_Signal_Declaration_Object (El, Entity, False); - Close_Temp; - - El := Get_Chain (El); - end loop; - - Pop_Local_Factory; - end Translate_Entity_Init; - - procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration) - is - Info : Block_Info_Acc; - Interface_List : O_Inter_List; - Instance : Subprgs.Subprg_Instance_Type; - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - begin - Info := Add_Info (Entity, Kind_Block); - Chap1.Start_Block_Decl (Entity); - Push_Instance_Factory (Info.Block_Scope'Access); - - -- Entity link (RTI and pointer to parent). - Info.Block_Link_Field := Add_Instance_Factory_Field - (Wki_Rti, Rtis.Ghdl_Entity_Link_Type); - - -- generics, ports. - Chap4.Translate_Generic_Chain (Entity); - Chap4.Translate_Port_Chain (Entity); - - Chap9.Translate_Block_Declarations (Entity, Entity); - - Pop_Instance_Factory (Info.Block_Scope'Access); - - Subprgs.Push_Subprg_Instance (Info.Block_Scope'Access, - Info.Block_Decls_Ptr_Type, - Wki_Instance, - Prev_Subprg_Instance); - - -- Entity elaborator. - Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"), - Global_Storage); - Subprgs.Add_Subprg_Instance_Interfaces (Interface_List, Instance); - Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); - - -- Entity dependences elaborator. - Start_Procedure_Decl (Interface_List, Create_Identifier ("PKG_ELAB"), - Global_Storage); - Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Pkg_Subprg); - - -- Generate RTI. - if Flag_Rti then - Rtis.Generate_Unit (Entity); - end if; - - if Global_Storage = O_Storage_External then - -- Entity declaration subprograms. - Chap4.Translate_Declaration_Chain_Subprograms (Entity); - else - -- Entity declaration and process subprograms. - Chap9.Translate_Block_Subprograms (Entity, Entity); - - -- Package elaborator Body. - Start_Subprogram_Body (Info.Block_Elab_Pkg_Subprg); - Push_Local_Factory; - New_Debug_Line_Stmt (Get_Line_Number (Entity)); - Chap2.Elab_Dependence (Get_Design_Unit (Entity)); - Pop_Local_Factory; - Finish_Subprogram_Body; - - -- Elaborator Body. - Start_Subprogram_Body (Info.Block_Elab_Subprg); - Push_Local_Factory; - Subprgs.Start_Subprg_Instance_Use (Instance); - New_Debug_Line_Stmt (Get_Line_Number (Entity)); - - Chap9.Elab_Block_Declarations (Entity, Entity); - Subprgs.Finish_Subprg_Instance_Use (Instance); - Pop_Local_Factory; - Finish_Subprogram_Body; - - -- Default value if any. - if False then --Is_Entity_Declaration_Top (Entity) then - declare - Init_Subprg : O_Dnode; - begin - Start_Procedure_Decl - (Interface_List, Create_Identifier ("_INIT"), - Global_Storage); - Subprgs.Add_Subprg_Instance_Interfaces - (Interface_List, Instance); - Finish_Subprogram_Decl (Interface_List, Init_Subprg); - - Start_Subprogram_Body (Init_Subprg); - Subprgs.Start_Subprg_Instance_Use (Instance); - Translate_Entity_Init (Entity); - Subprgs.Finish_Subprg_Instance_Use (Instance); - Finish_Subprogram_Body; - end; - end if; - end if; - Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); - end Translate_Entity_Declaration; - - -- Push scope for architecture ARCH via INSTANCE, and for its - -- entity via the entity field of the instance. - procedure Push_Architecture_Scope (Arch : Iir; Instance : O_Dnode) - is - Arch_Info : constant Block_Info_Acc := Get_Info (Arch); - Entity : constant Iir := Get_Entity (Arch); - Entity_Info : constant Block_Info_Acc := Get_Info (Entity); - begin - Set_Scope_Via_Param_Ptr (Arch_Info.Block_Scope, Instance); - Set_Scope_Via_Field (Entity_Info.Block_Scope, - Arch_Info.Block_Parent_Field, - Arch_Info.Block_Scope'Access); - end Push_Architecture_Scope; - - -- Pop scopes created by Push_Architecture_Scope. - procedure Pop_Architecture_Scope (Arch : Iir) - is - Arch_Info : constant Block_Info_Acc := Get_Info (Arch); - Entity : constant Iir := Get_Entity (Arch); - Entity_Info : constant Block_Info_Acc := Get_Info (Entity); - begin - Clear_Scope (Entity_Info.Block_Scope); - Clear_Scope (Arch_Info.Block_Scope); - end Pop_Architecture_Scope; - - procedure Translate_Architecture_Body (Arch : Iir) - is - Entity : constant Iir := Get_Entity (Arch); - Entity_Info : constant Block_Info_Acc := Get_Info (Entity); - Info : Block_Info_Acc; - Interface_List : O_Inter_List; - Constr : O_Assoc_List; - Instance : O_Dnode; - Var_Arch_Instance : O_Dnode; - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - begin - if Get_Foreign_Flag (Arch) then - Error_Msg_Sem ("FOREIGN architectures are not yet handled", Arch); - end if; - - Info := Add_Info (Arch, Kind_Block); - Start_Block_Decl (Arch); - Push_Instance_Factory (Info.Block_Scope'Access); - - -- We cannot use Add_Scope_Field here, because the entity is not a - -- child scope of the architecture. - Info.Block_Parent_Field := Add_Instance_Factory_Field - (Get_Identifier ("ENTITY"), - Get_Scope_Type (Entity_Info.Block_Scope)); - - Chap9.Translate_Block_Declarations (Arch, Arch); - - Pop_Instance_Factory (Info.Block_Scope'Access); - - -- Declare the constant containing the size of the instance. - New_Const_Decl - (Info.Block_Instance_Size, Create_Identifier ("INSTSIZE"), - Global_Storage, Ghdl_Index_Type); - if Global_Storage /= O_Storage_External then - Start_Const_Value (Info.Block_Instance_Size); - Finish_Const_Value - (Info.Block_Instance_Size, Get_Scope_Size (Info.Block_Scope)); - end if; - - -- Elaborator. - Start_Procedure_Decl - (Interface_List, Create_Identifier ("ELAB"), Global_Storage); - New_Interface_Decl - (Interface_List, Instance, Wki_Instance, - Entity_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); - - -- Generate RTI. - if Flag_Rti then - Rtis.Generate_Unit (Arch); - end if; - - if Global_Storage = O_Storage_External then - return; - end if; - - -- Create process subprograms. - Subprgs.Push_Subprg_Instance (Info.Block_Scope'Access, - Info.Block_Decls_Ptr_Type, - Wki_Instance, - Prev_Subprg_Instance); - Set_Scope_Via_Field (Entity_Info.Block_Scope, - Info.Block_Parent_Field, - Info.Block_Scope'Access); - - Chap9.Translate_Block_Subprograms (Arch, Arch); - - Clear_Scope (Entity_Info.Block_Scope); - Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); - - -- Elaborator body. - Start_Subprogram_Body (Info.Block_Elab_Subprg); - Push_Local_Factory; - - -- Create a variable for the architecture instance (with the right - -- type, instead of the entity instance type). - New_Var_Decl (Var_Arch_Instance, Wki_Arch_Instance, - O_Storage_Local, Info.Block_Decls_Ptr_Type); - New_Assign_Stmt - (New_Obj (Var_Arch_Instance), - New_Convert_Ov (New_Value (New_Obj (Instance)), - Info.Block_Decls_Ptr_Type)); - - -- Set RTI. - if Flag_Rti then - New_Assign_Stmt - (New_Selected_Element - (New_Selected_Acc_Value (New_Obj (Instance), - Entity_Info.Block_Link_Field), - Rtis.Ghdl_Entity_Link_Rti), - New_Unchecked_Address (New_Obj (Info.Block_Rti_Const), - Rtis.Ghdl_Rti_Access)); - end if; - - -- Call entity elaborators. - Start_Association (Constr, Entity_Info.Block_Elab_Subprg); - New_Association (Constr, New_Value (New_Obj (Instance))); - New_Procedure_Call (Constr); - - Push_Architecture_Scope (Arch, Var_Arch_Instance); - - New_Debug_Line_Stmt (Get_Line_Number (Arch)); - Chap2.Elab_Dependence (Get_Design_Unit (Arch)); - - Chap9.Elab_Block_Declarations (Arch, Arch); - --Chap6.Leave_Simple_Name (Ghdl_Leave_Architecture); - - Pop_Architecture_Scope (Arch); - - Pop_Local_Factory; - Finish_Subprogram_Body; - end Translate_Architecture_Body; - - procedure Translate_Component_Configuration_Decl - (Cfg : Iir; Blk : Iir; Base_Block : Iir; Num : in out Iir_Int32) - is - Inter_List : O_Inter_List; - Comp : Iir_Component_Declaration; - Comp_Info : Comp_Info_Acc; - Info : Config_Info_Acc; - Instance : O_Dnode; - Mark, Mark2 : Id_Mark_Type; - - Base_Info : Block_Info_Acc; - Base_Instance : O_Dnode; - - Block : Iir_Block_Configuration; - Binding : Iir_Binding_Indication; - Entity_Aspect : Iir; - Conf_Override : Iir; - Conf_Info : Config_Info_Acc; - begin - -- Incremental binding. - if Get_Nbr_Elements (Get_Instantiation_List (Cfg)) = 0 then - -- This component configuration applies to no component - -- instantiation, so it is not translated. - return; - end if; - - Binding := Get_Binding_Indication (Cfg); - if Binding = Null_Iir then - -- This is an unbound component configuration, since this is a - -- no-op, it is not translated. - return; - end if; - - Entity_Aspect := Get_Entity_Aspect (Binding); - - Comp := Get_Named_Entity (Get_Component_Name (Cfg)); - Comp_Info := Get_Info (Comp); - - if Get_Kind (Cfg) = Iir_Kind_Component_Configuration then - Block := Get_Block_Configuration (Cfg); - else - Block := Null_Iir; - end if; - - Push_Identifier_Prefix (Mark, Get_Identifier (Comp), Num); - Num := Num + 1; - - if Block /= Null_Iir then - Push_Identifier_Prefix (Mark2, "CONFIG"); - Translate_Configuration_Declaration (Cfg); - Pop_Identifier_Prefix (Mark2); - Conf_Override := Cfg; - Conf_Info := Get_Info (Cfg); - Clear_Info (Cfg); - else - Conf_Info := null; - Conf_Override := Null_Iir; - end if; - Info := Add_Info (Cfg, Kind_Config); - - Base_Info := Get_Info (Base_Block); - - Chap4.Translate_Association_Subprograms - (Binding, Blk, Base_Block, - Get_Entity_From_Entity_Aspect (Entity_Aspect)); - - Start_Procedure_Decl - (Inter_List, Create_Identifier, O_Storage_Private); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Comp_Info.Comp_Ptr_Type); - New_Interface_Decl (Inter_List, Base_Instance, Get_Identifier ("BLK"), - Base_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Info.Config_Subprg); - - -- Extract the entity/architecture. - - Start_Subprogram_Body (Info.Config_Subprg); - Push_Local_Factory; - - if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then - Push_Architecture_Scope (Base_Block, Base_Instance); - else - Set_Scope_Via_Param_Ptr (Base_Info.Block_Scope, Base_Instance); - end if; - - Set_Scope_Via_Param_Ptr (Comp_Info.Comp_Scope, Instance); - - if Conf_Info /= null then - Clear_Info (Cfg); - Set_Info (Cfg, Conf_Info); - end if; - Chap9.Translate_Entity_Instantiation - (Entity_Aspect, Binding, Comp, Conf_Override); - if Conf_Info /= null then - Clear_Info (Cfg); - Set_Info (Cfg, Info); - end if; - - Clear_Scope (Comp_Info.Comp_Scope); - - if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then - Pop_Architecture_Scope (Base_Block); - else - Clear_Scope (Base_Info.Block_Scope); - end if; - - Pop_Local_Factory; - Finish_Subprogram_Body; - - Pop_Identifier_Prefix (Mark); - end Translate_Component_Configuration_Decl; - - -- Create subprogram specifications for each configuration_specification - -- in BLOCK_CONFIG and its sub-blocks. - -- BLOCK is the block being configured (initially the architecture), - -- BASE_BLOCK is the root block giving the instance (initially the - -- architecture) - -- NUM is an integer used to generate uniq names. - procedure Translate_Block_Configuration_Decls - (Block_Config : Iir_Block_Configuration; - Block : Iir; - Base_Block : Iir; - Num : in out Iir_Int32) - is - El : Iir; - begin - El := Get_Configuration_Item_Chain (Block_Config); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Component_Configuration - | Iir_Kind_Configuration_Specification => - Translate_Component_Configuration_Decl - (El, Block, Base_Block, Num); - when Iir_Kind_Block_Configuration => - declare - Mark : Id_Mark_Type; - Base_Info : constant Block_Info_Acc := - Get_Info (Base_Block); - Blk : constant Iir := Get_Block_From_Block_Specification - (Get_Block_Specification (El)); - Blk_Info : constant Block_Info_Acc := Get_Info (Blk); - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Blk)); - case Get_Kind (Blk) is - when Iir_Kind_Generate_Statement => - Set_Scope_Via_Field_Ptr - (Base_Info.Block_Scope, - Blk_Info.Block_Origin_Field, - Blk_Info.Block_Scope'Access); - Translate_Block_Configuration_Decls - (El, Blk, Blk, Num); - Clear_Scope (Base_Info.Block_Scope); - when Iir_Kind_Block_Statement => - Translate_Block_Configuration_Decls - (El, Blk, Base_Block, Num); - when others => - Error_Kind - ("translate_block_configuration_decls(2)", Blk); - end case; - Pop_Identifier_Prefix (Mark); - end; - when others => - Error_Kind ("translate_block_configuration_decls(1)", El); - end case; - El := Get_Chain (El); - end loop; - end Translate_Block_Configuration_Decls; - - procedure Translate_Component_Configuration_Call - (Cfg : Iir; Base_Block : Iir; Block_Info : Block_Info_Acc) - is - Cfg_Info : Config_Info_Acc; - Base_Info : Block_Info_Acc; - begin - if Get_Binding_Indication (Cfg) = Null_Iir then - -- Unbound component configuration, nothing to do. - return; - end if; - - Cfg_Info := Get_Info (Cfg); - Base_Info := Get_Info (Base_Block); - - -- Call the subprogram for the instantiation list. - declare - List : Iir_List; - El : Iir; - begin - List := Get_Instantiation_List (Cfg); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - El := Get_Named_Entity (El); - case Get_Kind (El) is - when Iir_Kind_Component_Instantiation_Statement => - declare - Assoc : O_Assoc_List; - Info : constant Block_Info_Acc := Get_Info (El); - Comp_Info : constant Comp_Info_Acc := - Get_Info (Get_Named_Entity - (Get_Instantiated_Unit (El))); - V : O_Lnode; - begin - -- The component is really a component and not a - -- direct instance. - Start_Association (Assoc, Cfg_Info.Config_Subprg); - V := Get_Instance_Ref (Block_Info.Block_Scope); - V := New_Selected_Element (V, Info.Block_Link_Field); - New_Association - (Assoc, New_Address (V, Comp_Info.Comp_Ptr_Type)); - V := Get_Instance_Ref (Base_Info.Block_Scope); - New_Association - (Assoc, - New_Address (V, Base_Info.Block_Decls_Ptr_Type)); - New_Procedure_Call (Assoc); - end; - when others => - Error_Kind ("translate_component_configuration", El); - end case; - end loop; - end; - end Translate_Component_Configuration_Call; - - procedure Translate_Block_Configuration_Calls - (Block_Config : Iir_Block_Configuration; - Base_Block : Iir; - Base_Info : Block_Info_Acc); - - procedure Translate_Generate_Block_Configuration_Calls - (Block_Config : Iir_Block_Configuration; - Parent_Info : Block_Info_Acc) - is - Spec : constant Iir := Get_Block_Specification (Block_Config); - Block : constant Iir := Get_Block_From_Block_Specification (Spec); - Info : constant Block_Info_Acc := Get_Info (Block); - Scheme : constant Iir := Get_Generation_Scheme (Block); - - Type_Info : Type_Info_Acc; - Iter_Type : Iir; - - -- Generate a call for a iterative generate block whose index is - -- INDEX. - -- FAILS is true if it is an error if the block is already - -- configured. - procedure Gen_Subblock_Call (Index : O_Enode; Fails : Boolean) - is - Var_Inst : O_Dnode; - If_Blk : O_If_Block; - begin - Open_Temp; - Var_Inst := Create_Temp (Info.Block_Decls_Ptr_Type); - New_Assign_Stmt - (New_Obj (Var_Inst), - New_Address (New_Indexed_Element - (New_Acc_Value - (New_Selected_Element - (Get_Instance_Ref (Parent_Info.Block_Scope), - Info.Block_Parent_Field)), - Index), - Info.Block_Decls_Ptr_Type)); - -- Configure only if not yet configured. - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - New_Value_Selected_Acc_Value - (New_Obj (Var_Inst), - Info.Block_Configured_Field), - New_Lit (Ghdl_Bool_False_Node), - Ghdl_Bool_Type)); - -- Mark the block as configured. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var_Inst), - Info.Block_Configured_Field), - New_Lit (Ghdl_Bool_True_Node)); - Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var_Inst); - Translate_Block_Configuration_Calls (Block_Config, Block, Info); - Clear_Scope (Info.Block_Scope); - - if Fails then - New_Else_Stmt (If_Blk); - -- Already configured. - Chap6.Gen_Program_Error - (Block_Config, Chap6.Prg_Err_Block_Configured); - end if; - - Finish_If_Stmt (If_Blk); - Close_Temp; - end Gen_Subblock_Call; - - procedure Apply_To_All_Others_Blocks (Is_All : Boolean) - is - Var_I : O_Dnode; - Label : O_Snode; - begin - Start_Declare_Stmt; - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op - (ON_Eq, - New_Value (New_Obj (Var_I)), - New_Value - (New_Selected_Element - (Get_Var (Get_Info (Iter_Type).T.Range_Var), - Type_Info.T.Range_Length)), - Ghdl_Bool_Type)); - -- Selected_name is for default configurations, so - -- program should not fail if a block is already - -- configured but continue silently. - Gen_Subblock_Call (New_Value (New_Obj (Var_I)), Is_All); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Declare_Stmt; - end Apply_To_All_Others_Blocks; - begin - if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - Iter_Type := Get_Type (Scheme); - Type_Info := Get_Info (Get_Base_Type (Iter_Type)); - case Get_Kind (Spec) is - when Iir_Kind_Generate_Statement - | Iir_Kind_Simple_Name => - Apply_To_All_Others_Blocks (True); - when Iir_Kind_Indexed_Name => - declare - Index_List : constant Iir_List := Get_Index_List (Spec); - Rng : Mnode; - begin - if Index_List = Iir_List_Others then - Apply_To_All_Others_Blocks (False); - else - Open_Temp; - Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); - Gen_Subblock_Call - (Chap6.Translate_Index_To_Offset - (Rng, - Chap7.Translate_Expression - (Get_Nth_Element (Index_List, 0), Iter_Type), - Scheme, Iter_Type, Spec), - True); - Close_Temp; - end if; - end; - when Iir_Kind_Slice_Name => - declare - Rng : Mnode; - Slice : O_Dnode; - Slice_Ptr : O_Dnode; - Left, Right : O_Dnode; - Index : O_Dnode; - High : O_Dnode; - If_Blk : O_If_Block; - Label : O_Snode; - begin - Open_Temp; - Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); - Slice := Create_Temp (Type_Info.T.Range_Type); - Slice_Ptr := Create_Temp_Ptr - (Type_Info.T.Range_Ptr_Type, New_Obj (Slice)); - Chap7.Translate_Discrete_Range_Ptr - (Slice_Ptr, Get_Suffix (Spec)); - Left := Create_Temp_Init - (Ghdl_Index_Type, - Chap6.Translate_Index_To_Offset - (Rng, - New_Value (New_Selected_Element - (New_Obj (Slice), Type_Info.T.Range_Left)), - Spec, Iter_Type, Spec)); - Right := Create_Temp_Init - (Ghdl_Index_Type, - Chap6.Translate_Index_To_Offset - (Rng, - New_Value (New_Selected_Element - (New_Obj (Slice), - Type_Info.T.Range_Right)), - Spec, Iter_Type, Spec)); - Index := Create_Temp (Ghdl_Index_Type); - High := Create_Temp (Ghdl_Index_Type); - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - M2E (Chap3.Range_To_Dir (Rng)), - New_Value - (New_Selected_Element - (New_Obj (Slice), - Type_Info.T.Range_Dir)), - Ghdl_Bool_Type)); - -- Same direction, so left to right. - New_Assign_Stmt (New_Obj (Index), - New_Value (New_Obj (Left))); - New_Assign_Stmt (New_Obj (High), - New_Value (New_Obj (Right))); - New_Else_Stmt (If_Blk); - -- Opposite direction, so right to left. - New_Assign_Stmt (New_Obj (Index), - New_Value (New_Obj (Right))); - New_Assign_Stmt (New_Obj (High), - New_Value (New_Obj (Left))); - Finish_If_Stmt (If_Blk); - - -- Loop. - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, New_Compare_Op (ON_Gt, - New_Value (New_Obj (Index)), - New_Value (New_Obj (High)), - Ghdl_Bool_Type)); - Open_Temp; - Gen_Subblock_Call (New_Value (New_Obj (Index)), True); - Close_Temp; - Inc_Var (Index); - Finish_Loop_Stmt (Label); - Close_Temp; - end; - when others => - Error_Kind - ("translate_generate_block_configuration_calls", Spec); - end case; - else - -- Conditional generate statement. - declare - Var : O_Dnode; - If_Blk : O_If_Block; - begin - -- Configure the block only if it was created. - Open_Temp; - Var := Create_Temp_Init - (Info.Block_Decls_Ptr_Type, - New_Value (New_Selected_Element - (Get_Instance_Ref (Parent_Info.Block_Scope), - Info.Block_Parent_Field))); - Start_If_Stmt - (If_Blk, - New_Compare_Op - (ON_Neq, - New_Obj_Value (Var), - New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), - Ghdl_Bool_Type)); - Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); - Translate_Block_Configuration_Calls (Block_Config, Block, Info); - Clear_Scope (Info.Block_Scope); - Finish_If_Stmt (If_Blk); - Close_Temp; - end; - end if; - end Translate_Generate_Block_Configuration_Calls; - - procedure Translate_Block_Configuration_Calls - (Block_Config : Iir_Block_Configuration; - Base_Block : Iir; - Base_Info : Block_Info_Acc) - is - El : Iir; - begin - El := Get_Configuration_Item_Chain (Block_Config); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Component_Configuration - | Iir_Kind_Configuration_Specification => - Translate_Component_Configuration_Call - (El, Base_Block, Base_Info); - when Iir_Kind_Block_Configuration => - declare - Block : constant Iir := Strip_Denoting_Name - (Get_Block_Specification (El)); - begin - if Get_Kind (Block) = Iir_Kind_Block_Statement then - Translate_Block_Configuration_Calls - (El, Base_Block, Get_Info (Block)); - else - Translate_Generate_Block_Configuration_Calls - (El, Base_Info); - end if; - end; - when others => - Error_Kind ("translate_block_configuration_calls(2)", El); - end case; - El := Get_Chain (El); - end loop; - end Translate_Block_Configuration_Calls; - - procedure Translate_Configuration_Declaration (Config : Iir) - is - Block_Config : constant Iir_Block_Configuration := - Get_Block_Configuration (Config); - Arch : constant Iir_Architecture_Body := - Get_Block_Specification (Block_Config); - Arch_Info : constant Block_Info_Acc := Get_Info (Arch); - Interface_List : O_Inter_List; - Config_Info : Config_Info_Acc; - Instance : O_Dnode; - Num : Iir_Int32; - Final : Boolean; - begin - if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then - Chap4.Translate_Declaration_Chain (Config); - end if; - - Config_Info := Add_Info (Config, Kind_Config); - - -- Configurator. - Start_Procedure_Decl - (Interface_List, Create_Identifier, Global_Storage); - New_Interface_Decl (Interface_List, Instance, Wki_Instance, - Arch_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Interface_List, Config_Info.Config_Subprg); - - if Global_Storage = O_Storage_External then - return; - end if; - - -- Declare subprograms for configuration. - Num := 0; - Translate_Block_Configuration_Decls (Block_Config, Arch, Arch, Num); - - -- Body. - Start_Subprogram_Body (Config_Info.Config_Subprg); - Push_Local_Factory; - - Push_Architecture_Scope (Arch, Instance); - - if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then - Open_Temp; - Chap4.Elab_Declaration_Chain (Config, Final); - Close_Temp; - if Final then - raise Internal_Error; - end if; - end if; - - Translate_Block_Configuration_Calls (Block_Config, Arch, Arch_Info); - - Pop_Architecture_Scope (Arch); - Pop_Local_Factory; - Finish_Subprogram_Body; - end Translate_Configuration_Declaration; - end Chap1; - - package body Chap2 is - use Trans.Subprgs; - - procedure Elab_Package (Spec : Iir_Package_Declaration); - - type Name_String_Xlat_Array is array (Name_Id range <>) of - String (1 .. 4); - Operator_String_Xlat : constant - Name_String_Xlat_Array (Std_Names.Name_Id_Operators) := - (Std_Names.Name_Op_Equality => "OPEq", - Std_Names.Name_Op_Inequality => "OPNe", - Std_Names.Name_Op_Less => "OPLt", - Std_Names.Name_Op_Less_Equal => "OPLe", - Std_Names.Name_Op_Greater => "OPGt", - Std_Names.Name_Op_Greater_Equal => "OPGe", - Std_Names.Name_Op_Plus => "OPPl", - Std_Names.Name_Op_Minus => "OPMi", - Std_Names.Name_Op_Mul => "OPMu", - Std_Names.Name_Op_Div => "OPDi", - Std_Names.Name_Op_Exp => "OPEx", - Std_Names.Name_Op_Concatenation => "OPCc", - Std_Names.Name_Op_Condition => "OPCd", - Std_Names.Name_Op_Match_Equality => "OPQe", - Std_Names.Name_Op_Match_Inequality => "OPQi", - Std_Names.Name_Op_Match_Less => "OPQL", - Std_Names.Name_Op_Match_Less_Equal => "OPQl", - Std_Names.Name_Op_Match_Greater => "OPQG", - Std_Names.Name_Op_Match_Greater_Equal => "OPQg"); - - -- Set the identifier prefix with the subprogram identifier and - -- overload number if any. - procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type) - is - Id : Name_Id; - begin - -- FIXME: name_shift_operators, name_logical_operators, - -- name_word_operators, name_mod, name_rem - Id := Get_Identifier (Spec); - if Id in Std_Names.Name_Id_Operators then - Push_Identifier_Prefix - (Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec)); - else - Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec)); - end if; - end Push_Subprg_Identifier; - - procedure Translate_Subprogram_Interfaces (Spec : Iir) - is - Inter : Iir; - Mark : Id_Mark_Type; - begin - -- Set the identifier prefix with the subprogram identifier and - -- overload number if any. - Push_Subprg_Identifier (Spec, Mark); - - -- Translate interface types. - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Chap3.Translate_Object_Subtype (Inter); - Inter := Get_Chain (Inter); - end loop; - Pop_Identifier_Prefix (Mark); - end Translate_Subprogram_Interfaces; - - procedure Elab_Subprogram_Interfaces (Spec : Iir) - is - Inter : Iir; - begin - -- Translate interface types. - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Chap3.Elab_Object_Subtype (Get_Type (Inter)); - Inter := Get_Chain (Inter); - end loop; - end Elab_Subprogram_Interfaces; - - - -- Return the type of a subprogram interface. - -- Return O_Tnode_Null if the parameter is passed through the - -- interface record. - function Translate_Interface_Type (Inter : Iir) return O_Tnode - is - Mode : Object_Kind_Type; - Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); - begin - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_File_Declaration => - Mode := Mode_Value; - when Iir_Kind_Interface_Signal_Declaration => - Mode := Mode_Signal; - when others => - Error_Kind ("translate_interface_type", Inter); - end case; - case Tinfo.Type_Mode is - when Type_Mode_Unknown => - raise Internal_Error; - when Type_Mode_By_Value => - return Tinfo.Ortho_Type (Mode); - when Type_Mode_By_Copy - | Type_Mode_By_Ref => - return Tinfo.Ortho_Ptr_Type (Mode); - end case; - end Translate_Interface_Type; - - procedure Translate_Subprogram_Declaration (Spec : Iir) - is - Info : constant Subprg_Info_Acc := Get_Info (Spec); - Is_Func : constant Boolean := - Get_Kind (Spec) = Iir_Kind_Function_Declaration; - Inter : Iir; - Inter_Type : Iir; - Arg_Info : Ortho_Info_Acc; - Tinfo : Type_Info_Acc; - Interface_List : O_Inter_List; - Has_Result_Record : Boolean; - El_List : O_Element_List; - Mark : Id_Mark_Type; - Rtype : Iir; - Id : O_Ident; - Storage : O_Storage; - Foreign : Foreign_Info_Type := Foreign_Bad; - begin - -- Set the identifier prefix with the subprogram identifier and - -- overload number if any. - Push_Subprg_Identifier (Spec, Mark); - - if Get_Foreign_Flag (Spec) then - -- Special handling for foreign subprograms. - Foreign := Translate_Foreign_Id (Spec); - case Foreign.Kind is - when Foreign_Unknown => - Id := Create_Identifier; - when Foreign_Intrinsic => - Id := Create_Identifier; - when Foreign_Vhpidirect => - Id := Get_Identifier - (Name_Table.Name_Buffer (Foreign.Subprg_First - .. Foreign.Subprg_Last)); - end case; - Storage := O_Storage_External; - else - Id := Create_Identifier; - Storage := Global_Storage; - end if; - - if Is_Func then - -- If the result of a function is a composite type for ortho, - -- the result is allocated by the caller and an access to it is - -- given to the function. - Rtype := Get_Return_Type (Spec); - Info.Use_Stack2 := False; - Tinfo := Get_Info (Rtype); - - if Is_Composite (Tinfo) then - Start_Procedure_Decl (Interface_List, Id, Storage); - New_Interface_Decl - (Interface_List, Info.Res_Interface, - Get_Identifier ("RESULT"), - Tinfo.Ortho_Ptr_Type (Mode_Value)); - -- Furthermore, if the result type is unconstrained, the - -- function will allocate it on a secondary stack. - if not Is_Fully_Constrained_Type (Rtype) then - Info.Use_Stack2 := True; - end if; - else - -- Normal function. - Start_Function_Decl - (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value)); - Info.Res_Interface := O_Dnode_Null; - end if; - else - -- Create info for each interface of the procedure. - -- For parameters passed via copy and that needs a copy-out, - -- gather them in a record. An access to the record is then - -- passed to the procedure. - Has_Result_Record := False; - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Arg_Info := Add_Info (Inter, Kind_Interface); - Inter_Type := Get_Type (Inter); - Tinfo := Get_Info (Inter_Type); - if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration - and then Get_Mode (Inter) in Iir_Out_Modes - and then Tinfo.Type_Mode not in Type_Mode_By_Ref - and then Tinfo.Type_Mode /= Type_Mode_File - then - -- This interface is done via the result record. - -- Note: file passed through variables are vhdl87 files, - -- which are initialized at elaboration and thus - -- behave like an IN parameter. - if not Has_Result_Record then - -- Create the record. - Start_Record_Type (El_List); - Has_Result_Record := True; - end if; - -- Add a field to the record. - New_Record_Field (El_List, Arg_Info.Interface_Field, - Create_Identifier_Without_Prefix (Inter), - Tinfo.Ortho_Type (Mode_Value)); - else - Arg_Info.Interface_Field := O_Fnode_Null; - end if; - Inter := Get_Chain (Inter); - end loop; - if Has_Result_Record then - -- Declare the record type and an access to the record. - Finish_Record_Type (El_List, Info.Res_Record_Type); - New_Type_Decl (Create_Identifier ("RESTYPE"), - Info.Res_Record_Type); - Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type); - New_Type_Decl (Create_Identifier ("RESPTR"), - Info.Res_Record_Ptr); - else - Info.Res_Interface := O_Dnode_Null; - end if; - - Start_Procedure_Decl (Interface_List, Id, Storage); - - if Has_Result_Record then - -- Add the record parameter. - New_Interface_Decl (Interface_List, Info.Res_Interface, - Get_Identifier ("RESULT"), - Info.Res_Record_Ptr); - end if; - end if; - - -- Instance parameter if any. - if not Get_Foreign_Flag (Spec) then - Subprgs.Create_Subprg_Instance (Interface_List, Spec); - end if; - - -- Translate interfaces. - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - if Is_Func then - -- Create the info. - Arg_Info := Add_Info (Inter, Kind_Interface); - Arg_Info.Interface_Field := O_Fnode_Null; - else - -- The info was already created (just above) - Arg_Info := Get_Info (Inter); - end if; - - if Arg_Info.Interface_Field = O_Fnode_Null then - -- Not via the RESULT parameter. - Arg_Info.Interface_Type := Translate_Interface_Type (Inter); - New_Interface_Decl - (Interface_List, Arg_Info.Interface_Node, - Create_Identifier_Without_Prefix (Inter), - Arg_Info.Interface_Type); - end if; - Inter := Get_Chain (Inter); - end loop; - Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); - - -- Call the hook for foreign subprograms. - if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then - Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func); - end if; - - Save_Local_Identifier (Info.Subprg_Local_Id); - Pop_Identifier_Prefix (Mark); - end Translate_Subprogram_Declaration; - - -- Return TRUE iff subprogram specification SPEC is translated in an - -- ortho function. - function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean - is - begin - if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then - return False; - end if; - if Get_Info (Spec).Res_Interface /= O_Dnode_Null then - return False; - end if; - return True; - end Is_Subprogram_Ortho_Function; - - -- Return TRUE iif SUBPRG_BODY declares explicitely or implicitely - -- (or even implicitely by translation) a subprogram. - function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean - is - Decl : Iir; - Atype : Iir; - begin - Decl := Get_Declaration_Chain (Subprg_Body); - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - return True; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - -- The declaration preceed the body. - raise Internal_Error; - when Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration => - Atype := Get_Type_Definition (Decl); - case Iir_Kinds_Type_And_Subtype_Definition - (Get_Kind (Atype)) is - when Iir_Kinds_Scalar_Type_Definition => - null; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - null; - when Iir_Kind_File_Type_Definition => - return True; - when Iir_Kind_Protected_Type_Declaration => - raise Internal_Error; - when Iir_Kinds_Composite_Type_Definition => - -- At least for "=". - return True; - when Iir_Kind_Incomplete_Type_Definition => - null; - end case; - when others => - null; - end case; - Decl := Get_Chain (Decl); - end loop; - return False; - end Has_Nested_Subprograms; - - procedure Translate_Subprogram_Body (Subprg : Iir) - is - Spec : constant Iir := Get_Subprogram_Specification (Subprg); - Info : constant Ortho_Info_Acc := Get_Info (Spec); - - Old_Subprogram : Iir; - Mark : Id_Mark_Type; - Final : Boolean; - Is_Ortho_Func : Boolean; - - -- Set for a public method. In this case, the lock must be acquired - -- and retained. - Is_Prot : Boolean := False; - - -- True if the body has local (nested) subprograms. - Has_Nested : Boolean; - - Frame_Ptr_Type : O_Tnode; - Upframe_Field : O_Fnode; - - Frame : O_Dnode; - Frame_Ptr : O_Dnode; - - Has_Return : Boolean; - - Prev_Subprg_Instances : Subprgs.Subprg_Instance_Stack; - begin - -- Do not translate body for foreign subprograms. - if Get_Foreign_Flag (Spec) then - return; - end if; - - -- Check if there are nested subprograms to unnest. In that case, - -- a frame record is created, which is less efficient than the - -- use of local variables. - if Flag_Unnest_Subprograms then - Has_Nested := Has_Nested_Subprograms (Subprg); - else - Has_Nested := False; - end if; - - -- Set the identifier prefix with the subprogram identifier and - -- overload number if any. - Push_Subprg_Identifier (Spec, Mark); - Restore_Local_Identifier (Info.Subprg_Local_Id); - - if Has_Nested then - -- Unnest subprograms. - -- Create an instance for the local declarations. - Push_Instance_Factory (Info.Subprg_Frame_Scope'Access); - Add_Subprg_Instance_Field (Upframe_Field); - - if Info.Res_Record_Ptr /= O_Tnode_Null then - Info.Res_Record_Var := - Create_Var (Create_Var_Identifier ("RESULT"), - Info.Res_Record_Ptr); - end if; - - -- Create fields for parameters. - -- FIXME: do it only if they are referenced in nested - -- subprograms. - declare - Inter : Iir; - Inter_Info : Inter_Info_Acc; - begin - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Inter_Info := Get_Info (Inter); - if Inter_Info.Interface_Node /= O_Dnode_Null then - Inter_Info.Interface_Field := - Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (Inter), - Inter_Info.Interface_Type); - end if; - Inter := Get_Chain (Inter); - end loop; - end; - - Chap4.Translate_Declaration_Chain (Subprg); - Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access); - - New_Type_Decl (Create_Identifier ("_FRAMETYPE"), - Get_Scope_Type (Info.Subprg_Frame_Scope)); - Declare_Scope_Acc - (Info.Subprg_Frame_Scope, - Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type); - - Rtis.Generate_Subprogram_Body (Subprg); - - -- Local frame - Subprgs.Push_Subprg_Instance - (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, - Wki_Upframe, Prev_Subprg_Instances); - -- Link to previous frame - Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instances, Upframe_Field); - - Chap4.Translate_Declaration_Chain_Subprograms (Subprg); - - -- Link to previous frame - Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instances, Upframe_Field); - -- Local frame - Subprgs.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances); - end if; - - -- Create the body - - Start_Subprogram_Body (Info.Ortho_Func); - - Start_Subprg_Instance_Use (Spec); - - -- Variables will be created on the stack. - Push_Local_Factory; - - -- Code has access to local (and outer) variables. - -- FIXME: this is not necessary if Has_Nested is set - Subprgs.Clear_Subprg_Instance (Prev_Subprg_Instances); - - -- There is a local scope for temporaries. - Open_Local_Temp; - - if not Has_Nested then - Chap4.Translate_Declaration_Chain (Subprg); - Rtis.Generate_Subprogram_Body (Subprg); - Chap4.Translate_Declaration_Chain_Subprograms (Subprg); - else - New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, - Get_Scope_Type (Info.Subprg_Frame_Scope)); - - New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"), - O_Storage_Local, Frame_Ptr_Type); - New_Assign_Stmt (New_Obj (Frame_Ptr), - New_Address (New_Obj (Frame), Frame_Ptr_Type)); - - -- FIXME: use direct reference (ie Frame instead of Frame_Ptr) - Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr); - - -- Set UPFRAME. - Subprgs.Set_Subprg_Instance_Field - (Frame_Ptr, Upframe_Field, Info.Subprg_Instance); - - if Info.Res_Record_Type /= O_Tnode_Null then - -- Initialize the RESULT field - New_Assign_Stmt (Get_Var (Info.Res_Record_Var), - New_Obj_Value (Info.Res_Interface)); - -- Do not reference the RESULT field in the subprogram body, - -- directly reference the RESULT parameter. - -- FIXME: has a flag (see below for parameters). - Info.Res_Record_Var := Null_Var; - end if; - - -- Copy parameters to FRAME. - declare - Inter : Iir; - Inter_Info : Inter_Info_Acc; - begin - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - Inter_Info := Get_Info (Inter); - if Inter_Info.Interface_Node /= O_Dnode_Null then - New_Assign_Stmt - (New_Selected_Element (New_Obj (Frame), - Inter_Info.Interface_Field), - New_Obj_Value (Inter_Info.Interface_Node)); - - -- Forget the reference to the field in FRAME, so that - -- this subprogram will directly reference the parameter - -- (and not its copy in the FRAME). - Inter_Info.Interface_Field := O_Fnode_Null; - end if; - Inter := Get_Chain (Inter); - end loop; - end; - end if; - - -- Init out parameters passed by value/copy. - declare - Inter : Iir; - Inter_Type : Iir; - Type_Info : Type_Info_Acc; - begin - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration - and then Get_Mode (Inter) = Iir_Out_Mode - then - Inter_Type := Get_Type (Inter); - Type_Info := Get_Info (Inter_Type); - if (Type_Info.Type_Mode in Type_Mode_By_Value - or Type_Info.Type_Mode in Type_Mode_By_Copy) - and then Type_Info.Type_Mode /= Type_Mode_File - then - Chap4.Init_Object - (Chap6.Translate_Name (Inter), Inter_Type); - end if; - end if; - Inter := Get_Chain (Inter); - end loop; - end; - - Chap4.Elab_Declaration_Chain (Subprg, Final); - - -- If finalization is required, create a dummy loop around the - -- body and convert returns into exit out of this loop. - -- If the subprogram is a function, also create a variable for the - -- result. - Is_Prot := Is_Subprogram_Method (Spec); - if Final or Is_Prot then - if Is_Prot then - -- Lock the object. - Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), - Ghdl_Protected_Enter); - end if; - Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec); - if Is_Ortho_Func then - New_Var_Decl - (Info.Subprg_Result, Get_Identifier ("RESULT"), - O_Storage_Local, - Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value)); - end if; - Start_Loop_Stmt (Info.Subprg_Exit); - end if; - - Old_Subprogram := Current_Subprogram; - Current_Subprogram := Spec; - Has_Return := Chap8.Translate_Statements_Chain_Has_Return - (Get_Sequential_Statement_Chain (Subprg)); - Current_Subprogram := Old_Subprogram; - - if Final or Is_Prot then - -- Create a barrier to catch missing return statement. - if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then - New_Exit_Stmt (Info.Subprg_Exit); - else - if not Has_Return then - -- Missing return - Chap6.Gen_Program_Error - (Subprg, Chap6.Prg_Err_Missing_Return); - end if; - end if; - Finish_Loop_Stmt (Info.Subprg_Exit); - Chap4.Final_Declaration_Chain (Subprg, False); - - if Is_Prot then - -- Unlock the object. - Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), - Ghdl_Protected_Leave); - end if; - if Is_Ortho_Func then - New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); - end if; - else - if Get_Kind (Spec) = Iir_Kind_Function_Declaration - and then not Has_Return - then - -- Missing return - Chap6.Gen_Program_Error - (Subprg, Chap6.Prg_Err_Missing_Return); - end if; - end if; - - if Has_Nested then - Clear_Scope (Info.Subprg_Frame_Scope); - end if; - - Subprgs.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances); - Close_Local_Temp; - Pop_Local_Factory; - - Finish_Subprg_Instance_Use (Spec); - - Finish_Subprogram_Body; - - Pop_Identifier_Prefix (Mark); - end Translate_Subprogram_Body; - - procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) - is - Header : constant Iir := Get_Package_Header (Decl); - Info : Ortho_Info_Acc; - Interface_List : O_Inter_List; - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - begin - Info := Add_Info (Decl, Kind_Package); - - -- Translate declarations. - if Is_Uninstantiated_Package (Decl) then - -- Create an instance for the spec. - Push_Instance_Factory (Info.Package_Spec_Scope'Access); - Chap4.Translate_Generic_Chain (Header); - Chap4.Translate_Declaration_Chain (Decl); - Info.Package_Elab_Var := Create_Var - (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); - Pop_Instance_Factory (Info.Package_Spec_Scope'Access); - - -- Name the spec instance and create a pointer. - New_Type_Decl (Create_Identifier ("SPECINSTTYPE"), - Get_Scope_Type (Info.Package_Spec_Scope)); - Declare_Scope_Acc (Info.Package_Spec_Scope, - Create_Identifier ("SPECINSTPTR"), - Info.Package_Spec_Ptr_Type); - - -- Create an instance and its pointer for the body. - Chap2.Declare_Inst_Type_And_Ptr - (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type); - - -- Each subprogram has a body instance argument. - Subprgs.Push_Subprg_Instance - (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, - Wki_Instance, Prev_Subprg_Instance); - else - Chap4.Translate_Declaration_Chain (Decl); - Info.Package_Elab_Var := Create_Var - (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); - end if; - - -- Translate subprograms declarations. - Chap4.Translate_Declaration_Chain_Subprograms (Decl); - - -- Declare elaborator for the body. - Start_Procedure_Decl - (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage); - Subprgs.Add_Subprg_Instance_Interfaces - (Interface_List, Info.Package_Elab_Body_Instance); - Finish_Subprogram_Decl - (Interface_List, Info.Package_Elab_Body_Subprg); - - if Is_Uninstantiated_Package (Decl) then - Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); - - -- The spec elaborator has a spec instance argument. - Subprgs.Push_Subprg_Instance - (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type, - Wki_Instance, Prev_Subprg_Instance); - end if; - - Start_Procedure_Decl - (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); - Subprgs.Add_Subprg_Instance_Interfaces - (Interface_List, Info.Package_Elab_Spec_Instance); - Finish_Subprogram_Decl - (Interface_List, Info.Package_Elab_Spec_Subprg); - - if Flag_Rti then - -- Generate RTI. - Rtis.Generate_Unit (Decl); - end if; - - if Global_Storage = O_Storage_Public then - -- Create elaboration procedure for the spec - Elab_Package (Decl); - end if; - - if Is_Uninstantiated_Package (Decl) then - Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); - end if; - Save_Local_Identifier (Info.Package_Local_Id); - end Translate_Package_Declaration; - - procedure Translate_Package_Body (Decl : Iir_Package_Body) - is - Spec : constant Iir_Package_Declaration := Get_Package (Decl); - Info : constant Ortho_Info_Acc := Get_Info (Spec); - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - begin - -- Translate declarations. - if Is_Uninstantiated_Package (Spec) then - Push_Instance_Factory (Info.Package_Body_Scope'Access); - Info.Package_Spec_Field := Add_Instance_Factory_Field - (Get_Identifier ("SPEC"), - Get_Scope_Type (Info.Package_Spec_Scope)); - - Chap4.Translate_Declaration_Chain (Decl); - - Pop_Instance_Factory (Info.Package_Body_Scope'Access); - - if Global_Storage = O_Storage_External then - return; - end if; - else - -- May be called during elaboration to generate RTI. - if Global_Storage = O_Storage_External then - return; - end if; - - Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id); - - Chap4.Translate_Declaration_Chain (Decl); - end if; - - if Flag_Rti then - Rtis.Generate_Unit (Decl); - end if; - - if Is_Uninstantiated_Package (Spec) then - Subprgs.Push_Subprg_Instance - (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, - Wki_Instance, Prev_Subprg_Instance); - Set_Scope_Via_Field (Info.Package_Spec_Scope, - Info.Package_Spec_Field, - Info.Package_Body_Scope'Access); - end if; - - Chap4.Translate_Declaration_Chain_Subprograms (Decl); - - if Is_Uninstantiated_Package (Spec) then - Clear_Scope (Info.Package_Spec_Scope); - Subprgs.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); - end if; - - Elab_Package_Body (Spec, Decl); - end Translate_Package_Body; - - procedure Elab_Package (Spec : Iir_Package_Declaration) - is - Info : constant Ortho_Info_Acc := Get_Info (Spec); - Final : Boolean; - Constr : O_Assoc_List; - pragma Unreferenced (Final); - begin - Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); - Push_Local_Factory; - Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); - - Elab_Dependence (Get_Design_Unit (Spec)); - - if not Is_Uninstantiated_Package (Spec) - and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit - then - -- Register the top level package. This is done dynamically, as - -- we know only during elaboration that the design depends on a - -- package (a package maybe referenced by an entity which is never - -- instantiated due to generate statements). - Start_Association (Constr, Ghdl_Rti_Add_Package); - New_Association - (Constr, - New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); - New_Procedure_Call (Constr); - end if; - - Open_Temp; - Chap4.Elab_Declaration_Chain (Spec, Final); - Close_Temp; - - Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); - Pop_Local_Factory; - Finish_Subprogram_Body; - end Elab_Package; - - procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) - is - Info : constant Ortho_Info_Acc := Get_Info (Spec); - If_Blk : O_If_Block; - Constr : O_Assoc_List; - Final : Boolean; - begin - Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); - Push_Local_Factory; - Subprgs.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); - - if Is_Uninstantiated_Package (Spec) then - Set_Scope_Via_Field (Info.Package_Spec_Scope, - Info.Package_Spec_Field, - Info.Package_Body_Scope'Access); - end if; - - -- If the package was already elaborated, return now, - -- else mark the package as elaborated. - Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var))); - New_Return_Stmt; - New_Else_Stmt (If_Blk); - New_Assign_Stmt (Get_Var (Info.Package_Elab_Var), - New_Lit (Ghdl_Bool_True_Node)); - Finish_If_Stmt (If_Blk); - - -- Elab Spec. - Start_Association (Constr, Info.Package_Elab_Spec_Subprg); - Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance); - New_Procedure_Call (Constr); - - if Bod /= Null_Iir then - Elab_Dependence (Get_Design_Unit (Bod)); - Open_Temp; - Chap4.Elab_Declaration_Chain (Bod, Final); - Close_Temp; - end if; - - if Is_Uninstantiated_Package (Spec) then - Clear_Scope (Info.Package_Spec_Scope); - end if; - - Subprgs.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); - Pop_Local_Factory; - Finish_Subprogram_Body; - end Elab_Package_Body; - - procedure Instantiate_Iir_Info (N : Iir); - - procedure Instantiate_Iir_Chain_Info (Chain : Iir) - is - N : Iir; - begin - N := Chain; - while N /= Null_Iir loop - Instantiate_Iir_Info (N); - N := Get_Chain (N); - end loop; - end Instantiate_Iir_Chain_Info; - - procedure Instantiate_Iir_List_Info (L : Iir_List) - is - El : Iir; - begin - case L is - when Null_Iir_List - | Iir_List_All - | Iir_List_Others => - return; - when others => - for I in Natural loop - El := Get_Nth_Element (L, I); - exit when El = Null_Iir; - Instantiate_Iir_Info (El); - end loop; - end case; - end Instantiate_Iir_List_Info; - - procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is - begin - case Src.Kind is - when Kind_Type => - Dest.all := (Kind => Kind_Type, - Type_Mode => Src.Type_Mode, - Type_Incomplete => Src.Type_Incomplete, - Type_Locally_Constrained => - Src.Type_Locally_Constrained, - C => null, - Ortho_Type => Src.Ortho_Type, - Ortho_Ptr_Type => Src.Ortho_Ptr_Type, - Type_Transient_Chain => Null_Iir, - T => Src.T, - Type_Rti => Src.Type_Rti); - pragma Assert (Src.C = null); - pragma Assert (Src.Type_Transient_Chain = Null_Iir); - when Kind_Object => - pragma Assert (Src.Object_Driver = Null_Var); - pragma Assert (Src.Object_Function = O_Dnode_Null); - Dest.all := - (Kind => Kind_Object, - Object_Static => Src.Object_Static, - Object_Var => Instantiate_Var (Src.Object_Var), - Object_Driver => Null_Var, - Object_Rti => Src.Object_Rti, - Object_Function => O_Dnode_Null); - when Kind_Subprg => - Dest.Subprg_Frame_Scope := - Instantiate_Var_Scope (Src.Subprg_Frame_Scope); - Dest.all := - (Kind => Kind_Subprg, - Use_Stack2 => Src.Use_Stack2, - Ortho_Func => Src.Ortho_Func, - Res_Interface => Src.Res_Interface, - Res_Record_Var => Instantiate_Var (Src.Res_Record_Var), - Res_Record_Type => Src.Res_Record_Type, - Res_Record_Ptr => Src.Res_Record_Ptr, - Subprg_Frame_Scope => Dest.Subprg_Frame_Scope, - Subprg_Instance => Instantiate_Subprg_Instance - (Src.Subprg_Instance), - Subprg_Resolv => null, - Subprg_Local_Id => Src.Subprg_Local_Id, - Subprg_Exit => Src.Subprg_Exit, - Subprg_Result => Src.Subprg_Result); - when Kind_Interface => - Dest.all := (Kind => Kind_Interface, - Interface_Node => Src.Interface_Node, - Interface_Field => Src.Interface_Field, - Interface_Type => Src.Interface_Type); - when Kind_Index => - Dest.all := (Kind => Kind_Index, - Index_Field => Src.Index_Field); - when Kind_Expr => - Dest.all := (Kind => Kind_Expr, - Expr_Node => Src.Expr_Node); - when others => - raise Internal_Error; - end case; - end Copy_Info; - - procedure Instantiate_Iir_Info (N : Iir) is - begin - -- Nothing to do for null node. - if N = Null_Iir then - return; - end if; - - declare - use Nodes_Meta; - Kind : constant Iir_Kind := Get_Kind (N); - Fields : constant Fields_Array := Get_Fields (Kind); - F : Fields_Enum; - Orig : constant Iir := Sem_Inst.Get_Origin (N); - pragma Assert (Orig /= Null_Iir); - Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig); - Info : Ortho_Info_Acc; - begin - if Orig_Info /= null then - Info := Add_Info (N, Orig_Info.Kind); - - Copy_Info (Info, Orig_Info); - - case Info.Kind is - when Kind_Subprg => - Push_Instantiate_Var_Scope - (Info.Subprg_Frame_Scope'Access, - Orig_Info.Subprg_Frame_Scope'Access); - when others => - null; - end case; - end if; - - for I in Fields'Range loop - F := Fields (I); - case Get_Field_Type (F) is - when Type_Iir => - case Get_Field_Attribute (F) is - when Attr_None => - Instantiate_Iir_Info (Get_Iir (N, F)); - when Attr_Ref => - null; - when Attr_Maybe_Ref => - if not Get_Is_Ref (N) then - Instantiate_Iir_Info (Get_Iir (N, F)); - end if; - when Attr_Chain => - Instantiate_Iir_Chain_Info (Get_Iir (N, F)); - when Attr_Chain_Next => - null; - when Attr_Of_Ref => - raise Internal_Error; - end case; - when Type_Iir_List => - case Get_Field_Attribute (F) is - when Attr_None => - Instantiate_Iir_List_Info (Get_Iir_List (N, F)); - when Attr_Ref - | Attr_Of_Ref => - null; - when others => - raise Internal_Error; - end case; - when Type_PSL_NFA - | Type_PSL_Node => - -- TODO - raise Internal_Error; - when Type_Date_Type - | Type_Date_State_Type - | Type_Time_Stamp_Id => - -- Can this happen ? - raise Internal_Error; - when Type_String_Id - | Type_Source_Ptr - | Type_Base_Type - | Type_Iir_Constraint - | Type_Iir_Mode - | Type_Iir_Index32 - | Type_Iir_Int64 - | Type_Boolean - | Type_Iir_Staticness - | Type_Iir_All_Sensitized - | Type_Iir_Signal_Kind - | Type_Tri_State_Type - | Type_Iir_Pure_State - | Type_Iir_Delay_Mechanism - | Type_Iir_Lexical_Layout_Type - | Type_Iir_Predefined_Functions - | Type_Iir_Direction - | Type_Location_Type - | Type_Iir_Int32 - | Type_Int32 - | Type_Iir_Fp64 - | Type_Token_Type - | Type_Name_Id => - null; - end case; - end loop; - - if Info /= null then - case Info.Kind is - when Kind_Subprg => - Pop_Instantiate_Var_Scope - (Info.Subprg_Frame_Scope'Access); - when others => - null; - end case; - end if; - end; - end Instantiate_Iir_Info; - - procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir) - is - Inter : Iir; - Orig : Iir; - Orig_Info : Ortho_Info_Acc; - Info : Ortho_Info_Acc; - begin - Inter := Chain; - while Inter /= Null_Iir loop - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration => - Orig := Sem_Inst.Get_Origin (Inter); - Orig_Info := Get_Info (Orig); - - Info := Add_Info (Inter, Orig_Info.Kind); - Copy_Info (Info, Orig_Info); - - when Iir_Kind_Interface_Package_Declaration => - null; - - when others => - raise Internal_Error; - end case; - - Inter := Get_Chain (Inter); - end loop; - end Instantiate_Iir_Generic_Chain_Info; - - -- Add info for an interface_package_declaration or a - -- package_instantiation_declaration - procedure Instantiate_Info_Package (Inst : Iir) - is - Spec : constant Iir := - Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); - Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); - Info : Ortho_Info_Acc; - begin - Info := Add_Info (Inst, Kind_Package_Instance); - - -- Create the info instances. - Push_Instantiate_Var_Scope - (Info.Package_Instance_Spec_Scope'Access, - Pkg_Info.Package_Spec_Scope'Access); - Push_Instantiate_Var_Scope - (Info.Package_Instance_Body_Scope'Access, - Pkg_Info.Package_Body_Scope'Access); - Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst)); - Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst)); - Pop_Instantiate_Var_Scope - (Info.Package_Instance_Body_Scope'Access); - Pop_Instantiate_Var_Scope - (Info.Package_Instance_Spec_Scope'Access); - end Instantiate_Info_Package; - - procedure Translate_Package_Instantiation_Declaration (Inst : Iir) - is - Spec : constant Iir := - Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); - Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); - Info : Ortho_Info_Acc; - Interface_List : O_Inter_List; - Constr : O_Assoc_List; - begin - Instantiate_Info_Package (Inst); - Info := Get_Info (Inst); - - -- FIXME: if the instantiation occurs within a package declaration, - -- the variable must be declared extern (and public in the body). - Info.Package_Instance_Body_Var := Create_Var - (Create_Var_Identifier (Inst), - Get_Scope_Type (Pkg_Info.Package_Body_Scope)); - - -- FIXME: this is correct only for global instantiation, and only if - -- there is only one. - Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope, - Get_Var_Label (Info.Package_Instance_Body_Var)); - Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope, - Pkg_Info.Package_Spec_Field, - Info.Package_Instance_Body_Scope'Access); - - -- Declare elaboration procedure - Start_Procedure_Decl - (Interface_List, Create_Identifier ("ELAB"), Global_Storage); - -- Chap2.Add_Subprg_Instance_Interfaces - -- (Interface_List, Info.Package_Instance_Elab_Instance); - Finish_Subprogram_Decl - (Interface_List, Info.Package_Instance_Elab_Subprg); - - if Global_Storage /= O_Storage_Public then - return; - end if; - - -- Elaborator: - Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg); - -- Chap2.Start_Subprg_Instance_Use - -- (Info.Package_Instance_Elab_Instance); - - Elab_Dependence (Get_Design_Unit (Inst)); - - Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, - Get_Var_Label (Info.Package_Instance_Body_Var)); - Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope, - Pkg_Info.Package_Spec_Field, - Pkg_Info.Package_Body_Scope'Access); - Chap5.Elab_Generic_Map_Aspect (Inst); - Clear_Scope (Pkg_Info.Package_Spec_Scope); - Clear_Scope (Pkg_Info.Package_Body_Scope); - - -- Call the elaborator of the generic. The generic must be - -- temporary associated with the instance variable. - Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg); - Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, - Get_Var_Label (Info.Package_Instance_Body_Var)); - Add_Subprg_Instance_Assoc - (Constr, Pkg_Info.Package_Elab_Body_Instance); - Clear_Scope (Pkg_Info.Package_Body_Scope); - New_Procedure_Call (Constr); - - -- Chap2.Finish_Subprg_Instance_Use - -- (Info.Package_Instance_Elab_Instance); - Finish_Subprogram_Body; - end Translate_Package_Instantiation_Declaration; - - procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration) - is - Info : Ortho_Info_Acc; - If_Blk : O_If_Block; - Constr : O_Assoc_List; - begin - -- Std.Standard is pre-elaborated. - if Pkg = Standard_Package then - return; - end if; - - -- Nothing to do for uninstantiated package. - if Is_Uninstantiated_Package (Pkg) then - return; - end if; - - -- Call the package elaborator only if not already elaborated. - Info := Get_Info (Pkg); - Start_If_Stmt - (If_Blk, - New_Monadic_Op (ON_Not, - New_Value (Get_Var (Info.Package_Elab_Var)))); - -- Elaborates only non-elaborated packages. - Start_Association (Constr, Info.Package_Elab_Body_Subprg); - New_Procedure_Call (Constr); - Finish_If_Stmt (If_Blk); - end Elab_Dependence_Package; - - procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) - is - Info : constant Ortho_Info_Acc := Get_Info (Pkg); - Constr : O_Assoc_List; - begin - Start_Association (Constr, Info.Package_Instance_Elab_Subprg); - New_Procedure_Call (Constr); - end Elab_Dependence_Package_Instantiation; - - procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) - is - Depend_List: Iir_Design_Unit_List; - Design: Iir; - Library_Unit: Iir; - begin - Depend_List := Get_Dependence_List (Design_Unit); - - for I in Natural loop - Design := Get_Nth_Element (Depend_List, I); - exit when Design = Null_Iir; - if Get_Kind (Design) = Iir_Kind_Design_Unit then - Library_Unit := Get_Library_Unit (Design); - case Get_Kind (Library_Unit) is - when Iir_Kind_Package_Declaration => - Elab_Dependence_Package (Library_Unit); - when Iir_Kind_Package_Instantiation_Declaration => - Elab_Dependence_Package_Instantiation (Library_Unit); - when Iir_Kind_Entity_Declaration => - -- FIXME: architecture already elaborates its entity. - null; - when Iir_Kind_Configuration_Declaration => - null; - when Iir_Kind_Architecture_Body => - null; - when Iir_Kind_Package_Body => - -- A package instantiation depends on the body. - null; - when others => - Error_Kind ("elab_dependence", Library_Unit); - end case; - end if; - end loop; - end Elab_Dependence; - - procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; - Ptr_Type : out O_Tnode) is - begin - Predeclare_Scope_Type (Scope, Create_Identifier ("INSTTYPE")); - Declare_Scope_Acc - (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type); - end Declare_Inst_Type_And_Ptr; - - end Chap2; - - package body Chap3 is - function Create_Static_Type_Definition_Type_Range (Def : Iir) - return O_Cnode; - procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode); - - -- For scalar subtypes: creates info from the base type. - procedure Create_Subtype_Info_From_Type (Def : Iir; - Subtype_Info : Type_Info_Acc; - Base_Info : Type_Info_Acc); - - -- Finish a type definition: declare the type, define and declare a - -- pointer to the type. - procedure Finish_Type_Definition - (Info : Type_Info_Acc; Completion : Boolean := False) - is - begin - -- Declare the type. - if not Completion then - New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); - end if; - - -- Create an access to the type and declare it. - Info.Ortho_Ptr_Type (Mode_Value) := - New_Access_Type (Info.Ortho_Type (Mode_Value)); - New_Type_Decl (Create_Identifier ("PTR"), - Info.Ortho_Ptr_Type (Mode_Value)); - - -- Signal type. - if Info.Type_Mode in Type_Mode_Scalar then - Info.Ortho_Type (Mode_Signal) := - New_Access_Type (Info.Ortho_Type (Mode_Value)); - end if; - if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then - New_Type_Decl (Create_Identifier ("SIG"), - Info.Ortho_Type (Mode_Signal)); - end if; - - -- Signal pointer type. - if Info.Type_Mode in Type_Mode_Composite - and then Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null - then - Info.Ortho_Ptr_Type (Mode_Signal) := - New_Access_Type (Info.Ortho_Type (Mode_Signal)); - New_Type_Decl (Create_Identifier ("SIGPTR"), - Info.Ortho_Ptr_Type (Mode_Signal)); - else - Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; - end if; - end Finish_Type_Definition; - - procedure Create_Size_Var (Def : Iir) - is - Info : constant Type_Info_Acc := Get_Info (Def); - begin - Info.C := new Complex_Type_Arr_Info; - Info.C (Mode_Value).Size_Var := Create_Var - (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); - if Get_Has_Signal_Flag (Def) then - Info.C (Mode_Signal).Size_Var := Create_Var - (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); - end if; - end Create_Size_Var; - - -- A builder set internal fields of object pointed by BASE_PTR, using - -- memory from BASE_PTR and returns a pointer to the next memory byte - -- to be used. - procedure Create_Builder_Subprogram_Decl (Info : Type_Info_Acc; - Name : Name_Id; - Kind : Object_Kind_Type) - is - Interface_List : O_Inter_List; - Ident : O_Ident; - Ptype : O_Tnode; - begin - case Kind is - when Mode_Value => - Ident := Create_Identifier (Name, "_BUILDER"); - when Mode_Signal => - Ident := Create_Identifier (Name, "_SIGBUILDER"); - end case; - -- FIXME: return the same type as its first parameter ??? - Start_Function_Decl - (Interface_List, Ident, Global_Storage, Ghdl_Index_Type); - Subprgs.Add_Subprg_Instance_Interfaces - (Interface_List, Info.C (Kind).Builder_Instance); - case Info.Type_Mode is - when Type_Mode_Fat_Array => - Ptype := Info.T.Base_Ptr_Type (Kind); - when Type_Mode_Record => - Ptype := Info.Ortho_Ptr_Type (Kind); - when others => - raise Internal_Error; - end case; - New_Interface_Decl - (Interface_List, Info.C (Kind).Builder_Base_Param, - Get_Identifier ("base_ptr"), Ptype); - -- Add parameter for array bounds. - if Info.Type_Mode = Type_Mode_Fat_Array then - New_Interface_Decl - (Interface_List, Info.C (Kind).Builder_Bound_Param, - Get_Identifier ("bound"), Info.T.Bounds_Ptr_Type); - end if; - Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func); - end Create_Builder_Subprogram_Decl; - - function Gen_Call_Type_Builder (Var_Ptr : O_Dnode; - Var_Type : Iir; - Kind : Object_Kind_Type) - return O_Enode - is - Tinfo : constant Type_Info_Acc := Get_Info (Var_Type); - Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type)); - Assoc : O_Assoc_List; - begin - -- Build the field - Start_Association (Assoc, Binfo.C (Kind).Builder_Func); - Subprgs.Add_Subprg_Instance_Assoc - (Assoc, Binfo.C (Kind).Builder_Instance); - - case Tinfo.Type_Mode is - when Type_Mode_Record - | Type_Mode_Array => - New_Association (Assoc, New_Obj_Value (Var_Ptr)); - when Type_Mode_Fat_Array => - -- Note: a fat array can only be at the top of a complex type; - -- the bounds must have been set. - New_Association - (Assoc, New_Value_Selected_Acc_Value - (New_Obj (Var_Ptr), Tinfo.T.Base_Field (Kind))); - when others => - raise Internal_Error; - end case; - - if Tinfo.Type_Mode in Type_Mode_Arrays then - declare - Arr : Mnode; - begin - case Type_Mode_Arrays (Tinfo.Type_Mode) is - when Type_Mode_Array => - Arr := T2M (Var_Type, Kind); - when Type_Mode_Fat_Array => - Arr := Dp2M (Var_Ptr, Tinfo, Kind); - end case; - New_Association - (Assoc, M2Addr (Chap3.Get_Array_Bounds (Arr))); - end; - end if; - - return New_Function_Call (Assoc); - end Gen_Call_Type_Builder; - - procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) - is - Mem : O_Dnode; - V : Mnode; - begin - Open_Temp; - V := Stabilize (Var); - Mem := Create_Temp (Ghdl_Index_Type); - New_Assign_Stmt - (New_Obj (Mem), - Gen_Call_Type_Builder (M2Dp (V), Var_Type, Get_Object_Kind (Var))); - Close_Temp; - end Gen_Call_Type_Builder; - - ------------------ - -- Enumeration -- - ------------------ - - function Translate_Enumeration_Literal (Lit : Iir_Enumeration_Literal) - return O_Ident - is - El_Str : String (1 .. 4); - Id : Name_Id; - N : Integer; - C : Character; - begin - Id := Get_Identifier (Lit); - if Name_Table.Is_Character (Id) then - C := Name_Table.Get_Character (Id); - El_Str (1) := 'C'; - case C is - when 'A' .. 'Z' - | 'a' .. 'z' - | '0' .. '9' => - El_Str (2) := '_'; - El_Str (3) := C; - when others => - N := Character'Pos (Name_Table.Get_Character (Id)); - El_Str (2) := N2hex (N / 16); - El_Str (3) := N2hex (N mod 16); - end case; - return Get_Identifier (El_Str (1 .. 3)); - else - return Create_Identifier_Without_Prefix (Lit); - end if; - end Translate_Enumeration_Literal; - - procedure Translate_Enumeration_Type - (Def : Iir_Enumeration_Type_Definition) - is - El_List : Iir_List; - El : Iir_Enumeration_Literal; - Constr : O_Enum_List; - Lit_Name : O_Ident; - Val : O_Cnode; - Info : Type_Info_Acc; - Nbr : Natural; - Size : Natural; - begin - El_List := Get_Enumeration_Literal_List (Def); - Nbr := Get_Nbr_Elements (El_List); - if Nbr <= 256 then - Size := 8; - else - Size := 32; - end if; - Start_Enum_Type (Constr, Size); - for I in Natural loop - El := Get_Nth_Element (El_List, I); - exit when El = Null_Iir; - - Lit_Name := Translate_Enumeration_Literal (El); - New_Enum_Literal (Constr, Lit_Name, Val); - Set_Ortho_Expr (El, Val); - end loop; - Info := Get_Info (Def); - Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value)); - if Nbr <= 256 then - Info.Type_Mode := Type_Mode_E8; - else - Info.Type_Mode := Type_Mode_E32; - end if; - -- Enumerations are always in their range. - Info.T.Nocheck_Low := True; - Info.T.Nocheck_Hi := True; - Finish_Type_Definition (Info); - end Translate_Enumeration_Type; - - procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition) - is - Info : Type_Info_Acc; - El_List : Iir_List; - True_Lit, False_Lit : Iir_Enumeration_Literal; - False_Node, True_Node : O_Cnode; - begin - Info := Get_Info (Def); - El_List := Get_Enumeration_Literal_List (Def); - if Get_Nbr_Elements (El_List) /= 2 then - raise Internal_Error; - end if; - False_Lit := Get_Nth_Element (El_List, 0); - True_Lit := Get_Nth_Element (El_List, 1); - New_Boolean_Type - (Info.Ortho_Type (Mode_Value), - Translate_Enumeration_Literal (False_Lit), False_Node, - Translate_Enumeration_Literal (True_Lit), True_Node); - Info.Type_Mode := Type_Mode_B1; - Set_Ortho_Expr (False_Lit, False_Node); - Set_Ortho_Expr (True_Lit, True_Node); - Info.T.Nocheck_Low := True; - Info.T.Nocheck_Hi := True; - Finish_Type_Definition (Info); - end Translate_Bool_Type; - - --------------- - -- Integer -- - --------------- - - -- Return the number of bits (32 or 64) required to represent the - -- (integer or physical) type definition DEF. - type Type_Precision is (Precision_32, Precision_64); - function Get_Type_Precision (Def : Iir) return Type_Precision - is - St : Iir; - L, H : Iir; - Lv, Hv : Iir_Int64; - begin - St := Get_Subtype_Definition (Get_Type_Declarator (Def)); - Get_Low_High_Limit (Get_Range_Constraint (St), L, H); - Lv := Get_Value (L); - Hv := Get_Value (H); - if Lv >= -(2 ** 31) and then Hv <= (2 ** 31 - 1) then - return Precision_32; - else - if Flag_Only_32b then - Error_Msg_Sem - ("range of " & Disp_Node (Get_Type_Declarator (St)) - & " is too large", St); - return Precision_32; - end if; - return Precision_64; - end if; - end Get_Type_Precision; - - procedure Translate_Integer_Type - (Def : Iir_Integer_Type_Definition) - is - Info : Type_Info_Acc; - begin - Info := Get_Info (Def); - case Get_Type_Precision (Def) is - when Precision_32 => - Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); - Info.Type_Mode := Type_Mode_I32; - when Precision_64 => - Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); - Info.Type_Mode := Type_Mode_I64; - end case; - -- Integers are always in their ranges. - Info.T.Nocheck_Low := True; - Info.T.Nocheck_Hi := True; - - Finish_Type_Definition (Info); - end Translate_Integer_Type; - - ---------------------- - -- Floating types -- - ---------------------- - - procedure Translate_Floating_Type (Def : Iir_Floating_Type_Definition) - is - Info : Type_Info_Acc; - begin - -- FIXME: should check precision - Info := Get_Info (Def); - Info.Type_Mode := Type_Mode_F64; - Info.Ortho_Type (Mode_Value) := New_Float_Type; - -- Reals are always in their ranges. - Info.T.Nocheck_Low := True; - Info.T.Nocheck_Hi := True; - - Finish_Type_Definition (Info); - end Translate_Floating_Type; - - ---------------- - -- Physical -- - ---------------- - - procedure Translate_Physical_Type (Def : Iir_Physical_Type_Definition) - is - Info : Type_Info_Acc; - begin - Info := Get_Info (Def); - case Get_Type_Precision (Def) is - when Precision_32 => - Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); - Info.Type_Mode := Type_Mode_P32; - when Precision_64 => - Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); - Info.Type_Mode := Type_Mode_P64; - end case; - -- Phyiscals are always in their ranges. - Info.T.Nocheck_Low := True; - Info.T.Nocheck_Hi := True; - - Finish_Type_Definition (Info); - end Translate_Physical_Type; - - procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition) - is - Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value); - Unit : Iir; - Info : Object_Info_Acc; - begin - Unit := Get_Unit_Chain (Def); - while Unit /= Null_Iir loop - Info := Add_Info (Unit, Kind_Object); - Info.Object_Var := - Create_Var (Create_Var_Identifier (Unit), Phy_Type); - Unit := Get_Chain (Unit); - end loop; - end Translate_Physical_Units; - - ------------ - -- File -- - ------------ - - procedure Translate_File_Type (Def : Iir_File_Type_Definition) - is - Info : Type_Info_Acc; - begin - Info := Get_Info (Def); - Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type; - Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type; - Info.Type_Mode := Type_Mode_File; - end Translate_File_Type; - - function Get_File_Signature_Length (Def : Iir) return Natural is - begin - case Get_Kind (Def) is - when Iir_Kinds_Scalar_Type_Definition => - return 1; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - return 2 - + Get_File_Signature_Length (Get_Element_Subtype (Def)); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - El : Iir; - Res : Natural; - List : Iir_List; - begin - Res := 2; - List := Get_Elements_Declaration_List (Get_Base_Type (Def)); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Res := Res + Get_File_Signature_Length (Get_Type (El)); - end loop; - return Res; - end; - when others => - Error_Kind ("get_file_signature_length", Def); - end case; - end Get_File_Signature_Length; - - procedure Get_File_Signature (Def : Iir; - Res : in out String; - Off : in out Natural) - is - Scalar_Map : constant array (Type_Mode_Scalar) of Character - := "beEiIpPF"; - begin - case Get_Kind (Def) is - when Iir_Kinds_Scalar_Type_Definition => - Res (Off) := Scalar_Map (Get_Info (Def).Type_Mode); - Off := Off + 1; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - Res (Off) := '['; - Off := Off + 1; - Get_File_Signature (Get_Element_Subtype (Def), Res, Off); - Res (Off) := ']'; - Off := Off + 1; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - El : Iir; - List : Iir_List; - begin - Res (Off) := '<'; - Off := Off + 1; - List := Get_Elements_Declaration_List (Get_Base_Type (Def)); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Get_File_Signature (Get_Type (El), Res, Off); - end loop; - Res (Off) := '>'; - Off := Off + 1; - end; - when others => - Error_Kind ("get_file_signature", Def); - end case; - end Get_File_Signature; - - procedure Create_File_Type_Var (Def : Iir_File_Type_Definition) - is - Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); - Info : Type_Info_Acc; - begin - if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition then - return; - end if; - declare - Len : constant Natural := Get_File_Signature_Length (Type_Name); - Sig : String (1 .. Len + 2); - Off : Natural := Sig'First; - begin - Get_File_Signature (Type_Name, Sig, Off); - Sig (Len + 1) := '.'; - Sig (Len + 2) := Character'Val (10); - Info := Get_Info (Def); - Info.T.File_Signature := Create_String - (Sig, Create_Identifier ("FILESIG"), Global_Storage); - end; - end Create_File_Type_Var; - - ------------- - -- Array -- - ------------- - - function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is - begin - if Get_Has_Signal_Flag (Def) then - return Mode_Signal; - else - return Mode_Value; - end if; - end Type_To_Last_Object_Kind; - - procedure Create_Array_Fat_Pointer - (Info : Type_Info_Acc; Kind : Object_Kind_Type) - is - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field - (Constr, Info.T.Base_Field (Kind), Get_Identifier ("BASE"), - Info.T.Base_Ptr_Type (Kind)); - New_Record_Field - (Constr, Info.T.Bounds_Field (Kind), Get_Identifier ("BOUNDS"), - Info.T.Bounds_Ptr_Type); - Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); - end Create_Array_Fat_Pointer; - - procedure Translate_Incomplete_Array_Type - (Def : Iir_Array_Type_Definition) - is - Arr_Info : Incomplete_Type_Info_Acc; - Info : Type_Info_Acc; - begin - Arr_Info := Get_Info (Def); - if Arr_Info.Incomplete_Array /= null then - -- This (incomplete) array type was already translated. - -- This is the case for a second access type definition to this - -- still incomplete array type. - return; - end if; - Info := new Ortho_Info_Type (Kind_Type); - Info.Type_Mode := Type_Mode_Fat_Array; - Info.Type_Incomplete := True; - Arr_Info.Incomplete_Array := Info; - - Info.T := Ortho_Info_Type_Array_Init; - Info.T.Bounds_Type := O_Tnode_Null; - - Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); - New_Type_Decl (Create_Identifier ("BOUNDP"), - Info.T.Bounds_Ptr_Type); - - Info.T.Base_Ptr_Type (Mode_Value) := New_Access_Type (O_Tnode_Null); - New_Type_Decl (Create_Identifier ("BASEP"), - Info.T.Base_Ptr_Type (Mode_Value)); - - Create_Array_Fat_Pointer (Info, Mode_Value); - - New_Type_Decl - (Create_Identifier, Info.Ortho_Type (Mode_Value)); - end Translate_Incomplete_Array_Type; - - -- Declare the bounds types for DEF. - procedure Translate_Array_Type_Bounds - (Def : Iir_Array_Type_Definition; - Info : Type_Info_Acc; - Complete : Boolean) - is - Indexes_List : constant Iir_List := - Get_Index_Subtype_Definition_List (Def); - Constr : O_Element_List; - Dim : String (1 .. 8); - N : Natural; - P : Natural; - Index : Iir; - Index_Info : Index_Info_Acc; - Index_Type_Mark : Iir; - begin - Start_Record_Type (Constr); - for I in Natural loop - Index_Type_Mark := Get_Nth_Element (Indexes_List, I); - exit when Index_Type_Mark = Null_Iir; - Index := Get_Index_Type (Index_Type_Mark); - - -- Index comes from a type mark. - pragma Assert (not Is_Anonymous_Type_Definition (Index)); - - Index_Info := Add_Info (Index_Type_Mark, Kind_Index); - - -- Build the name - N := I + 1; - P := Dim'Last; - loop - Dim (P) := Character'Val (Character'Pos ('0') + N mod 10); - P := P - 1; - N := N / 10; - exit when N = 0; - end loop; - P := P - 3; - Dim (P .. P + 3) := "dim_"; - - New_Record_Field (Constr, Index_Info.Index_Field, - Get_Identifier (Dim (P .. Dim'Last)), - Get_Info (Get_Base_Type (Index)).T.Range_Type); - end loop; - Finish_Record_Type (Constr, Info.T.Bounds_Type); - New_Type_Decl (Create_Identifier ("BOUND"), - Info.T.Bounds_Type); - if Complete then - Finish_Access_Type (Info.T.Bounds_Ptr_Type, Info.T.Bounds_Type); - else - Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); - New_Type_Decl (Create_Identifier ("BOUNDP"), - Info.T.Bounds_Ptr_Type); - end if; - end Translate_Array_Type_Bounds; - - procedure Translate_Array_Type_Base - (Def : Iir_Array_Type_Definition; - Info : Type_Info_Acc; - Complete : Boolean) - is - El_Type : Iir; - El_Tinfo : Type_Info_Acc; - Id, Idptr : O_Ident; - begin - El_Type := Get_Element_Subtype (Def); - Translate_Type_Definition (El_Type, True); - El_Tinfo := Get_Info (El_Type); - - if Is_Complex_Type (El_Tinfo) then - if El_Tinfo.Type_Mode = Type_Mode_Array then - Info.T.Base_Type := El_Tinfo.T.Base_Ptr_Type; - Info.T.Base_Ptr_Type := El_Tinfo.T.Base_Ptr_Type; - else - Info.T.Base_Type := El_Tinfo.Ortho_Ptr_Type; - Info.T.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type; - end if; - else - for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - case Kind is - when Mode_Value => - -- For the values. - Id := Create_Identifier ("BASE"); - if not Complete then - Idptr := Create_Identifier ("BASEP"); - else - Idptr := O_Ident_Nul; - end if; - when Mode_Signal => - -- For the signals - Id := Create_Identifier ("SIGBASE"); - Idptr := Create_Identifier ("SIGBASEP"); - end case; - Info.T.Base_Type (Kind) := - New_Array_Type (El_Tinfo.Ortho_Type (Kind), - Ghdl_Index_Type); - New_Type_Decl (Id, Info.T.Base_Type (Kind)); - if Is_Equal (Idptr, O_Ident_Nul) then - Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), - Info.T.Base_Type (Kind)); - else - Info.T.Base_Ptr_Type (Kind) := - New_Access_Type (Info.T.Base_Type (Kind)); - New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); - end if; - end loop; - end if; - end Translate_Array_Type_Base; - - -- For unidimensional arrays: create a constant bounds whose length - -- is 1, for concatenation with element. - procedure Translate_Static_Unidimensional_Array_Length_One - (Def : Iir_Array_Type_Definition) - is - Indexes : constant Iir_List := Get_Index_Subtype_List (Def); - Index_Type : Iir; - Index_Base_Type : Iir; - Constr : O_Record_Aggr_List; - Constr1 : O_Record_Aggr_List; - Arr_Info : Type_Info_Acc; - Tinfo : Type_Info_Acc; - Irange : Iir; - Res1 : O_Cnode; - Res : O_Cnode; - begin - if Get_Nbr_Elements (Indexes) /= 1 then - -- Not a one-dimensional array. - return; - end if; - Index_Type := Get_Index_Type (Indexes, 0); - Arr_Info := Get_Info (Def); - if Get_Type_Staticness (Index_Type) = Locally then - if Global_Storage /= O_Storage_External then - Index_Base_Type := Get_Base_Type (Index_Type); - Tinfo := Get_Info (Index_Base_Type); - Irange := Get_Range_Constraint (Index_Type); - Start_Record_Aggr (Constr, Arr_Info.T.Bounds_Type); - Start_Record_Aggr (Constr1, Tinfo.T.Range_Type); - New_Record_Aggr_El - (Constr1, - Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); - New_Record_Aggr_El - (Constr1, - Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); - New_Record_Aggr_El - (Constr1, Chap7.Translate_Static_Range_Dir (Irange)); - New_Record_Aggr_El - (Constr1, Ghdl_Index_1); - Finish_Record_Aggr (Constr1, Res1); - New_Record_Aggr_El (Constr, Res1); - Finish_Record_Aggr (Constr, Res); - else - Res := O_Cnode_Null; - end if; - Arr_Info.T.Array_1bound := Create_Global_Const - (Create_Identifier ("BR1"), - Arr_Info.T.Bounds_Type, Global_Storage, Res); - else - Arr_Info.T.Array_1bound := Create_Var - (Create_Var_Identifier ("BR1"), - Arr_Info.T.Bounds_Type, Global_Storage); - end if; - end Translate_Static_Unidimensional_Array_Length_One; - - procedure Translate_Dynamic_Unidimensional_Array_Length_One - (Def : Iir_Array_Type_Definition) - is - Indexes : constant Iir_List := Get_Index_Subtype_List (Def); - Index_Type : Iir; - Arr_Info : Type_Info_Acc; - Bound1, Rng : Mnode; - begin - if Get_Nbr_Elements (Indexes) /= 1 then - return; - end if; - Index_Type := Get_Index_Type (Indexes, 0); - if Get_Type_Staticness (Index_Type) = Locally then - return; - end if; - Arr_Info := Get_Info (Def); - Open_Temp; - Bound1 := Varv2M (Arr_Info.T.Array_1bound, Arr_Info, Mode_Value, - Arr_Info.T.Bounds_Type, Arr_Info.T.Bounds_Ptr_Type); - Bound1 := Bounds_To_Range (Bound1, Def, 1); - Stabilize (Bound1); - Rng := Type_To_Range (Index_Type); - Stabilize (Rng); - New_Assign_Stmt (M2Lv (Range_To_Dir (Bound1)), - M2E (Range_To_Dir (Rng))); - New_Assign_Stmt (M2Lv (Range_To_Left (Bound1)), - M2E (Range_To_Left (Rng))); - New_Assign_Stmt (M2Lv (Range_To_Right (Bound1)), - M2E (Range_To_Left (Rng))); - New_Assign_Stmt (M2Lv (Range_To_Length (Bound1)), - New_Lit (Ghdl_Index_1)); - Close_Temp; - end Translate_Dynamic_Unidimensional_Array_Length_One; - - procedure Translate_Array_Type_Definition - (Def : Iir_Array_Type_Definition) - is - Info : constant Type_Info_Acc := Get_Info (Def); - -- If true, INFO was already partially filled, by a previous access - -- type definition to this incomplete array type. - Completion : constant Boolean := Info.Type_Mode = Type_Mode_Fat_Array; - El_Tinfo : Type_Info_Acc; - begin - if not Completion then - Info.Type_Mode := Type_Mode_Fat_Array; - Info.T := Ortho_Info_Type_Array_Init; - end if; - Translate_Array_Type_Base (Def, Info, Completion); - Translate_Array_Type_Bounds (Def, Info, Completion); - Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - if not Completion then - Create_Array_Fat_Pointer (Info, Mode_Value); - end if; - if Get_Has_Signal_Flag (Def) then - Create_Array_Fat_Pointer (Info, Mode_Signal); - end if; - Finish_Type_Definition (Info, Completion); - - Translate_Static_Unidimensional_Array_Length_One (Def); - - El_Tinfo := Get_Info (Get_Element_Subtype (Def)); - if Is_Complex_Type (El_Tinfo) then - -- This is a complex type. - Info.C := new Complex_Type_Arr_Info; - -- No size variable for unconstrained array type. - for Mode in Object_Kind_Type loop - Info.C (Mode).Size_Var := Null_Var; - Info.C (Mode).Builder_Need_Func := - El_Tinfo.C (Mode).Builder_Need_Func; - end loop; - end if; - Info.Type_Incomplete := False; - end Translate_Array_Type_Definition; - - -- Get the length of DEF, ie the number of elements. - -- If the length is not statically defined, returns -1. - function Get_Array_Subtype_Length (Def : Iir_Array_Subtype_Definition) - return Iir_Int64 - is - Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); - Index : Iir; - Len : Iir_Int64; - begin - -- Check if the bounds of the array are locally static. - Len := 1; - for I in Natural loop - Index := Get_Index_Type (Indexes_List, I); - exit when Index = Null_Iir; - - if Get_Type_Staticness (Index) /= Locally then - return -1; - end if; - Len := Len * Eval_Discrete_Type_Length (Index); - end loop; - return Len; - end Get_Array_Subtype_Length; - - procedure Translate_Array_Subtype_Definition - (Def : Iir_Array_Subtype_Definition) - is - Info : constant Type_Info_Acc := Get_Info (Def); - Base_Type : constant Iir := Get_Base_Type (Def); - Binfo : constant Type_Info_Acc := Get_Info (Base_Type); - - Len : Iir_Int64; - - Id : O_Ident; - begin - -- Note: info of indexes subtype are not created! - - Len := Get_Array_Subtype_Length (Def); - Info.Type_Mode := Type_Mode_Array; - Info.Type_Locally_Constrained := (Len >= 0); - if Is_Complex_Type (Binfo) - or else not Info.Type_Locally_Constrained - then - -- This is a complex type as the size is not known at compile - -- time. - Info.Ortho_Type := Binfo.T.Base_Ptr_Type; - Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; - - Create_Size_Var (Def); - - for Mode in Object_Kind_Type loop - Info.C (Mode).Builder_Need_Func := - Is_Complex_Type (Binfo) - and then Binfo.C (Mode).Builder_Need_Func; - end loop; - else - -- Length is known. Create a constrained array. - Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; - for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - case I is - when Mode_Value => - Id := Create_Identifier; - when Mode_Signal => - Id := Create_Identifier ("SIG"); - end case; - Info.Ortho_Type (I) := New_Constrained_Array_Type - (Binfo.T.Base_Type (I), - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); - New_Type_Decl (Id, Info.Ortho_Type (I)); - end loop; - end if; - end Translate_Array_Subtype_Definition; - - procedure Translate_Array_Subtype_Element_Subtype - (Def : Iir_Array_Subtype_Definition) - is - El_Type : constant Iir := Get_Element_Subtype (Def); - Type_Mark : constant Iir := Get_Denoted_Type_Mark (Def); - Tm_El_Type : Iir; - begin - if Type_Mark = Null_Iir then - -- Array subtype for constained array definition. Same element - -- subtype as the base type. - return; - end if; - - Tm_El_Type := Get_Element_Subtype (Type_Mark); - if El_Type = Tm_El_Type then - -- Same element subtype as the type mark. - return; - end if; - - case Get_Kind (El_Type) is - when Iir_Kinds_Scalar_Subtype_Definition => - declare - El_Info : Ortho_Info_Acc; - begin - El_Info := Add_Info (El_Type, Kind_Type); - Create_Subtype_Info_From_Type - (El_Type, El_Info, Get_Info (Tm_El_Type)); - end; - when others => - Error_Kind ("translate_array_subtype_element_subtype", El_Type); - end case; - end Translate_Array_Subtype_Element_Subtype; - - function Create_Static_Array_Subtype_Bounds - (Def : Iir_Array_Subtype_Definition) - return O_Cnode - is - Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); - Baseinfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def)); - Index : Iir; - List : O_Record_Aggr_List; - Res : O_Cnode; - begin - Start_Record_Aggr (List, Baseinfo.T.Bounds_Type); - for I in Natural loop - Index := Get_Index_Type (Indexes_List, I); - exit when Index = Null_Iir; - New_Record_Aggr_El - (List, Create_Static_Type_Definition_Type_Range (Index)); - end loop; - Finish_Record_Aggr (List, Res); - return Res; - end Create_Static_Array_Subtype_Bounds; - - procedure Create_Array_Subtype_Bounds - (Def : Iir_Array_Subtype_Definition; Target : O_Lnode) - is - Base_Type : constant Iir := Get_Base_Type (Def); - Baseinfo : constant Type_Info_Acc := Get_Info (Base_Type); - Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); - Indexes_Def_List : constant Iir_List := - Get_Index_Subtype_Definition_List (Base_Type); - Index : Iir; - Targ : Mnode; - begin - Targ := Lv2M (Target, True, - Baseinfo.T.Bounds_Type, - Baseinfo.T.Bounds_Ptr_Type, - null, Mode_Value); - Open_Temp; - if Get_Nbr_Elements (Indexes_List) > 1 then - Targ := Stabilize (Targ); - end if; - for I in Natural loop - Index := Get_Index_Type (Indexes_List, I); - exit when Index = Null_Iir; - declare - Index_Type : constant Iir := Get_Base_Type (Index); - Index_Info : constant Type_Info_Acc := Get_Info (Index_Type); - Base_Index_Info : constant Index_Info_Acc := - Get_Info (Get_Nth_Element (Indexes_Def_List, I)); - D : O_Dnode; - begin - Open_Temp; - D := Create_Temp_Ptr - (Index_Info.T.Range_Ptr_Type, - New_Selected_Element (M2Lv (Targ), - Base_Index_Info.Index_Field)); - Chap7.Translate_Discrete_Range_Ptr (D, Index); - Close_Temp; - end; - end loop; - Close_Temp; - end Create_Array_Subtype_Bounds; - - -- Get staticness of the array bounds. - function Get_Array_Bounds_Staticness (Def : Iir) return Iir_Staticness - is - List : constant Iir_List := Get_Index_Subtype_List (Def); - Idx_Type : Iir; - begin - for I in Natural loop - Idx_Type := Get_Index_Type (List, I); - exit when Idx_Type = Null_Iir; - if Get_Type_Staticness (Idx_Type) /= Locally then - return Globally; - end if; - end loop; - return Locally; - end Get_Array_Bounds_Staticness; - - -- Create a variable containing the bounds for array subtype DEF. - procedure Create_Array_Subtype_Bounds_Var - (Def : Iir; Elab_Now : Boolean) - is - Info : constant Type_Info_Acc := Get_Info (Def); - Base_Info : Type_Info_Acc; - Val : O_Cnode; - begin - if Info.T.Array_Bounds /= Null_Var then - return; - end if; - Base_Info := Get_Info (Get_Base_Type (Def)); - case Get_Array_Bounds_Staticness (Def) is - when None - | Globally => - Info.T.Static_Bounds := False; - Info.T.Array_Bounds := Create_Var - (Create_Var_Identifier ("STB"), Base_Info.T.Bounds_Type); - if Elab_Now then - Create_Array_Subtype_Bounds - (Def, Get_Var (Info.T.Array_Bounds)); - end if; - when Locally => - Info.T.Static_Bounds := True; - if Global_Storage = O_Storage_External then - -- Do not create the value of the type desc, since it - -- is never dereferenced in a static type desc. - Val := O_Cnode_Null; - else - Val := Create_Static_Array_Subtype_Bounds (Def); - end if; - Info.T.Array_Bounds := Create_Global_Const - (Create_Identifier ("STB"), - Base_Info.T.Bounds_Type, Global_Storage, Val); - - when Unknown => - raise Internal_Error; - end case; - end Create_Array_Subtype_Bounds_Var; - - procedure Create_Array_Type_Builder - (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type) - is - Info : constant Type_Info_Acc := Get_Info (Def); - Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; - Bound : constant O_Dnode := Info.C (Kind).Builder_Bound_Param; - Var_Off : O_Dnode; - Var_Mem : O_Dnode; - Var_Length : O_Dnode; - El_Type : Iir; - El_Info : Type_Info_Acc; - Label : O_Snode; - begin - Start_Subprogram_Body (Info.C (Kind).Builder_Func); - Subprgs.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); - - -- Compute length of the array. - New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, - Ghdl_Index_Type); - New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local, - Info.T.Base_Ptr_Type (Kind)); - New_Var_Decl (Var_Off, Get_Identifier ("off"), O_Storage_Local, - Ghdl_Index_Type); - - El_Type := Get_Element_Subtype (Def); - El_Info := Get_Info (El_Type); - - New_Assign_Stmt - (New_Obj (Var_Length), - New_Dyadic_Op (ON_Mul_Ov, - New_Value (Get_Var (El_Info.C (Kind).Size_Var)), - Get_Bounds_Length (Dp2M (Bound, Info, - Mode_Value, - Info.T.Bounds_Type, - Info.T.Bounds_Ptr_Type), - Def))); - - -- Find the innermost non-array element. - while El_Info.Type_Mode = Type_Mode_Array loop - El_Type := Get_Element_Subtype (El_Type); - El_Info := Get_Info (El_Type); - end loop; - - -- Set each index of the array. - Init_Var (Var_Off); - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Off), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - - New_Assign_Stmt - (New_Obj (Var_Mem), - New_Unchecked_Address - (New_Slice (New_Access_Element - (New_Convert_Ov (New_Obj_Value (Base), - Char_Ptr_Type)), - Chararray_Type, - New_Obj_Value (Var_Off)), - Info.T.Base_Ptr_Type (Kind))); - - New_Assign_Stmt - (New_Obj (Var_Off), - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_Off), - Gen_Call_Type_Builder (Var_Mem, El_Type, Kind))); - Finish_Loop_Stmt (Label); - - New_Return_Stmt (New_Obj_Value (Var_Off)); - - Subprgs.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); - Finish_Subprogram_Body; - end Create_Array_Type_Builder; - - -------------- - -- record -- - -------------- - - -- Get the alignment mask for *ortho* type ATYPE. - function Get_Type_Alignmask (Atype : O_Tnode) return O_Enode is - begin - return New_Dyadic_Op - (ON_Sub_Ov, - New_Lit (New_Alignof (Atype, Ghdl_Index_Type)), - New_Lit (Ghdl_Index_1)); - end Get_Type_Alignmask; - - -- Get the alignment mask for type INFO (Mode_Value). - function Get_Type_Alignmask (Info : Type_Info_Acc) return O_Enode is - begin - if Is_Complex_Type (Info) then - if Info.Type_Mode /= Type_Mode_Record then - raise Internal_Error; - end if; - return New_Value (Get_Var (Info.C (Mode_Value).Align_Var)); - else - return Get_Type_Alignmask (Info.Ortho_Type (Mode_Value)); - end if; - end Get_Type_Alignmask; - - -- Align VALUE (of unsigned type) for type ATYPE. - -- The formulae is: (V + (A - 1)) and not (A - 1), where A is the - -- alignment for ATYPE in bytes. - function Realign (Value : O_Enode; Atype : Iir) return O_Enode - is - Tinfo : constant Type_Info_Acc := Get_Info (Atype); - begin - return New_Dyadic_Op - (ON_And, - New_Dyadic_Op (ON_Add_Ov, Value, Get_Type_Alignmask (Tinfo)), - New_Monadic_Op (ON_Not, Get_Type_Alignmask (Tinfo))); - end Realign; - - function Realign (Value : O_Enode; Mask : O_Dnode) return O_Enode is - begin - return New_Dyadic_Op - (ON_And, - New_Dyadic_Op (ON_Add_Ov, Value, New_Obj_Value (Mask)), - New_Monadic_Op (ON_Not, New_Obj_Value (Mask))); - end Realign; - - -- Find the innermost non-array element. - function Get_Innermost_Non_Array_Element (Atype : Iir) return Iir - is - Res : Iir := Atype; - begin - while Get_Kind (Res) in Iir_Kinds_Array_Type_Definition loop - Res := Get_Element_Subtype (Res); - end loop; - return Res; - end Get_Innermost_Non_Array_Element; - - procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) - is - El_List : O_Element_List; - List : Iir_List; - El : Iir_Element_Declaration; - Info : Type_Info_Acc; - Field_Info : Ortho_Info_Acc; - El_Type : Iir; - El_Tinfo : Type_Info_Acc; - El_Tnode : O_Tnode; - - -- True if a size variable will be created since the size of - -- the record is not known at compile-time. - Need_Size : Boolean; - - Mark : Id_Mark_Type; - begin - Info := Get_Info (Def); - Need_Size := False; - List := Get_Elements_Declaration_List (Def); - - -- First, translate the anonymous type of the elements. - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - El_Type := Get_Type (El); - if Get_Info (El_Type) = null then - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - Translate_Type_Definition (El_Type); - Pop_Identifier_Prefix (Mark); - end if; - if not Need_Size and then Is_Complex_Type (Get_Info (El_Type)) then - Need_Size := True; - end if; - Field_Info := Add_Info (El, Kind_Field); - end loop; - - -- Then create the record type. - Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - Start_Record_Type (El_List); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Field_Info := Get_Info (El); - El_Tinfo := Get_Info (Get_Type (El)); - if Is_Complex_Type (El_Tinfo) then - -- Always use an offset for a complex type. - El_Tnode := Ghdl_Index_Type; - else - El_Tnode := El_Tinfo.Ortho_Type (Kind); - end if; - - New_Record_Field (El_List, Field_Info.Field_Node (Kind), - Create_Identifier_Without_Prefix (El), - El_Tnode); - end loop; - Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); - end loop; - Info.Type_Mode := Type_Mode_Record; - Finish_Type_Definition (Info); - - if Need_Size then - Create_Size_Var (Def); - Info.C (Mode_Value).Align_Var := Create_Var - (Create_Var_Identifier ("ALIGNMSK"), Ghdl_Index_Type); - Info.C (Mode_Value).Builder_Need_Func := True; - Info.C (Mode_Signal).Builder_Need_Func := True; - end if; - end Translate_Record_Type; - - procedure Create_Record_Type_Builder - (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type) - is - Info : constant Type_Info_Acc := Get_Info (Def); - Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; - List : Iir_List; - El : Iir_Element_Declaration; - - Off_Var : O_Dnode; - Ptr_Var : O_Dnode; - Off_Val : O_Enode; - El_Type : Iir; - Inner_Type : Iir; - El_Tinfo : Type_Info_Acc; - begin - Start_Subprogram_Body (Info.C (Kind).Builder_Func); - Subprgs.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); - - New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local, - Ghdl_Index_Type); - - -- Reserve memory for the record, ie: - -- OFF = SIZEOF (record). - New_Assign_Stmt - (New_Obj (Off_Var), - New_Lit (New_Sizeof (Info.Ortho_Type (Kind), - Ghdl_Index_Type))); - - -- Set memory for each complex element. - List := Get_Elements_Declaration_List (Def); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - El_Type := Get_Type (El); - El_Tinfo := Get_Info (El_Type); - if Is_Complex_Type (El_Tinfo) then - -- Complex type. - - -- Align on the innermost array element (which should be - -- a record) for Mode_Value. No need to align for signals, - -- as all non-composite elements are accesses. - Inner_Type := Get_Innermost_Non_Array_Element (El_Type); - Off_Val := New_Obj_Value (Off_Var); - if Kind = Mode_Value then - Off_Val := Realign (Off_Val, Inner_Type); - end if; - New_Assign_Stmt (New_Obj (Off_Var), Off_Val); - - -- Set the offset. - New_Assign_Stmt - (New_Selected_Element (New_Acc_Value (New_Obj (Base)), - Get_Info (El).Field_Node (Kind)), - New_Obj_Value (Off_Var)); - - if El_Tinfo.C (Kind).Builder_Need_Func then - -- This type needs a builder, call it. - Start_Declare_Stmt; - New_Var_Decl - (Ptr_Var, Get_Identifier ("var_ptr"), - O_Storage_Local, El_Tinfo.Ortho_Ptr_Type (Kind)); - - New_Assign_Stmt - (New_Obj (Ptr_Var), - M2E (Chap6.Translate_Selected_Element - (Dp2M (Base, Info, Kind), El))); - - New_Assign_Stmt - (New_Obj (Off_Var), - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Off_Var), - Gen_Call_Type_Builder - (Ptr_Var, El_Type, Kind))); - - Finish_Declare_Stmt; - else - -- Allocate memory. - New_Assign_Stmt - (New_Obj (Off_Var), - New_Dyadic_Op - (ON_Add_Ov, - New_Obj_Value (Off_Var), - New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)))); - end if; - end if; - end loop; - New_Return_Stmt (New_Value (Get_Var (Info.C (Kind).Size_Var))); - Subprgs.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); - Finish_Subprogram_Body; - end Create_Record_Type_Builder; - - -------------- - -- Access -- - -------------- - procedure Translate_Access_Type (Def : Iir_Access_Type_Definition) - is - D_Type : constant Iir := Get_Designated_Type (Def); - D_Info : constant Ortho_Info_Acc := Get_Info (D_Type); - Def_Info : constant Type_Info_Acc := Get_Info (Def); - Dtype : O_Tnode; - Arr_Info : Type_Info_Acc; - begin - if not Is_Fully_Constrained_Type (D_Type) then - -- An access type to an unconstrained type definition is a fat - -- pointer. - Def_Info.Type_Mode := Type_Mode_Fat_Acc; - if D_Info.Kind = Kind_Incomplete_Type then - Translate_Incomplete_Array_Type (D_Type); - Arr_Info := D_Info.Incomplete_Array; - Def_Info.Ortho_Type := Arr_Info.Ortho_Type; - Def_Info.T := Arr_Info.T; - else - Def_Info.Ortho_Type := D_Info.Ortho_Type; - Def_Info.T := D_Info.T; - end if; - Def_Info.Ortho_Ptr_Type (Mode_Value) := - New_Access_Type (Def_Info.Ortho_Type (Mode_Value)); - New_Type_Decl (Create_Identifier ("PTR"), - Def_Info.Ortho_Ptr_Type (Mode_Value)); - else - -- Otherwise, it is a thin pointer. - Def_Info.Type_Mode := Type_Mode_Acc; - -- No access types for signals. - Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - - if D_Info.Kind = Kind_Incomplete_Type then - Dtype := O_Tnode_Null; - elsif Is_Complex_Type (D_Info) then - -- FIXME: clean here when the ortho_type of a array - -- complex_type is correctly set (not a pointer). - Def_Info.Ortho_Type (Mode_Value) := - D_Info.Ortho_Ptr_Type (Mode_Value); - Finish_Type_Definition (Def_Info, True); - return; - elsif D_Info.Type_Mode in Type_Mode_Arrays then - -- The designated type cannot be a sub array inside ortho. - -- FIXME: lift this restriction. - Dtype := D_Info.T.Base_Type (Mode_Value); - else - Dtype := D_Info.Ortho_Type (Mode_Value); - end if; - Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype); - Finish_Type_Definition (Def_Info); - end if; - end Translate_Access_Type; - - ------------------------ - -- Incomplete types -- - ------------------------ - procedure Translate_Incomplete_Type (Def : Iir) - is --- Ftype : Iir; --- Info : Type_Info_Acc; - Info : Incomplete_Type_Info_Acc; - Ctype : Iir; - begin - if Get_Nbr_Elements (Get_Incomplete_Type_List (Def)) = 0 then - -- FIXME: - -- This is a work-around for dummy incomplete type (ie incomplete - -- types not used before the full type declaration). - return; - end if; - Ctype := Get_Type (Get_Type_Declarator (Def)); - Info := Add_Info (Ctype, Kind_Incomplete_Type); - Info.Incomplete_Type := Def; - Info.Incomplete_Array := null; - end Translate_Incomplete_Type; - - -- CTYPE is the type which has been completed. - procedure Translate_Complete_Type - (Incomplete_Info : in out Incomplete_Type_Info_Acc; Ctype : Iir) - is - List : Iir_List; - Atype : Iir; - Def_Info : Type_Info_Acc; - C_Info : Type_Info_Acc; - Dtype : O_Tnode; - begin - C_Info := Get_Info (Ctype); - List := Get_Incomplete_Type_List (Incomplete_Info.Incomplete_Type); - for I in Natural loop - Atype := Get_Nth_Element (List, I); - exit when Atype = Null_Iir; - if Get_Kind (Atype) /= Iir_Kind_Access_Type_Definition then - raise Internal_Error; - end if; - Def_Info := Get_Info (Atype); - case C_Info.Type_Mode is - when Type_Mode_Arrays => - Dtype := C_Info.T.Base_Type (Mode_Value); - when others => - Dtype := C_Info.Ortho_Type (Mode_Value); - end case; - Finish_Access_Type (Def_Info.Ortho_Type (Mode_Value), Dtype); - end loop; - Unchecked_Deallocation (Incomplete_Info); - end Translate_Complete_Type; - - ----------------- - -- protected -- - ----------------- - - procedure Translate_Protected_Type (Def : Iir_Protected_Type_Declaration) - is - Info : constant Type_Info_Acc := Get_Info (Def); - Mark : Id_Mark_Type; - begin - New_Uncomplete_Record_Type (Info.Ortho_Type (Mode_Value)); - New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); - - Info.Ortho_Ptr_Type (Mode_Value) := - New_Access_Type (Info.Ortho_Type (Mode_Value)); - New_Type_Decl (Create_Identifier ("PTR"), - Info.Ortho_Ptr_Type (Mode_Value)); - - Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; - - Info.Type_Mode := Type_Mode_Protected; - - -- A protected type is a complex type, as its size is not known - -- at definition point (will be known at body declaration). - Info.C := new Complex_Type_Arr_Info; - Info.C (Mode_Value).Builder_Need_Func := False; - - -- This is just use to set overload number on subprograms, and to - -- translate interfaces. - Push_Identifier_Prefix - (Mark, Get_Identifier (Get_Type_Declarator (Def))); - Chap4.Translate_Declaration_Chain (Def); - Pop_Identifier_Prefix (Mark); - end Translate_Protected_Type; - - procedure Translate_Protected_Type_Subprograms - (Def : Iir_Protected_Type_Declaration) - is - Info : constant Type_Info_Acc := Get_Info (Def); - El : Iir; - Inter_List : O_Inter_List; - Mark : Id_Mark_Type; - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - begin - Push_Identifier_Prefix - (Mark, Get_Identifier (Get_Type_Declarator (Def))); - - -- Init. - Start_Function_Decl - (Inter_List, Create_Identifier ("INIT"), Global_Storage, - Info.Ortho_Ptr_Type (Mode_Value)); - Subprgs.Add_Subprg_Instance_Interfaces - (Inter_List, Info.T.Prot_Init_Instance); - Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Subprg); - - -- Use the object as instance. - Subprgs.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, - Info.Ortho_Ptr_Type (Mode_Value), - Wki_Obj, - Prev_Subprg_Instance); - - -- Final. - Start_Procedure_Decl - (Inter_List, Create_Identifier ("FINI"), Global_Storage); - Subprgs.Add_Subprg_Instance_Interfaces - (Inter_List, Info.T.Prot_Final_Instance); - Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Final_Subprg); - - -- Methods. - El := Get_Declaration_Chain (Def); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - -- Translate only if used. - if Get_Info (El) /= null then - Chap2.Translate_Subprogram_Declaration (El); - end if; - when others => - Error_Kind ("translate_protected_type_subprograms", El); - end case; - El := Get_Chain (El); - end loop; - - Subprgs.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); - - Pop_Identifier_Prefix (Mark); - end Translate_Protected_Type_Subprograms; - - procedure Translate_Protected_Type_Body (Bod : Iir) - is - Decl : constant Iir_Protected_Type_Declaration := - Get_Protected_Type_Declaration (Bod); - Info : constant Type_Info_Acc := Get_Info (Decl); - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); - - -- Create the object type - Push_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); - -- First, the previous instance. - Subprgs.Add_Subprg_Instance_Field (Info.T.Prot_Subprg_Instance_Field); - -- Then the object lock - Info.T.Prot_Lock_Field := Add_Instance_Factory_Field - (Get_Identifier ("LOCK"), Ghdl_Ptr_Type); - - -- Translate declarations. - Chap4.Translate_Declaration_Chain (Bod); - - Pop_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); - Info.Ortho_Type (Mode_Value) := Get_Scope_Type (Info.T.Prot_Scope); - - Pop_Identifier_Prefix (Mark); - end Translate_Protected_Type_Body; - - procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode) - is - Info : constant Type_Info_Acc := Get_Info (Type_Def); - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Proc); - New_Association - (Assoc, - New_Unchecked_Address - (New_Selected_Element - (Get_Instance_Ref (Info.T.Prot_Scope), - Info.T.Prot_Lock_Field), - Ghdl_Ptr_Type)); - New_Procedure_Call (Assoc); - end Call_Ghdl_Protected_Procedure; - - procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir) - is - Mark : Id_Mark_Type; - Decl : constant Iir := Get_Protected_Type_Declaration (Bod); - Info : constant Type_Info_Acc := Get_Info (Decl); - Final : Boolean; - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); - - -- Subprograms of BOD. - Subprgs.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, - Info.Ortho_Ptr_Type (Mode_Value), - Wki_Obj, - Prev_Subprg_Instance); - Subprgs.Start_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); - - Chap4.Translate_Declaration_Chain_Subprograms (Bod); - - Subprgs.Finish_Prev_Subprg_Instance_Use_Via_Field - (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); - Subprgs.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); - - Pop_Identifier_Prefix (Mark); - - if Global_Storage = O_Storage_External then - return; - end if; - - -- Init subprogram - declare - Var_Obj : O_Dnode; - begin - Start_Subprogram_Body (Info.T.Prot_Init_Subprg); - Subprgs.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance); - New_Var_Decl (Var_Obj, Wki_Obj, O_Storage_Local, - Info.Ortho_Ptr_Type (Mode_Value)); - - -- Allocate the object - New_Assign_Stmt - (New_Obj (Var_Obj), - Gen_Alloc (Alloc_System, - New_Lit (New_Sizeof (Info.Ortho_Type (Mode_Value), - Ghdl_Index_Type)), - Info.Ortho_Ptr_Type (Mode_Value))); - - Subprgs.Set_Subprg_Instance_Field - (Var_Obj, Info.T.Prot_Subprg_Instance_Field, - Info.T.Prot_Init_Instance); - - Set_Scope_Via_Param_Ptr (Info.T.Prot_Scope, Var_Obj); - - -- Create lock. - Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init); - - -- Elaborate fields. - Open_Temp; - Chap4.Elab_Declaration_Chain (Bod, Final); - Close_Temp; - - Clear_Scope (Info.T.Prot_Scope); - - New_Return_Stmt (New_Obj_Value (Var_Obj)); - Subprgs.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); - - Finish_Subprogram_Body; - end; - - -- Fini subprogram - begin - Start_Subprogram_Body (Info.T.Prot_Final_Subprg); - Subprgs.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance); - - -- Deallocate fields. - if Final or True then - Chap4.Final_Declaration_Chain (Bod, True); - end if; - - -- Destroy lock. - Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini); - - Subprgs.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance); - Finish_Subprogram_Body; - end; - end Translate_Protected_Type_Body_Subprograms; - - --------------- - -- Scalars -- - --------------- - - -- Create a type_range structure. - procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode) - is - T_Info : Type_Info_Acc; - Base_Type : Iir; - Expr : Iir; - V : O_Dnode; - begin - Base_Type := Get_Base_Type (Def); - T_Info := Get_Info (Base_Type); - Expr := Get_Range_Constraint (Def); - Open_Temp; - V := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, Target); - Chap7.Translate_Range_Ptr (V, Expr, Def); - Close_Temp; - end Create_Scalar_Type_Range; - - function Create_Static_Scalar_Type_Range (Def : Iir) return O_Cnode is - begin - return Chap7.Translate_Static_Range (Get_Range_Constraint (Def), - Get_Base_Type (Def)); - end Create_Static_Scalar_Type_Range; - - procedure Create_Scalar_Type_Range_Type - (Def : Iir; With_Length : Boolean) - is - Constr : O_Element_List; - Info : Ortho_Info_Acc; - begin - Info := Get_Info (Def); - Start_Record_Type (Constr); - New_Record_Field - (Constr, Info.T.Range_Left, Wki_Left, - Info.Ortho_Type (Mode_Value)); - New_Record_Field - (Constr, Info.T.Range_Right, Wki_Right, - Info.Ortho_Type (Mode_Value)); - New_Record_Field - (Constr, Info.T.Range_Dir, Wki_Dir, Ghdl_Dir_Type_Node); - if With_Length then - New_Record_Field - (Constr, Info.T.Range_Length, Wki_Length, Ghdl_Index_Type); - else - Info.T.Range_Length := O_Fnode_Null; - end if; - Finish_Record_Type (Constr, Info.T.Range_Type); - New_Type_Decl (Create_Identifier ("TRT"), Info.T.Range_Type); - Info.T.Range_Ptr_Type := New_Access_Type (Info.T.Range_Type); - New_Type_Decl (Create_Identifier ("TRPTR"), - Info.T.Range_Ptr_Type); - end Create_Scalar_Type_Range_Type; - - function Create_Static_Type_Definition_Type_Range (Def : Iir) - return O_Cnode - is - begin - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kinds_Scalar_Subtype_Definition => - return Create_Static_Scalar_Type_Range (Def); - - when Iir_Kind_Array_Subtype_Definition => - return Create_Static_Array_Subtype_Bounds (Def); - - when Iir_Kind_Array_Type_Definition => - return O_Cnode_Null; - - when others => - Error_Kind ("create_static_type_definition_type_range", Def); - end case; - end Create_Static_Type_Definition_Type_Range; - - procedure Create_Type_Definition_Type_Range (Def : Iir) - is - Target : O_Lnode; - Info : Type_Info_Acc; - begin - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kinds_Scalar_Subtype_Definition => - Target := Get_Var (Get_Info (Def).T.Range_Var); - Create_Scalar_Type_Range (Def, Target); - - when Iir_Kind_Array_Subtype_Definition => - if Get_Constraint_State (Def) = Fully_Constrained then - Info := Get_Info (Def); - if not Info.T.Static_Bounds then - Target := Get_Var (Info.T.Array_Bounds); - Create_Array_Subtype_Bounds (Def, Target); - end if; - end if; - - when Iir_Kind_Array_Type_Definition => - declare - Index_List : constant Iir_List := - Get_Index_Subtype_List (Def); - Index : Iir; - begin - for I in Natural loop - Index := Get_Index_Type (Index_List, I); - exit when Index = Null_Iir; - if Is_Anonymous_Type_Definition (Index) then - Create_Type_Definition_Type_Range (Index); - end if; - end loop; - end; - Translate_Dynamic_Unidimensional_Array_Length_One (Def); - return; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition - | Iir_Kind_File_Type_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Protected_Type_Declaration => - return; - - when others => - Error_Kind ("create_type_definition_type_range", Def); - end case; - end Create_Type_Definition_Type_Range; - - -- Return TRUE iff LIT is equal to the high (IS_HI=TRUE) or low - -- (IS_HI=false) limit of the base type of DEF. MODE is the mode of - -- DEF. - function Is_Equal_Limit (Lit : Iir; - Is_Hi : Boolean; - Def : Iir; - Mode : Type_Mode_Type) return Boolean - is - begin - case Mode is - when Type_Mode_B1 => - declare - V : Iir_Int32; - begin - V := Iir_Int32 (Eval_Pos (Lit)); - if Is_Hi then - return V = 1; - else - return V = 0; - end if; - end; - when Type_Mode_E8 => - declare - V : Iir_Int32; - Base_Type : Iir; - begin - V := Iir_Int32 (Eval_Pos (Lit)); - if Is_Hi then - Base_Type := Get_Base_Type (Def); - return V = Iir_Int32 - (Get_Nbr_Elements - (Get_Enumeration_Literal_List (Base_Type))) - 1; - else - return V = 0; - end if; - end; - when Type_Mode_I32 => - declare - V : Iir_Int32; - begin - V := Iir_Int32 (Get_Value (Lit)); - if Is_Hi then - return V = Iir_Int32'Last; - else - return V = Iir_Int32'First; - end if; - end; - when Type_Mode_P32 => - declare - V : Iir_Int32; - begin - V := Iir_Int32 (Get_Physical_Value (Lit)); - if Is_Hi then - return V = Iir_Int32'Last; - else - return V = Iir_Int32'First; - end if; - end; - when Type_Mode_I64 => - declare - V : Iir_Int64; - begin - V := Get_Value (Lit); - if Is_Hi then - return V = Iir_Int64'Last; - else - return V = Iir_Int64'First; - end if; - end; - when Type_Mode_P64 => - declare - V : Iir_Int64; - begin - V := Get_Physical_Value (Lit); - if Is_Hi then - return V = Iir_Int64'Last; - else - return V = Iir_Int64'First; - end if; - end; - when Type_Mode_F64 => - declare - V : Iir_Fp64; - begin - V := Get_Fp_Value (Lit); - if Is_Hi then - return V = Iir_Fp64'Last; - else - return V = Iir_Fp64'First; - end if; - end; - when others => - Error_Kind ("is_equal_limit " & Type_Mode_Type'Image (Mode), - Lit); - end case; - end Is_Equal_Limit; - - -- For scalar subtypes: creates info from the base type. - procedure Create_Subtype_Info_From_Type (Def : Iir; - Subtype_Info : Type_Info_Acc; - Base_Info : Type_Info_Acc) - is - Rng : Iir; - Lo, Hi : Iir; - begin - Subtype_Info.Ortho_Type := Base_Info.Ortho_Type; - Subtype_Info.Ortho_Ptr_Type := Base_Info.Ortho_Ptr_Type; - Subtype_Info.Type_Mode := Base_Info.Type_Mode; - Subtype_Info.T := Base_Info.T; - - Rng := Get_Range_Constraint (Def); - if Get_Expr_Staticness (Rng) /= Locally then - -- Bounds are not known. - -- Do the checks. - Subtype_Info.T.Nocheck_Hi := False; - Subtype_Info.T.Nocheck_Low := False; - else - -- Bounds are locally static. - Get_Low_High_Limit (Rng, Lo, Hi); - Subtype_Info.T.Nocheck_Hi := - Is_Equal_Limit (Hi, True, Def, Base_Info.Type_Mode); - Subtype_Info.T.Nocheck_Low := - Is_Equal_Limit (Lo, False, Def, Base_Info.Type_Mode); - end if; - end Create_Subtype_Info_From_Type; - - procedure Create_Record_Size_Var (Def : Iir; Kind : Object_Kind_Type) - is - Info : constant Type_Info_Acc := Get_Info (Def); - List : constant Iir_List := - Get_Elements_Declaration_List (Get_Base_Type (Def)); - El : Iir_Element_Declaration; - El_Type : Iir; - El_Tinfo : Type_Info_Acc; - Inner_Type : Iir; - Inner_Tinfo : Type_Info_Acc; - Res : O_Enode; - Align_Var : O_Dnode; - If_Blk : O_If_Block; - begin - Open_Temp; - - -- Start with the size of the 'base' record, that - -- contains all non-complex types and an offset for - -- each complex types. - Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type)); - - -- Start with alignment of the record. - -- ALIGN = ALIGNOF (record) - if Kind = Mode_Value then - Align_Var := Create_Temp (Ghdl_Index_Type); - New_Assign_Stmt - (New_Obj (Align_Var), - Get_Type_Alignmask (Info.Ortho_Type (Kind))); - end if; - - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - El_Type := Get_Type (El); - El_Tinfo := Get_Info (El_Type); - if Is_Complex_Type (El_Tinfo) then - Inner_Type := Get_Innermost_Non_Array_Element (El_Type); - - -- Align (only for Mode_Value) the size, - -- and add the size of the element. - if Kind = Mode_Value then - Inner_Tinfo := Get_Info (Inner_Type); - -- If alignmask (Inner_Type) > alignmask then - -- alignmask = alignmask (Inner_type); - -- end if; - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Gt, - Get_Type_Alignmask (Inner_Tinfo), - New_Obj_Value (Align_Var), - Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Obj (Align_Var), Get_Type_Alignmask (Inner_Tinfo)); - Finish_If_Stmt (If_Blk); - Res := Realign (Res, Inner_Type); - end if; - Res := New_Dyadic_Op - (ON_Add_Ov, - New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)), - Res); - end if; - end loop; - if Kind = Mode_Value then - Res := Realign (Res, Align_Var); - end if; - New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); - Close_Temp; - end Create_Record_Size_Var; - - procedure Create_Array_Size_Var (Def : Iir; Kind : Object_Kind_Type) - is - Info : constant Type_Info_Acc := Get_Info (Def); - El_Type : constant Iir := Get_Element_Subtype (Def); - Res : O_Enode; - begin - Res := New_Dyadic_Op - (ON_Mul_Ov, - Get_Array_Type_Length (Def), - Chap3.Get_Object_Size (T2M (El_Type, Kind), El_Type)); - New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); - end Create_Array_Size_Var; - - procedure Create_Type_Definition_Size_Var (Def : Iir) - is - Info : constant Type_Info_Acc := Get_Info (Def); - begin - if not Is_Complex_Type (Info) then - return; - end if; - - for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - if Info.C (Kind).Size_Var /= Null_Var then - case Info.Type_Mode is - when Type_Mode_Non_Composite - | Type_Mode_Fat_Array - | Type_Mode_Unknown - | Type_Mode_Protected => - raise Internal_Error; - when Type_Mode_Record => - Create_Record_Size_Var (Def, Kind); - when Type_Mode_Array => - Create_Array_Size_Var (Def, Kind); - end case; - end if; - end loop; - end Create_Type_Definition_Size_Var; - - procedure Create_Type_Range_Var (Def : Iir) - is - Info : constant Type_Info_Acc := Get_Info (Def); - Base_Info : Type_Info_Acc; - Val : O_Cnode; - Suffix : String (1 .. 3) := "xTR"; - begin - case Get_Kind (Def) is - when Iir_Kinds_Subtype_Definition => - Suffix (1) := 'S'; -- "STR"; - when Iir_Kind_Enumeration_Type_Definition => - Suffix (1) := 'B'; -- "BTR"; - when others => - raise Internal_Error; - end case; - Base_Info := Get_Info (Get_Base_Type (Def)); - case Get_Type_Staticness (Def) is - when None - | Globally => - Info.T.Range_Var := Create_Var - (Create_Var_Identifier (Suffix), Base_Info.T.Range_Type); - when Locally => - if Global_Storage = O_Storage_External then - -- Do not create the value of the type desc, since it - -- is never dereferenced in a static type desc. - Val := O_Cnode_Null; - else - Val := Create_Static_Type_Definition_Type_Range (Def); - end if; - Info.T.Range_Var := Create_Global_Const - (Create_Identifier (Suffix), - Base_Info.T.Range_Type, Global_Storage, Val); - when Unknown => - raise Internal_Error; - end case; - end Create_Type_Range_Var; - - - -- Call HANDLE_A_SUBTYPE for all type/subtypes declared with DEF - -- (of course, this is a noop if DEF is not a composite type). - generic - with procedure Handle_A_Subtype (Atype : Iir); - procedure Handle_Anonymous_Subtypes (Def : Iir); - - procedure Handle_Anonymous_Subtypes (Def : Iir) is - begin - case Get_Kind (Def) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - declare - Asub : Iir; - begin - Asub := Get_Element_Subtype (Def); - if Is_Anonymous_Type_Definition (Asub) then - Handle_A_Subtype (Asub); - end if; - end; - when Iir_Kind_Record_Type_Definition => - declare - El : Iir; - Asub : Iir; - List : Iir_List; - begin - List := Get_Elements_Declaration_List (Def); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Asub := Get_Type (El); - if Is_Anonymous_Type_Definition (Asub) then - Handle_A_Subtype (Asub); - end if; - end loop; - end; - when others => - null; - end case; - end Handle_Anonymous_Subtypes; - - -- Note: boolean types are translated by translate_bool_type_definition! - procedure Translate_Type_Definition - (Def : Iir; With_Vars : Boolean := True) - is - Info : Ortho_Info_Acc; - Base_Info : Type_Info_Acc; - Base_Type : Iir; - Complete_Info : Incomplete_Type_Info_Acc; - begin - -- Handle the special case of incomplete type. - if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then - Translate_Incomplete_Type (Def); - return; - end if; - - -- If the definition is already translated, return now. - Info := Get_Info (Def); - if Info /= null then - if Info.Kind = Kind_Type then - -- The subtype was already translated. - return; - end if; - if Info.Kind = Kind_Incomplete_Type then - -- Type is being completed. - Complete_Info := Info; - Clear_Info (Def); - if Complete_Info.Incomplete_Array /= null then - Info := Complete_Info.Incomplete_Array; - Set_Info (Def, Info); - Unchecked_Deallocation (Complete_Info); - else - Info := Add_Info (Def, Kind_Type); - end if; - else - raise Internal_Error; - end if; - else - Complete_Info := null; - Info := Add_Info (Def, Kind_Type); - end if; - - Base_Type := Get_Base_Type (Def); - Base_Info := Get_Info (Base_Type); - - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition => - Translate_Enumeration_Type (Def); - Create_Scalar_Type_Range_Type (Def, True); - Create_Type_Range_Var (Def); - --Create_Type_Desc_Var (Def); - - when Iir_Kind_Integer_Type_Definition => - Translate_Integer_Type (Def); - Create_Scalar_Type_Range_Type (Def, True); - - when Iir_Kind_Physical_Type_Definition => - Translate_Physical_Type (Def); - Create_Scalar_Type_Range_Type (Def, False); - if With_Vars and Get_Type_Staticness (Def) /= Locally then - Translate_Physical_Units (Def); - else - Info.T.Range_Var := Null_Var; - end if; - - when Iir_Kind_Floating_Type_Definition => - Translate_Floating_Type (Def); - Create_Scalar_Type_Range_Type (Def, False); - - when Iir_Kinds_Scalar_Subtype_Definition => - Create_Subtype_Info_From_Type (Def, Info, Base_Info); - if With_Vars then - Create_Type_Range_Var (Def); - else - Info.T.Range_Var := Null_Var; - end if; - - when Iir_Kind_Array_Type_Definition => - declare - El_Type : Iir; - Mark : Id_Mark_Type; - begin - El_Type := Get_Element_Subtype (Def); - if Get_Info (El_Type) = null then - Push_Identifier_Prefix (Mark, "ET"); - Translate_Type_Definition (El_Type); - Pop_Identifier_Prefix (Mark); - end if; - end; - Translate_Array_Type_Definition (Def); - - when Iir_Kind_Array_Subtype_Definition => - if Get_Index_Constraint_Flag (Def) then - if Base_Info = null or else Base_Info.Type_Incomplete then - declare - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, "BT"); - Translate_Type_Definition (Base_Type); - Pop_Identifier_Prefix (Mark); - Base_Info := Get_Info (Base_Type); - end; - end if; - Translate_Array_Subtype_Definition (Def); - Info.T := Base_Info.T; - --Info.Type_Range_Type := Base_Info.Type_Range_Type; - if With_Vars then - Create_Array_Subtype_Bounds_Var (Def, False); - end if; - else - -- An unconstrained array subtype. Use same infos as base - -- type. - Free_Info (Def); - Set_Info (Def, Base_Info); - end if; - Translate_Array_Subtype_Element_Subtype (Def); - - when Iir_Kind_Record_Type_Definition => - Translate_Record_Type (Def); - Info.T := Ortho_Info_Type_Record_Init; - - when Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Access_Subtype_Definition => - Free_Info (Def); - Set_Info (Def, Base_Info); - - when Iir_Kind_Access_Type_Definition => - declare - Dtype : constant Iir := Get_Designated_Type (Def); - begin - -- Translate the subtype - if Is_Anonymous_Type_Definition (Dtype) then - Translate_Type_Definition (Dtype); - end if; - Translate_Access_Type (Def); - end; - - when Iir_Kind_File_Type_Definition => - Translate_File_Type (Def); - Info.T := Ortho_Info_Type_File_Init; - if With_Vars then - Create_File_Type_Var (Def); - end if; - - when Iir_Kind_Protected_Type_Declaration => - Translate_Protected_Type (Def); - Info.T := Ortho_Info_Type_Prot_Init; - - when others => - Error_Kind ("translate_type_definition", Def); - end case; - - if Complete_Info /= null then - Translate_Complete_Type (Complete_Info, Def); - end if; - end Translate_Type_Definition; - - procedure Translate_Bool_Type_Definition (Def : Iir) - is - Info : Type_Info_Acc; - begin - -- If the definition is already translated, return now. - Info := Get_Info (Def); - if Info /= null then - raise Internal_Error; - end if; - - Info := Add_Info (Def, Kind_Type); - - if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then - raise Internal_Error; - end if; - Translate_Bool_Type (Def); - - -- This is usually done in translate_type_definition, but boolean - -- types are not handled by translate_type_definition. - Create_Scalar_Type_Range_Type (Def, True); - end Translate_Bool_Type_Definition; - - procedure Translate_Type_Subprograms (Decl : Iir) - is - Def : Iir; - Tinfo : Type_Info_Acc; - Id : Name_Id; - begin - Def := Get_Type_Definition (Decl); - - if Get_Kind (Def) in Iir_Kinds_Subtype_Definition then - -- Also elaborate the base type, iff DEF and its BASE_TYPE have - -- been declared by the same type declarator. This avoids several - -- elaboration of the same type. - Def := Get_Base_Type (Def); - if Get_Type_Declarator (Def) /= Decl then - -- Can this happen ?? - raise Internal_Error; - end if; - elsif Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then - return; - end if; - - if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then - Translate_Protected_Type_Subprograms (Def); - end if; - - Tinfo := Get_Info (Def); - if not Is_Complex_Type (Tinfo) - or else Tinfo.C (Mode_Value).Builder_Need_Func = False - then - return; - end if; - - -- Declare subprograms. - Id := Get_Identifier (Decl); - Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); - if Get_Has_Signal_Flag (Def) then - Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal); - end if; - - if Global_Storage = O_Storage_External then - return; - end if; - - -- Define subprograms. - case Get_Kind (Def) is - when Iir_Kind_Array_Type_Definition => - Create_Array_Type_Builder (Def, Mode_Value); - if Get_Has_Signal_Flag (Def) then - Create_Array_Type_Builder (Def, Mode_Signal); - end if; - when Iir_Kind_Record_Type_Definition => - Create_Record_Type_Builder (Def, Mode_Value); - if Get_Has_Signal_Flag (Def) then - Create_Record_Type_Builder (Def, Mode_Signal); - end if; - when others => - Error_Kind ("translate_type_subprograms", Def); - end case; - end Translate_Type_Subprograms; - - -- Initialize the objects related to a type (type range and type - -- descriptor). - procedure Elab_Type_Definition (Def : Iir); - procedure Elab_Type_Definition_Depend is new Handle_Anonymous_Subtypes - (Handle_A_Subtype => Elab_Type_Definition); - procedure Elab_Type_Definition (Def : Iir) is - begin - case Get_Kind (Def) is - when Iir_Kind_Incomplete_Type_Definition => - -- Nothing to do. - return; - when Iir_Kind_Protected_Type_Declaration => - -- Elaboration subprograms interfaces. - declare - Final : Boolean; - begin - Chap4.Elab_Declaration_Chain (Def, Final); - if Final then - raise Internal_Error; - end if; - end; - return; - when others => - null; - end case; - - if Get_Type_Staticness (Def) = Locally then - return; - end if; - - Elab_Type_Definition_Depend (Def); - - Create_Type_Definition_Type_Range (Def); - Create_Type_Definition_Size_Var (Def); - end Elab_Type_Definition; - - procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id) - is - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Id); - Chap3.Translate_Type_Definition (Def); - Pop_Identifier_Prefix (Mark); - end Translate_Named_Type_Definition; - - procedure Translate_Anonymous_Type_Definition - (Def : Iir; Transient : Boolean) - is - Mark : Id_Mark_Type; - Type_Info : Type_Info_Acc; - begin - Type_Info := Get_Info (Def); - if Type_Info /= null then - return; - end if; - Push_Identifier_Prefix_Uniq (Mark); - Chap3.Translate_Type_Definition (Def, False); - if Transient then - Add_Transient_Type_In_Temp (Def); - end if; - Pop_Identifier_Prefix (Mark); - end Translate_Anonymous_Type_Definition; - - procedure Translate_Object_Subtype (Decl : Iir; - With_Vars : Boolean := True) - is - Mark : Id_Mark_Type; - Mark2 : Id_Mark_Type; - Def : Iir; - begin - Def := Get_Type (Decl); - if Is_Anonymous_Type_Definition (Def) then - Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Push_Identifier_Prefix (Mark2, "OT"); - Chap3.Translate_Type_Definition (Def, With_Vars); - Pop_Identifier_Prefix (Mark2); - Pop_Identifier_Prefix (Mark); - end if; - end Translate_Object_Subtype; - - procedure Elab_Object_Subtype (Def : Iir) is - begin - if Is_Anonymous_Type_Definition (Def) then - Elab_Type_Definition (Def); - end if; - end Elab_Object_Subtype; - - procedure Elab_Type_Declaration (Decl : Iir) - is - begin - Elab_Type_Definition (Get_Type_Definition (Decl)); - end Elab_Type_Declaration; - - procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration) - is - begin - Elab_Type_Definition (Get_Type (Decl)); - end Elab_Subtype_Declaration; - - function Get_Thin_Array_Length (Atype : Iir) return O_Cnode - is - Indexes_List : constant Iir_List := Get_Index_Subtype_List (Atype); - Nbr_Dim : constant Natural := Get_Nbr_Elements (Indexes_List); - Index : Iir; - Val : Iir_Int64; - Rng : Iir; - begin - Val := 1; - for I in 0 .. Nbr_Dim - 1 loop - Index := Get_Index_Type (Indexes_List, I); - Rng := Get_Range_Constraint (Index); - Val := Val * Eval_Discrete_Range_Length (Rng); - end loop; - return New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Val)); - end Get_Thin_Array_Length; - - function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) - return Mnode - is - Indexes_List : constant Iir_List := - Get_Index_Subtype_Definition_List (Get_Base_Type (Atype)); - Index_Type_Mark : constant Iir := - Get_Nth_Element (Indexes_List, Dim - 1); - Index_Type : constant Iir := Get_Index_Type (Index_Type_Mark); - Base_Index_Info : constant Index_Info_Acc := - Get_Info (Index_Type_Mark); - Iinfo : constant Type_Info_Acc := - Get_Info (Get_Base_Type (Index_Type)); - begin - return Lv2M (New_Selected_Element (M2Lv (B), - Base_Index_Info.Index_Field), - Iinfo, - Get_Object_Kind (B), - Iinfo.T.Range_Type, - Iinfo.T.Range_Ptr_Type); - end Bounds_To_Range; - - function Type_To_Range (Atype : Iir) return Mnode - is - Info : constant Type_Info_Acc := Get_Info (Atype); - begin - return Varv2M (Info.T.Range_Var, Info, Mode_Value, - Info.T.Range_Type, Info.T.Range_Ptr_Type); - end Type_To_Range; - - function Range_To_Length (R : Mnode) return Mnode - is - Tinfo : constant Type_Info_Acc := Get_Type_Info (R); - begin - return Lv2M (New_Selected_Element (M2Lv (R), - Tinfo.T.Range_Length), - Tinfo, - Mode_Value); - end Range_To_Length; - - function Range_To_Dir (R : Mnode) return Mnode - is - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Type_Info (R); - return Lv2M (New_Selected_Element (M2Lv (R), - Tinfo.T.Range_Dir), - Tinfo, - Mode_Value); - end Range_To_Dir; - - function Range_To_Left (R : Mnode) return Mnode - is - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Type_Info (R); - return Lv2M (New_Selected_Element (M2Lv (R), - Tinfo.T.Range_Left), - Tinfo, - Mode_Value); - end Range_To_Left; - - function Range_To_Right (R : Mnode) return Mnode - is - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Type_Info (R); - return Lv2M (New_Selected_Element (M2Lv (R), - Tinfo.T.Range_Right), - Tinfo, - Mode_Value); - end Range_To_Right; - - function Get_Array_Type_Bounds (Info : Type_Info_Acc) return Mnode - is - begin - case Info.Type_Mode is - when Type_Mode_Fat_Array => - raise Internal_Error; - when Type_Mode_Array => - return Varv2M (Info.T.Array_Bounds, - Info, Mode_Value, - Info.T.Bounds_Type, - Info.T.Bounds_Ptr_Type); - when others => - raise Internal_Error; - end case; - end Get_Array_Type_Bounds; - - function Get_Array_Type_Bounds (Atype : Iir) return Mnode is - begin - return Get_Array_Type_Bounds (Get_Info (Atype)); - end Get_Array_Type_Bounds; - - function Get_Array_Bounds (Arr : Mnode) return Mnode - is - Info : constant Type_Info_Acc := Get_Type_Info (Arr); - begin - case Info.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => - declare - Kind : Object_Kind_Type; - begin - Kind := Get_Object_Kind (Arr); - return Lp2M - (New_Selected_Element (M2Lv (Arr), - Info.T.Bounds_Field (Kind)), - Info, - Mode_Value, - Info.T.Bounds_Type, - Info.T.Bounds_Ptr_Type); - end; - when Type_Mode_Array => - return Get_Array_Type_Bounds (Info); - when others => - raise Internal_Error; - end case; - end Get_Array_Bounds; - - function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) - return Mnode is - begin - return Bounds_To_Range (Get_Array_Bounds (Arr), Atype, Dim); - end Get_Array_Range; - - function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode - is - Type_Info : constant Type_Info_Acc := Get_Info (Atype); - Index_List : constant Iir_List := Get_Index_Subtype_List (Atype); - Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); - Dim_Length : O_Enode; - Res : O_Enode; - Bounds_Stable : Mnode; - begin - if Type_Info.Type_Locally_Constrained then - return New_Lit (Get_Thin_Array_Length (Atype)); - end if; - - if Nbr_Dim > 1 then - Bounds_Stable := Stabilize (Bounds); - else - Bounds_Stable := Bounds; - end if; - - for Dim in 1 .. Nbr_Dim loop - Dim_Length := - M2E (Range_To_Length - (Bounds_To_Range (Bounds_Stable, Atype, Dim))); - if Dim = 1 then - Res := Dim_Length; - else - Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); - end if; - end loop; - return Res; - end Get_Bounds_Length; - - function Get_Array_Type_Length (Atype : Iir) return O_Enode - is - Type_Info : constant Type_Info_Acc := Get_Info (Atype); - begin - if Type_Info.Type_Locally_Constrained then - return New_Lit (Get_Thin_Array_Length (Atype)); - else - return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype); - end if; - end Get_Array_Type_Length; - - function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode - is - Type_Info : constant Type_Info_Acc := Get_Info (Atype); - begin - if Type_Info.Type_Locally_Constrained then - return New_Lit (Get_Thin_Array_Length (Atype)); - else - return Get_Bounds_Length (Get_Array_Bounds (Arr), Atype); - end if; - end Get_Array_Length; - - function Get_Array_Base (Arr : Mnode) return Mnode - is - Info : Type_Info_Acc; - begin - Info := Get_Type_Info (Arr); - case Info.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => - declare - Kind : Object_Kind_Type; - begin - Kind := Get_Object_Kind (Arr); - return Lp2M - (New_Selected_Element (M2Lv (Arr), - Info.T.Base_Field (Kind)), - Info, - Get_Object_Kind (Arr), - Info.T.Base_Type (Kind), - Info.T.Base_Ptr_Type (Kind)); - end; - when Type_Mode_Array => - return Arr; - when others => - raise Internal_Error; - end case; - end Get_Array_Base; - - function Reindex_Complex_Array - (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc) - return Mnode - is - El_Type : constant Iir := Get_Element_Subtype (Atype); - El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); - Kind : constant Object_Kind_Type := Get_Object_Kind (Base); - begin - pragma Assert (Is_Complex_Type (El_Tinfo)); - return - E2M - (New_Unchecked_Address - (New_Slice - (New_Access_Element - (New_Convert_Ov (M2E (Base), Char_Ptr_Type)), - Chararray_Type, - New_Dyadic_Op (ON_Mul_Ov, - New_Value - (Get_Var (El_Tinfo.C (Kind).Size_Var)), - Index)), - El_Tinfo.Ortho_Ptr_Type (Kind)), - Res_Info, Kind); - end Reindex_Complex_Array; - - function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) - return Mnode - is - El_Type : constant Iir := Get_Element_Subtype (Atype); - El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); - Kind : constant Object_Kind_Type := Get_Object_Kind (Base); - begin - if Is_Complex_Type (El_Tinfo) then - return Reindex_Complex_Array (Base, Atype, Index, El_Tinfo); - else - return Lv2M (New_Indexed_Element (M2Lv (Base), Index), - El_Tinfo, Kind); - end if; - end Index_Base; - - function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) - return Mnode - is - T_Info : constant Type_Info_Acc := Get_Info (Atype); - El_Type : constant Iir := Get_Element_Subtype (Atype); - El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); - Kind : constant Object_Kind_Type := Get_Object_Kind (Base); - begin - if Is_Complex_Type (El_Tinfo) then - return Reindex_Complex_Array (Base, Atype, Index, T_Info); - else - return Lv2M (New_Slice (M2Lv (Base), - T_Info.T.Base_Type (Kind), - Index), - False, - T_Info.T.Base_Type (Kind), - T_Info.T.Base_Ptr_Type (Kind), - T_Info, Kind); - end if; - end Slice_Base; - - procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; - Res : Mnode; - Arr_Type : Iir) - is - Dinfo : constant Type_Info_Acc := - Get_Info (Get_Base_Type (Arr_Type)); - Kind : constant Object_Kind_Type := Get_Object_Kind (Res); - Length : O_Enode; - begin - -- Compute array size. - Length := Get_Object_Size (Res, Arr_Type); - -- Allocate the storage for the elements. - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Base (Res)), - Gen_Alloc (Alloc_Kind, Length, Dinfo.T.Base_Ptr_Type (Kind))); - - if Is_Complex_Type (Dinfo) - and then Dinfo.C (Kind).Builder_Need_Func - then - Open_Temp; - -- Build the type. - Chap3.Gen_Call_Type_Builder (Res, Arr_Type); - Close_Temp; - end if; - end Allocate_Fat_Array_Base; - - procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean) - is - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix_Uniq (Mark); - if Get_Info (Sub_Type) = null then - -- Minimal subtype creation. - Translate_Type_Definition (Sub_Type, False); - if Transient then - Add_Transient_Type_In_Temp (Sub_Type); - end if; - end if; - -- Force creation of variables. - Chap3.Create_Array_Subtype_Bounds_Var (Sub_Type, True); - Chap3.Create_Type_Definition_Size_Var (Sub_Type); - Pop_Identifier_Prefix (Mark); - end Create_Array_Subtype; - - -- Copy SRC to DEST. - -- Both have the same type, OTYPE. - procedure Translate_Object_Copy (Dest : Mnode; - Src : O_Enode; - Obj_Type : Iir) - is - Info : constant Type_Info_Acc := Get_Info (Obj_Type); - Kind : constant Object_Kind_Type := Get_Object_Kind (Dest); - D : Mnode; - begin - case Info.Type_Mode is - when Type_Mode_Scalar - | Type_Mode_Acc - | Type_Mode_File => - -- Scalar or thin pointer. - New_Assign_Stmt (M2Lv (Dest), Src); - when Type_Mode_Fat_Acc => - -- a fat pointer. - D := Stabilize (Dest); - Copy_Fat_Pointer (D, Stabilize (E2M (Src, Info, Kind))); - when Type_Mode_Fat_Array => - -- a fat array. - D := Stabilize (Dest); - Gen_Memcpy (M2Addr (Get_Array_Base (D)), - M2Addr (Get_Array_Base (E2M (Src, Info, Kind))), - Get_Object_Size (D, Obj_Type)); - when Type_Mode_Array - | Type_Mode_Record => - D := Stabilize (Dest); - Gen_Memcpy (M2Addr (D), Src, Get_Object_Size (D, Obj_Type)); - when Type_Mode_Unknown - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Translate_Object_Copy; - - function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) - return O_Enode - is - Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); - Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); - begin - if Is_Complex_Type (Type_Info) - and then Type_Info.C (Kind).Size_Var /= Null_Var - then - return New_Value (Get_Var (Type_Info.C (Kind).Size_Var)); - end if; - case Type_Info.Type_Mode is - when Type_Mode_Non_Composite - | Type_Mode_Array - | Type_Mode_Record => - return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind), - Ghdl_Index_Type)); - when Type_Mode_Fat_Array => - declare - El_Type : Iir; - El_Tinfo : Type_Info_Acc; - Obj_Bt : Iir; - Sz : O_Enode; - begin - Obj_Bt := Get_Base_Type (Obj_Type); - El_Type := Get_Element_Subtype (Obj_Bt); - El_Tinfo := Get_Info (El_Type); - -- See create_type_definition_size_var. - Sz := Get_Object_Size (T2M (El_Type, Kind), El_Type); - if Is_Complex_Type (El_Tinfo) then - Sz := New_Dyadic_Op - (ON_Add_Ov, - Sz, - New_Lit (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind), - Ghdl_Index_Type))); - end if; - return New_Dyadic_Op - (ON_Mul_Ov, Chap3.Get_Array_Length (Obj, Obj_Bt), Sz); - end; - when others => - raise Internal_Error; - end case; - end Get_Object_Size; - - procedure Translate_Object_Allocation - (Res : in out Mnode; - Alloc_Kind : Allocation_Kind; - Obj_Type : Iir; - Bounds : Mnode) - is - Dinfo : constant Type_Info_Acc := Get_Info (Obj_Type); - Kind : constant Object_Kind_Type := Get_Object_Kind (Res); - begin - if Dinfo.Type_Mode = Type_Mode_Fat_Array then - -- Allocate memory for bounds. - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Res)), - Gen_Alloc (Alloc_Kind, - New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, - Ghdl_Index_Type)), - Dinfo.T.Bounds_Ptr_Type)); - - -- Copy bounds to the allocated area. - Gen_Memcpy - (M2Addr (Chap3.Get_Array_Bounds (Res)), - M2Addr (Bounds), - New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, Ghdl_Index_Type))); - - -- Allocate base. - Allocate_Fat_Array_Base (Alloc_Kind, Res, Obj_Type); - else - New_Assign_Stmt - (M2Lp (Res), - Gen_Alloc - (Alloc_Kind, - Chap3.Get_Object_Size (T2M (Obj_Type, Kind), - Obj_Type), - Dinfo.Ortho_Ptr_Type (Kind))); - - if Is_Complex_Type (Dinfo) - and then Dinfo.C (Kind).Builder_Need_Func - then - Open_Temp; - -- Build the type. - Chap3.Gen_Call_Type_Builder (Res, Obj_Type); - Close_Temp; - end if; - - end if; - end Translate_Object_Allocation; - - procedure Gen_Deallocate (Obj : O_Enode) - is - Assocs : O_Assoc_List; - begin - Start_Association (Assocs, Ghdl_Deallocate); - New_Association (Assocs, New_Convert_Ov (Obj, Ghdl_Ptr_Type)); - New_Procedure_Call (Assocs); - end Gen_Deallocate; - - -- Performs deallocation of PARAM (the parameter of a deallocate call). - procedure Translate_Object_Deallocation (Param : Iir) - is - -- Performs deallocation of field FIELD of type FTYPE of PTR. - -- If FIELD is O_FNODE_NULL, deallocate PTR (of type FTYPE). - -- Here, deallocate means freeing memory and clearing to null. - procedure Deallocate_1 - (Ptr : Mnode; Field : O_Fnode; Ftype : O_Tnode) - is - L : O_Lnode; - begin - for I in 0 .. 1 loop - L := M2Lv (Ptr); - if Field /= O_Fnode_Null then - L := New_Selected_Element (L, Field); - end if; - case I is - when 0 => - -- Call deallocator. - Gen_Deallocate (New_Value (L)); - when 1 => - -- set the value to 0. - New_Assign_Stmt (L, New_Lit (New_Null_Access (Ftype))); - end case; - end loop; - end Deallocate_1; - - Param_Type : Iir; - Val : Mnode; - Info : Type_Info_Acc; - Binfo : Type_Info_Acc; - begin - -- Compute parameter - Val := Chap6.Translate_Name (Param); - if Get_Object_Kind (Val) = Mode_Signal then - raise Internal_Error; - end if; - Stabilize (Val); - Param_Type := Get_Type (Param); - Info := Get_Info (Param_Type); - case Info.Type_Mode is - when Type_Mode_Fat_Acc => - -- This is a fat pointer. - -- Deallocate base and bounds. - Binfo := Get_Info (Get_Designated_Type (Param_Type)); - Deallocate_1 (Val, Binfo.T.Base_Field (Mode_Value), - Binfo.T.Base_Ptr_Type (Mode_Value)); - Deallocate_1 (Val, Binfo.T.Bounds_Field (Mode_Value), - Binfo.T.Bounds_Ptr_Type); - when Type_Mode_Acc => - -- This is a thin pointer. - Deallocate_1 (Val, O_Fnode_Null, - Info.Ortho_Type (Mode_Value)); - when others => - raise Internal_Error; - end case; - end Translate_Object_Deallocation; - - function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode - is - Constr : Iir; - Info : Type_Info_Acc; - - function Gen_Compare (Low : O_Enode; Hi : O_Enode) return O_Enode - is - L, H : O_Enode; - begin - if not Info.T.Nocheck_Low then - L := New_Compare_Op - (ON_Lt, New_Obj_Value (Value), Low, Ghdl_Bool_Type); - end if; - if not Info.T.Nocheck_Hi then - H := New_Compare_Op - (ON_Gt, New_Obj_Value (Value), Hi, Ghdl_Bool_Type); - end if; - if Info.T.Nocheck_Hi then - if Info.T.Nocheck_Low then - -- Should not happen! - return New_Lit (Ghdl_Bool_False_Node); - else - return L; - end if; - else - if Info.T.Nocheck_Low then - return H; - else - return New_Dyadic_Op (ON_Or, L, H); - end if; - end if; - end Gen_Compare; - - function Gen_Compare_To return O_Enode is - begin - return Gen_Compare - (Chap14.Translate_Left_Type_Attribute (Atype), - Chap14.Translate_Right_Type_Attribute (Atype)); - end Gen_Compare_To; - - function Gen_Compare_Downto return O_Enode is - begin - return Gen_Compare - (Chap14.Translate_Right_Type_Attribute (Atype), - Chap14.Translate_Left_Type_Attribute (Atype)); - end Gen_Compare_Downto; - - --Low, High : Iir; - Var_Res : O_Dnode; - If_Blk : O_If_Block; - begin - Constr := Get_Range_Constraint (Atype); - Info := Get_Info (Atype); - - if Get_Kind (Constr) = Iir_Kind_Range_Expression then - -- Constraint is a range expression, therefore, direction is - -- known. - if Get_Expr_Staticness (Constr) = Locally then - -- Range constraint is locally static - -- FIXME: check low and high if they are not limits... - --Low := Get_Low_Limit (Constr); - --High := Get_High_Limit (Constr); - null; - end if; - case Get_Direction (Constr) is - when Iir_To => - return Gen_Compare_To; - when Iir_Downto => - return Gen_Compare_Downto; - end case; - end if; - - -- Range constraint is not static - -- full check (lot's of code ?). - Var_Res := Create_Temp (Ghdl_Bool_Type); - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - Chap14.Translate_Dir_Type_Attribute (Atype), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - -- To. - New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_To); - New_Else_Stmt (If_Blk); - -- Downto - New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_Downto); - Finish_If_Stmt (If_Blk); - return New_Obj_Value (Var_Res); - end Not_In_Range; - - function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean - is - Info : constant Type_Info_Acc := Get_Info (Atype); - begin - if Info.T.Nocheck_Low and Info.T.Nocheck_Hi then - return False; - end if; - if Expr /= Null_Iir and then Get_Type (Expr) = Atype then - return False; - end if; - return True; - end Need_Range_Check; - - procedure Check_Range - (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir) - is - If_Blk : O_If_Block; - begin - if not Need_Range_Check (Expr, Atype) then - return; - end if; - - if Expr /= Null_Iir - and then Get_Expr_Staticness (Expr) = Locally - and then Get_Type_Staticness (Atype) = Locally - then - if not Eval_Is_In_Bound (Eval_Static_Expr (Expr), Atype) then - Chap6.Gen_Bound_Error (Loc); - end if; - else - Open_Temp; - Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype)); - Chap6.Gen_Bound_Error (Loc); - Finish_If_Stmt (If_Blk); - Close_Temp; - end if; - end Check_Range; - - function Insert_Scalar_Check - (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) - return O_Enode - is - Var : O_Dnode; - begin - Var := Create_Temp_Init - (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value); - Check_Range (Var, Expr, Atype, Loc); - return New_Obj_Value (Var); - end Insert_Scalar_Check; - - function Maybe_Insert_Scalar_Check - (Value : O_Enode; Expr : Iir; Atype : Iir) - return O_Enode - is - Expr_Type : constant Iir := Get_Type (Expr); - begin - -- pragma Assert (Base_Type = Get_Base_Type (Atype)); - if Get_Kind (Expr_Type) in Iir_Kinds_Scalar_Type_Definition - and then Need_Range_Check (Expr, Atype) - then - return Insert_Scalar_Check (Value, Expr, Atype, Expr); - else - return Value; - end if; - end Maybe_Insert_Scalar_Check; - - function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean - is - L_Indexes : constant Iir_List := Get_Index_Subtype_List (L_Type); - R_Indexes : constant Iir_List := Get_Index_Subtype_List (R_Type); - L_El : Iir; - R_El : Iir; - begin - for I in Natural loop - L_El := Get_Index_Type (L_Indexes, I); - R_El := Get_Index_Type (R_Indexes, I); - exit when L_El = Null_Iir and R_El = Null_Iir; - if Eval_Discrete_Type_Length (L_El) - /= Eval_Discrete_Type_Length (R_El) - then - return False; - end if; - end loop; - return True; - end Locally_Array_Match; - - procedure Check_Array_Match (L_Type : Iir; - L_Node : Mnode; - R_Type : Iir; - R_Node : Mnode; - Loc : Iir) - is - L_Tinfo, R_Tinfo : Type_Info_Acc; - begin - L_Tinfo := Get_Info (L_Type); - R_Tinfo := Get_Info (R_Type); - -- FIXME: optimize for a statically bounded array of a complex type. - if L_Tinfo.Type_Mode = Type_Mode_Array - and then L_Tinfo.Type_Locally_Constrained - and then R_Tinfo.Type_Mode = Type_Mode_Array - and then R_Tinfo.Type_Locally_Constrained - then - -- Both left and right are thin array. - -- Check here the length are the same. - if not Locally_Array_Match (L_Type, R_Type) then - Chap6.Gen_Bound_Error (Loc); - end if; - else - -- Check length match. - declare - Index_List : constant Iir_List := - Get_Index_Subtype_List (L_Type); - Index : Iir; - Cond : O_Enode; - Sub_Cond : O_Enode; - begin - for I in Natural loop - Index := Get_Nth_Element (Index_List, I); - exit when Index = Null_Iir; - Sub_Cond := New_Compare_Op - (ON_Neq, - M2E (Range_To_Length - (Get_Array_Range (L_Node, L_Type, I + 1))), - M2E (Range_To_Length - (Get_Array_Range (R_Node, R_Type, I + 1))), - Ghdl_Bool_Type); - if I = 0 then - Cond := Sub_Cond; - else - Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); - end if; - end loop; - Chap6.Check_Bound_Error (Cond, Loc, 0); - end; - end if; - end Check_Array_Match; - - procedure Create_Range_From_Array_Attribute_And_Length - (Array_Attr : Iir; Length : O_Dnode; Range_Ptr : O_Dnode) - is - Attr_Kind : Iir_Kind; - Arr_Rng : Mnode; - Iinfo : Type_Info_Acc; - - Res : Mnode; - - Dir : O_Enode; - Diff : O_Dnode; - Left_Bound : Mnode; - If_Blk : O_If_Block; - If_Blk1 : O_If_Block; - begin - Open_Temp; - Arr_Rng := Chap14.Translate_Array_Attribute_To_Range (Array_Attr); - Iinfo := Get_Type_Info (Arr_Rng); - Stabilize (Arr_Rng); - - Res := Dp2M (Range_Ptr, Iinfo, Mode_Value); - - -- Length. - New_Assign_Stmt (M2Lv (Range_To_Length (Arr_Rng)), - New_Obj_Value (Length)); - - -- Direction. - Attr_Kind := Get_Kind (Array_Attr); - Dir := M2E (Range_To_Dir (Arr_Rng)); - case Attr_Kind is - when Iir_Kind_Range_Array_Attribute => - New_Assign_Stmt (M2Lv (Range_To_Dir (Res)), Dir); - when Iir_Kind_Reverse_Range_Array_Attribute => - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Eq, - Dir, - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - New_Assign_Stmt - (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_Downto_Node)); - New_Else_Stmt (If_Blk); - New_Assign_Stmt - (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_To_Node)); - Finish_If_Stmt (If_Blk); - when others => - Error_Kind ("Create_Range_From_Array_Attribute_And_Length", - Array_Attr); - end case; - - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - New_Obj_Value (Length), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - -- Null range. - case Attr_Kind is - when Iir_Kind_Range_Array_Attribute => - New_Assign_Stmt (M2Lv (Range_To_Left (Res)), - M2E (Range_To_Right (Arr_Rng))); - New_Assign_Stmt (M2Lv (Range_To_Right (Res)), - M2E (Range_To_Left (Arr_Rng))); - when Iir_Kind_Reverse_Range_Array_Attribute => - New_Assign_Stmt (M2Lv (Range_To_Left (Res)), - M2E (Range_To_Left (Arr_Rng))); - New_Assign_Stmt (M2Lv (Range_To_Right (Res)), - M2E (Range_To_Right (Arr_Rng))); - when others => - raise Internal_Error; - end case; - - New_Else_Stmt (If_Blk); - - -- LEFT. - case Attr_Kind is - when Iir_Kind_Range_Array_Attribute => - Left_Bound := Range_To_Left (Arr_Rng); - when Iir_Kind_Reverse_Range_Array_Attribute => - Left_Bound := Range_To_Right (Arr_Rng); - when others => - raise Internal_Error; - end case; - Stabilize (Left_Bound); - New_Assign_Stmt (M2Lv (Range_To_Left (Res)), M2E (Left_Bound)); - - -- RIGHT. - Diff := Create_Temp_Init - (Iinfo.Ortho_Type (Mode_Value), - New_Convert_Ov - (New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Length), - New_Lit (Ghdl_Index_1)), - Iinfo.Ortho_Type (Mode_Value))); - - Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, - M2E (Range_To_Dir (Res)), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - New_Assign_Stmt (M2Lv (Range_To_Right (Res)), - New_Dyadic_Op (ON_Add_Ov, - M2E (Left_Bound), - New_Obj_Value (Diff))); - New_Else_Stmt (If_Blk1); - New_Assign_Stmt (M2Lv (Range_To_Right (Res)), - New_Dyadic_Op (ON_Sub_Ov, - M2E (Left_Bound), - New_Obj_Value (Diff))); - Finish_If_Stmt (If_Blk1); - - -- FIXME: check right bounds is inside bounds. - Finish_If_Stmt (If_Blk); - Close_Temp; - end Create_Range_From_Array_Attribute_And_Length; - - procedure Create_Range_From_Length - (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir) - is - Iinfo : constant Type_Info_Acc := Get_Info (Index_Type); - Range_Constr : constant Iir := Get_Range_Constraint (Index_Type); - Op : ON_Op_Kind; - Diff : O_Enode; - Left_Bound : O_Enode; - Var_Right : O_Dnode; - If_Blk : O_If_Block; - begin - if Get_Kind (Range_Constr) /= Iir_Kind_Range_Expression then - Create_Range_From_Array_Attribute_And_Length - (Range_Constr, Length, Range_Ptr); - return; - end if; - - Start_Declare_Stmt; - New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), - O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Length), - New_Obj_Value (Length)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Dir), - New_Lit (Chap7.Translate_Static_Range_Dir (Range_Constr))); - - case Get_Direction (Range_Constr) is - when Iir_To => - Op := ON_Add_Ov; - when Iir_Downto => - Op := ON_Sub_Ov; - end case; - - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - New_Obj_Value (Length), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - -- Null range. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), - Chap7.Translate_Range_Expression_Right (Range_Constr, Index_Type)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), - Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); - - New_Else_Stmt (If_Blk); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), - Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); - Left_Bound := Chap7.Translate_Range_Expression_Left - (Range_Constr, Index_Type); - Diff := New_Convert_Ov - (New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Length), - New_Lit (Ghdl_Index_1)), - Iinfo.Ortho_Type (Mode_Value)); - New_Assign_Stmt (New_Obj (Var_Right), - New_Dyadic_Op (Op, Left_Bound, Diff)); - - -- Check the right bounds is inside the bounds of the index type. - Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Loc); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), - New_Obj_Value (Var_Right)); - Finish_If_Stmt (If_Blk); - Finish_Declare_Stmt; - end Create_Range_From_Length; - end Chap3; - - package body Chap4 is - -- Get the ortho type for an object of mode MODE. - function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) - return O_Tnode is - begin - if Is_Complex_Type (Tinfo) then - case Tinfo.Type_Mode is - when Type_Mode_Fat_Array => - return Tinfo.Ortho_Type (Kind); - when Type_Mode_Record - | Type_Mode_Array - | Type_Mode_Protected => - -- For a complex type, use a pointer. - return Tinfo.Ortho_Ptr_Type (Kind); - when others => - raise Internal_Error; - end case; - else - return Tinfo.Ortho_Type (Kind); - end if; - end Get_Object_Type; - - procedure Create_Object (El : Iir) - is - Obj_Type : O_Tnode; - Info : Object_Info_Acc; - Tinfo : Type_Info_Acc; - Def : Iir; - Val : Iir; - Storage : O_Storage; - Deferred : Iir; - begin - Def := Get_Type (El); - Val := Get_Default_Value (El); - - -- Be sure the object type was translated. - if Get_Kind (El) = Iir_Kind_Constant_Declaration - and then Get_Deferred_Declaration_Flag (El) = False - and then Get_Deferred_Declaration (El) /= Null_Iir - then - -- This is a full constant declaration which complete a previous - -- incomplete constant declaration. - -- - -- Do not create the subtype of this full constant declaration, - -- since it was already created by the deferred declaration. - -- Use the type of the deferred declaration. - Deferred := Get_Deferred_Declaration (El); - Def := Get_Type (Deferred); - Info := Get_Info (Deferred); - Set_Info (El, Info); - else - Chap3.Translate_Object_Subtype (El); - Info := Add_Info (El, Kind_Object); - end if; - - Tinfo := Get_Info (Def); - Obj_Type := Get_Object_Type (Tinfo, Mode_Value); - - case Get_Kind (El) is - when Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_Constant_Declaration => - Info.Object_Var := - Create_Var (Create_Var_Identifier (El), Obj_Type); - when Iir_Kind_Constant_Declaration => - if Get_Deferred_Declaration (El) /= Null_Iir then - -- This is a full constant declaration (in a body) of a - -- deferred constant declaration (in a package). - Storage := O_Storage_Public; - else - Storage := Global_Storage; - end if; - if Info.Object_Var = Null_Var then - -- Not a full constant declaration (ie a value for an - -- already declared constant). - -- Must create the declaration. - if Chap7.Is_Static_Constant (El) then - Info.Object_Static := True; - Info.Object_Var := Create_Global_Const - (Create_Identifier (El), Obj_Type, Global_Storage, - O_Cnode_Null); - else - Info.Object_Static := False; - Info.Object_Var := Create_Var - (Create_Var_Identifier (El), - Obj_Type, Global_Storage); - end if; - end if; - if Get_Deferred_Declaration (El) = Null_Iir - and then Info.Object_Static - and then Storage /= O_Storage_External - then - -- Deferred constant are never considered as locally static. - -- FIXME: to be improved ? - - -- open_temp/close_temp only required for transient types. - Open_Temp; - Define_Global_Const - (Info.Object_Var, - Chap7.Translate_Static_Expression (Val, Def)); - Close_Temp; - end if; - when others => - Error_Kind ("create_objet", El); - end case; - end Create_Object; - - procedure Create_Signal (Decl : Iir) - is - Sig_Type_Def : constant Iir := Get_Type (Decl); - Sig_Type : O_Tnode; - Type_Info : Type_Info_Acc; - Info : Ortho_Info_Acc; - begin - Chap3.Translate_Object_Subtype (Decl); - - Type_Info := Get_Info (Sig_Type_Def); - Sig_Type := Get_Object_Type (Type_Info, Mode_Signal); - pragma Assert (Sig_Type /= O_Tnode_Null); - - Info := Add_Info (Decl, Kind_Object); - - Info.Object_Var := - Create_Var (Create_Var_Identifier (Decl), Sig_Type); - - case Get_Kind (Decl) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration => - Rtis.Generate_Signal_Rti (Decl); - when Iir_Kind_Guard_Signal_Declaration => - -- No name created for guard signal. - null; - when others => - Error_Kind ("create_signal", Decl); - end case; - end Create_Signal; - - procedure Create_Implicit_Signal (Decl : Iir) - is - Sig_Type : O_Tnode; - Type_Info : Type_Info_Acc; - Info : Ortho_Info_Acc; - Sig_Type_Def : Iir; - begin - Sig_Type_Def := Get_Type (Decl); - -- This has been disabled since DECL can have an anonymous subtype, - -- and DECL has no identifiers, which causes translate_object_subtype - -- to crash. - -- Note: DECL can only be a iir_kind_delayed_attribute. - --Chap3.Translate_Object_Subtype (Decl); - Type_Info := Get_Info (Sig_Type_Def); - Sig_Type := Type_Info.Ortho_Type (Mode_Signal); - if Sig_Type = O_Tnode_Null then - raise Internal_Error; - end if; - - Info := Add_Info (Decl, Kind_Object); - - Info.Object_Var := Create_Var (Create_Uniq_Identifier, Sig_Type); - end Create_Implicit_Signal; - - procedure Create_File_Object (El : Iir_File_Declaration) - is - Obj_Type : O_Tnode; - Info : Ortho_Info_Acc; - Obj_Type_Def : Iir; - begin - Obj_Type_Def := Get_Type (El); - Obj_Type := Get_Ortho_Type (Obj_Type_Def, Mode_Value); - - Info := Add_Info (El, Kind_Object); - - Info.Object_Var := Create_Var (Create_Var_Identifier (El), Obj_Type); - end Create_File_Object; - - procedure Create_Package_Interface (Inter : Iir) - is - Info : Ortho_Info_Acc; - Pkg : constant Iir := Get_Named_Entity - (Get_Uninstantiated_Package_Name (Inter)); - Pkg_Info : constant Ortho_Info_Acc := Get_Info (Pkg); - begin - Chap2.Instantiate_Info_Package (Inter); - Info := Get_Info (Inter); - - -- The spec - Info.Package_Instance_Spec_Var := - Create_Var (Create_Var_Identifier (Inter, "SPEC", 0), - Pkg_Info.Package_Spec_Ptr_Type); - Set_Scope_Via_Var_Ptr - (Info.Package_Instance_Spec_Scope, - Info.Package_Instance_Spec_Var); - - -- The body - Info.Package_Instance_Body_Var := - Create_Var (Create_Var_Identifier (Inter, "BODY", 0), - Pkg_Info.Package_Body_Ptr_Type); - Set_Scope_Via_Var_Ptr - (Info.Package_Instance_Body_Scope, - Info.Package_Instance_Body_Var); - end Create_Package_Interface; - - procedure Allocate_Complex_Object (Obj_Type : Iir; - Alloc_Kind : Allocation_Kind; - Var : in out Mnode) - is - Type_Info : constant Type_Info_Acc := Get_Type_Info (Var); - Kind : constant Object_Kind_Type := Get_Object_Kind (Var); - Targ : Mnode; - begin - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - -- Cannot allocate unconstrained object (since size is unknown). - raise Internal_Error; - end if; - - if not Is_Complex_Type (Type_Info) then - -- Object is not complex. - return; - end if; - - if Type_Info.C (Kind).Builder_Need_Func - and then not Is_Stable (Var) - then - Targ := Create_Temp (Type_Info, Kind); - else - Targ := Var; - end if; - - -- Allocate variable. - New_Assign_Stmt - (M2Lp (Targ), - Gen_Alloc (Alloc_Kind, - Chap3.Get_Object_Size (Var, Obj_Type), - Type_Info.Ortho_Ptr_Type (Kind))); - - if Type_Info.C (Kind).Builder_Need_Func then - -- Build the type. - Chap3.Gen_Call_Type_Builder (Targ, Obj_Type); - if not Is_Stable (Var) then - New_Assign_Stmt (M2Lp (Var), M2Addr (Targ)); - Var := Targ; - end if; - end if; - end Allocate_Complex_Object; - - -- Note : OBJ can be a tree. - -- FIXME: should use translate_aggregate_others. - procedure Init_Array_Object (Obj : Mnode; Obj_Type : Iir) - is - Sobj : Mnode; - - -- Type of the object. - Type_Info : Type_Info_Acc; - - -- Iterator for the elements. - Index : O_Dnode; - - Upper_Limit : O_Enode; - Upper_Var : O_Dnode; - - Label : O_Snode; - begin - Type_Info := Get_Info (Obj_Type); - - -- Iterate on all elements of the object. - Open_Temp; - - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - Sobj := Stabilize (Obj); - else - Sobj := Obj; - end if; - Upper_Limit := Chap3.Get_Array_Length (Sobj, Obj_Type); - - if Type_Info.Type_Mode /= Type_Mode_Array then - Upper_Var := Create_Temp_Init (Ghdl_Index_Type, Upper_Limit); - else - Upper_Var := O_Dnode_Null; - end if; - - Index := Create_Temp (Ghdl_Index_Type); - Init_Var (Index); - Start_Loop_Stmt (Label); - if Upper_Var /= O_Dnode_Null then - Upper_Limit := New_Obj_Value (Upper_Var); - end if; - Gen_Exit_When (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Index), Upper_Limit, - Ghdl_Bool_Type)); - Init_Object (Chap3.Index_Base (Chap3.Get_Array_Base (Sobj), - Obj_Type, - New_Obj_Value (Index)), - Get_Element_Subtype (Obj_Type)); - Inc_Var (Index); - Finish_Loop_Stmt (Label); - - Close_Temp; - end Init_Array_Object; - - procedure Init_Protected_Object (Obj : Mnode; Obj_Type : Iir) - is - Assoc : O_Assoc_List; - Info : Type_Info_Acc; - begin - Info := Get_Info (Obj_Type); - - -- Call the initializer. - Start_Association (Assoc, Info.T.Prot_Init_Subprg); - Subprgs.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance); - -- Use of M2Lp is a little bit fragile (not sure we get the - -- variable, but should work: we didn't stabilize it). - New_Assign_Stmt (M2Lp (Obj), New_Function_Call (Assoc)); - end Init_Protected_Object; - - procedure Fini_Protected_Object (Decl : Iir) - is - Obj : Mnode; - Assoc : O_Assoc_List; - Info : Type_Info_Acc; - begin - Info := Get_Info (Get_Type (Decl)); - - Obj := Chap6.Translate_Name (Decl); - -- Call the Finalizator. - Start_Association (Assoc, Info.T.Prot_Final_Subprg); - New_Association (Assoc, M2E (Obj)); - New_Procedure_Call (Assoc); - end Fini_Protected_Object; - - procedure Init_Object (Obj : Mnode; Obj_Type : Iir) - is - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Type_Info (Obj); - case Tinfo.Type_Mode is - when Type_Mode_Scalar => - New_Assign_Stmt - (M2Lv (Obj), Chap14.Translate_Left_Type_Attribute (Obj_Type)); - when Type_Mode_Acc => - New_Assign_Stmt - (M2Lv (Obj), - New_Lit (New_Null_Access (Tinfo.Ortho_Type (Mode_Value)))); - when Type_Mode_Fat_Acc => - declare - Dinfo : Type_Info_Acc; - Sobj : Mnode; - begin - Open_Temp; - Sobj := Stabilize (Obj); - Dinfo := Get_Info (Get_Designated_Type (Obj_Type)); - New_Assign_Stmt - (New_Selected_Element (M2Lv (Sobj), - Dinfo.T.Bounds_Field (Mode_Value)), - New_Lit (New_Null_Access (Dinfo.T.Bounds_Ptr_Type))); - New_Assign_Stmt - (New_Selected_Element (M2Lv (Sobj), - Dinfo.T.Base_Field (Mode_Value)), - New_Lit (New_Null_Access - (Dinfo.T.Base_Ptr_Type (Mode_Value)))); - Close_Temp; - end; - when Type_Mode_Arrays => - Init_Array_Object (Obj, Obj_Type); - when Type_Mode_Record => - declare - Sobj : Mnode; - El : Iir_Element_Declaration; - List : Iir_List; - begin - Open_Temp; - Sobj := Stabilize (Obj); - List := Get_Elements_Declaration_List - (Get_Base_Type (Obj_Type)); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Init_Object (Chap6.Translate_Selected_Element (Sobj, El), - Get_Type (El)); - end loop; - Close_Temp; - end; - when Type_Mode_Protected => - Init_Protected_Object (Obj, Obj_Type); - when Type_Mode_Unknown - | Type_Mode_File => - raise Internal_Error; - end case; - end Init_Object; - - procedure Elab_Object_Storage (Obj : Iir) - is - Obj_Type : constant Iir := Get_Type (Obj); - Obj_Info : constant Object_Info_Acc := Get_Info (Obj); - - Name_Node : Mnode; - - Type_Info : Type_Info_Acc; - Alloc_Kind : Allocation_Kind; - begin - -- Elaborate subtype. - Chap3.Elab_Object_Subtype (Obj_Type); - - Type_Info := Get_Info (Obj_Type); - - -- FIXME: the object type may be a fat array! - -- FIXME: fat array + aggregate ? - - if Type_Info.Type_Mode = Type_Mode_Protected then - -- Protected object will be created by its INIT function. - return; - end if; - - if Is_Complex_Type (Type_Info) - and then Type_Info.Type_Mode /= Type_Mode_Fat_Array - then - -- FIXME: avoid allocation if the value is a string and - -- the object is a constant - Name_Node := Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value); - Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); - Allocate_Complex_Object (Obj_Type, Alloc_Kind, Name_Node); - end if; - end Elab_Object_Storage; - - -- Generate code to create object OBJ and initialize it with value VAL. - procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir) - is - Obj_Type : constant Iir := Get_Type (Obj); - Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type); - Obj_Info : constant Object_Info_Acc := Get_Info (Obj); - - Name_Node : Mnode; - Value_Node : O_Enode; - - Alloc_Kind : Allocation_Kind; - begin - -- Elaborate subtype. - Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); - - -- Note: no temporary variable region is created, as the allocation - -- may be performed on the stack. - - if Value = Null_Iir then - -- Performs default initialization. - Open_Temp; - Init_Object (Name, Obj_Type); - Close_Temp; - elsif Get_Kind (Value) = Iir_Kind_Aggregate then - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - -- Allocate. - declare - Aggr_Type : Iir; - begin - Aggr_Type := Get_Type (Value); - Chap3.Create_Array_Subtype (Aggr_Type, True); - Name_Node := Stabilize (Name); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), - M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type))); - Chap3.Allocate_Fat_Array_Base - (Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type)); - end; - else - Name_Node := Name; - end if; - Chap7.Translate_Aggregate (Name_Node, Obj_Type, Value); - else - Value_Node := Chap7.Translate_Expression (Value, Obj_Type); - - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - declare - S : Mnode; - begin - Name_Node := Stabilize (Name); - S := Stabilize (E2M (Value_Node, Type_Info, Mode_Value)); - - if Get_Kind (Value) = Iir_Kind_String_Literal - and then Get_Kind (Obj) = Iir_Kind_Constant_Declaration - then - -- No need to allocate space for the object. - Copy_Fat_Pointer (Name_Node, S); - else - Chap3.Translate_Object_Allocation - (Name_Node, Alloc_Kind, Obj_Type, - Chap3.Get_Array_Bounds (S)); - Chap3.Translate_Object_Copy - (Name_Node, M2Addr (S), Obj_Type); - end if; - end; - else - Chap3.Translate_Object_Copy (Name, Value_Node, Obj_Type); - end if; - Destroy_Local_Transient_Types; - end if; - end Elab_Object_Init; - - -- Generate code to create object OBJ and initialize it with value VAL. - procedure Elab_Object_Value (Obj : Iir; Value : Iir) - is - Name : Mnode; - begin - Elab_Object_Storage (Obj); - Name := Get_Var (Get_Info (Obj).Object_Var, - Get_Info (Get_Type (Obj)), Mode_Value); - Elab_Object_Init (Name, Obj, Value); - end Elab_Object_Value; - - -- Create code to elaborate OBJ. - procedure Elab_Object (Obj : Iir) - is - Value : Iir; - Obj1 : Iir; - begin - -- A locally static constant is pre-elaborated. - -- (only constant can be locally static). - if Get_Expr_Staticness (Obj) = Locally - and then Get_Deferred_Declaration (Obj) = Null_Iir - then - return; - end if; - - -- Set default value. - if Get_Kind (Obj) = Iir_Kind_Constant_Declaration then - if Get_Info (Obj).Object_Static then - return; - end if; - if Get_Deferred_Declaration_Flag (Obj) then - -- No code generation for a deferred constant. - return; - end if; - Obj1 := Get_Deferred_Declaration (Obj); - if Obj1 = Null_Iir then - Obj1 := Obj; - end if; - else - Obj1 := Obj; - end if; - - New_Debug_Line_Stmt (Get_Line_Number (Obj)); - - -- Still use the default value of the not deferred constant. - -- FIXME: what about composite types. - Value := Get_Default_Value (Obj); - Elab_Object_Value (Obj1, Value); - end Elab_Object; - - procedure Fini_Object (Obj : Iir) - is - Obj_Type : Iir; - Type_Info : Type_Info_Acc; - begin - Obj_Type := Get_Type (Obj); - Type_Info := Get_Info (Obj_Type); - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - declare - V : Mnode; - begin - Open_Temp; - V := Chap6.Translate_Name (Obj); - Stabilize (V); - Chap3.Gen_Deallocate - (New_Value (M2Lp (Chap3.Get_Array_Bounds (V)))); - Chap3.Gen_Deallocate - (New_Value (M2Lp (Chap3.Get_Array_Base (V)))); - Close_Temp; - end; - elsif Is_Complex_Type (Type_Info) then - Chap3.Gen_Deallocate - (New_Value (M2Lp (Chap6.Translate_Name (Obj)))); - end if; - end Fini_Object; - - function Get_Nbr_Signals (Sig : Mnode; Sig_Type : Iir) return O_Enode - is - Info : constant Type_Info_Acc := Get_Info (Sig_Type); - begin - case Info.Type_Mode is - when Type_Mode_Scalar => - -- Note: here we discard SIG... - return New_Lit (Ghdl_Index_1); - when Type_Mode_Arrays => - declare - Len : O_Dnode; - If_Blk : O_If_Block; - Ssig : Mnode; - begin - Ssig := Stabilize (Sig); - Len := Create_Temp_Init - (Ghdl_Index_Type, - Chap3.Get_Array_Length (Ssig, Sig_Type)); - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Neq, - New_Obj_Value (Len), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Obj (Len), - New_Dyadic_Op - (ON_Mul_Ov, - New_Obj_Value (Len), - Get_Nbr_Signals - (Chap3.Index_Base - (Chap3.Get_Array_Base (Ssig), Sig_Type, - New_Lit (Ghdl_Index_0)), - Get_Element_Subtype (Sig_Type)))); - Finish_If_Stmt (If_Blk); - - return New_Obj_Value (Len); - end; - when Type_Mode_Record => - declare - List : Iir_List; - El : Iir; - Res : O_Enode; - E : O_Enode; - Sig_El : Mnode; - Ssig : Mnode; - begin - List := - Get_Elements_Declaration_List (Get_Base_Type (Sig_Type)); - Ssig := Stabilize (Sig); - Res := O_Enode_Null; - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Sig_El := Chap6.Translate_Selected_Element (Ssig, El); - E := Get_Nbr_Signals (Sig_El, Get_Type (El)); - if Res /= O_Enode_Null then - Res := New_Dyadic_Op (ON_Add_Ov, Res, E); - else - Res := E; - end if; - end loop; - if Res = O_Enode_Null then - -- Empty records. - Res := New_Lit (Ghdl_Index_0); - end if; - return Res; - end; - when Type_Mode_Unknown - | Type_Mode_File - | Type_Mode_Acc - | Type_Mode_Fat_Acc - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Get_Nbr_Signals; - - -- Get the leftest signal of SIG. - -- The leftest signal of - -- a scalar signal is itself, - -- an array signal is the leftest, - -- a record signal is the first element. - function Get_Leftest_Signal (Sig: Mnode; Sig_Type : Iir) - return Mnode - is - Res : Mnode; - Res_Type : Iir; - Info : Type_Info_Acc; - begin - Res := Sig; - Res_Type := Sig_Type; - loop - Info := Get_Type_Info (Res); - case Info.Type_Mode is - when Type_Mode_Scalar => - return Res; - when Type_Mode_Arrays => - Res := Chap3.Index_Base - (Chap3.Get_Array_Base (Res), Res_Type, - New_Lit (Ghdl_Index_0)); - Res_Type := Get_Element_Subtype (Res_Type); - when Type_Mode_Record => - declare - Element : Iir; - begin - Element := Get_First_Element - (Get_Elements_Declaration_List - (Get_Base_Type (Res_Type))); - Res := Chap6.Translate_Selected_Element (Res, Element); - Res_Type := Get_Type (Element); - end; - when Type_Mode_Unknown - | Type_Mode_File - | Type_Mode_Acc - | Type_Mode_Fat_Acc - | Type_Mode_Protected => - raise Internal_Error; - end case; - end loop; - end Get_Leftest_Signal; - - -- Add func and instance. - procedure Add_Associations_For_Resolver - (Assoc : in out O_Assoc_List; Func_Decl : Iir) - is - Func_Info : constant Subprg_Info_Acc := Get_Info (Func_Decl); - Resolv_Info : constant Subprg_Resolv_Info_Acc := - Func_Info.Subprg_Resolv; - Val : O_Enode; - begin - New_Association - (Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func, - Ghdl_Ptr_Type))); - if Subprgs.Has_Subprg_Instance (Resolv_Info.Var_Instance) then - Val := New_Convert_Ov - (Subprgs.Get_Subprg_Instance (Resolv_Info.Var_Instance), - Ghdl_Ptr_Type); - else - Val := New_Lit (New_Null_Access (Ghdl_Ptr_Type)); - end if; - New_Association (Assoc, Val); - end Add_Associations_For_Resolver; - - type O_If_Block_Acc is access O_If_Block; - - type Elab_Signal_Data is record - -- Default value of the signal. - Val : Mnode; - -- If statement for a block of signals. - If_Stmt : O_If_Block_Acc; - -- True if the default value is set. - Has_Val : Boolean; - -- True if a resolution function was already attached. - Already_Resolved : Boolean; - -- True if the signal may already have been created. - Check_Null : Boolean; - end record; - - procedure Elab_Signal_Non_Composite (Targ : Mnode; - Targ_Type : Iir; - Data : Elab_Signal_Data) - is - Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type); - Create_Subprg : O_Dnode; - Conv : O_Tnode; - Res : O_Enode; - Assoc : O_Assoc_List; - Init_Val : O_Enode; - -- For the resolution function (if any). - Func : Iir; - If_Stmt : O_If_Block; - Targ_Ptr : O_Dnode; - begin - if Data.Check_Null then - Targ_Ptr := Create_Temp_Init - (Ghdl_Signal_Ptr_Ptr, - New_Unchecked_Address (M2Lv (Targ), Ghdl_Signal_Ptr_Ptr)); - Start_If_Stmt - (If_Stmt, - New_Compare_Op (ON_Eq, - New_Value (New_Acc_Value (New_Obj (Targ_Ptr))), - New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), - Ghdl_Bool_Type)); - end if; - - case Type_Info.Type_Mode is - when Type_Mode_B1 => - Create_Subprg := Ghdl_Create_Signal_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Create_Subprg := Ghdl_Create_Signal_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Create_Subprg := Ghdl_Create_Signal_E32; - Conv := Ghdl_I32_Type; - when Type_Mode_I32 - | Type_Mode_P32 => - Create_Subprg := Ghdl_Create_Signal_I32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 - | Type_Mode_I64 => - Create_Subprg := Ghdl_Create_Signal_I64; - Conv := Ghdl_I64_Type; - when Type_Mode_F64 => - Create_Subprg := Ghdl_Create_Signal_F64; - Conv := Ghdl_Real_Type; - when others => - Error_Kind ("elab_signal_non_composite", Targ_Type); - end case; - - if Data.Has_Val then - Init_Val := M2E (Data.Val); - else - Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); - end if; - - Start_Association (Assoc, Create_Subprg); - New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); - - if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then - Func := Has_Resolution_Function (Targ_Type); - else - Func := Null_Iir; - end if; - if Func /= Null_Iir and then not Data.Already_Resolved then - Add_Associations_For_Resolver (Assoc, Func); - else - New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); - New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); - end if; - - Res := New_Function_Call (Assoc); - - if Data.Check_Null then - New_Assign_Stmt (New_Acc_Value (New_Obj (Targ_Ptr)), Res); - Finish_If_Stmt (If_Stmt); - else - New_Assign_Stmt - (M2Lv (Targ), - New_Convert_Ov (Res, Type_Info.Ortho_Type (Mode_Signal))); - end if; - end Elab_Signal_Non_Composite; - - function Elab_Signal_Prepare_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Elab_Signal_Data) - return Elab_Signal_Data - is - Assoc : O_Assoc_List; - Func : Iir; - Res : Elab_Signal_Data; - begin - Res := Data; - if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then - Func := Has_Resolution_Function (Targ_Type); - if Func /= Null_Iir and then not Data.Already_Resolved then - if Data.Check_Null then - Res.If_Stmt := new O_If_Block; - Start_If_Stmt - (Res.If_Stmt.all, - New_Compare_Op - (ON_Eq, - New_Convert_Ov (M2E (Get_Leftest_Signal (Targ, - Targ_Type)), - Ghdl_Signal_Ptr), - New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), - Ghdl_Bool_Type)); - --Res.Check_Null := False; - end if; - -- Add resolver. - Start_Association (Assoc, Ghdl_Signal_Create_Resolution); - Add_Associations_For_Resolver (Assoc, Func); - New_Association - (Assoc, New_Convert_Ov (M2Addr (Targ), Ghdl_Ptr_Type)); - New_Association (Assoc, Get_Nbr_Signals (Targ, Targ_Type)); - New_Procedure_Call (Assoc); - Res.Already_Resolved := True; - end if; - end if; - if Data.Has_Val then - if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then - Res.Val := Stabilize (Data.Val); - else - Res.Val := Chap3.Get_Array_Base (Data.Val); - end if; - end if; - return Res; - end Elab_Signal_Prepare_Composite; - - procedure Elab_Signal_Finish_Composite (Data : in out Elab_Signal_Data) - is - procedure Free is new Ada.Unchecked_Deallocation - (Object => O_If_Block, Name => O_If_Block_Acc); - begin - if Data.If_Stmt /= null then - Finish_If_Stmt (Data.If_Stmt.all); - Free (Data.If_Stmt); - end if; - end Elab_Signal_Finish_Composite; - - function Elab_Signal_Update_Array (Data : Elab_Signal_Data; - Targ_Type : Iir; - Index : O_Dnode) - return Elab_Signal_Data - is - begin - if not Data.Has_Val then - return Data; - else - return Elab_Signal_Data' - (Val => Chap3.Index_Base (Data.Val, Targ_Type, - New_Obj_Value (Index)), - Has_Val => True, - If_Stmt => null, - Already_Resolved => Data.Already_Resolved, - Check_Null => Data.Check_Null); - end if; - end Elab_Signal_Update_Array; - - function Elab_Signal_Update_Record (Data : Elab_Signal_Data; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Elab_Signal_Data - is - pragma Unreferenced (Targ_Type); - begin - if not Data.Has_Val then - return Data; - else - return Elab_Signal_Data' - (Val => Chap6.Translate_Selected_Element (Data.Val, El), - Has_Val => True, - If_Stmt => null, - Already_Resolved => Data.Already_Resolved, - Check_Null => Data.Check_Null); - end if; - end Elab_Signal_Update_Record; - - procedure Elab_Signal is new Foreach_Non_Composite - (Data_Type => Elab_Signal_Data, - Composite_Data_Type => Elab_Signal_Data, - Do_Non_Composite => Elab_Signal_Non_Composite, - Prepare_Data_Array => Elab_Signal_Prepare_Composite, - Update_Data_Array => Elab_Signal_Update_Array, - Finish_Data_Array => Elab_Signal_Finish_Composite, - Prepare_Data_Record => Elab_Signal_Prepare_Composite, - Update_Data_Record => Elab_Signal_Update_Record, - Finish_Data_Record => Elab_Signal_Finish_Composite); - - -- Elaborate signal subtypes and allocate the storage for the object. - procedure Elab_Signal_Declaration_Storage (Decl : Iir) - is - Sig_Type : Iir; - Type_Info : Type_Info_Acc; - Name_Node : Mnode; - begin - New_Debug_Line_Stmt (Get_Line_Number (Decl)); - - Open_Temp; - - Sig_Type := Get_Type (Decl); - Chap3.Elab_Object_Subtype (Sig_Type); - Type_Info := Get_Info (Sig_Type); - - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - Name_Node := Chap6.Translate_Name (Decl); - Name_Node := Stabilize (Name_Node); - Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); - elsif Is_Complex_Type (Type_Info) then - Name_Node := Chap6.Translate_Name (Decl); - Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); - end if; - - Close_Temp; - end Elab_Signal_Declaration_Storage; - - function Has_Direct_Driver (Sig : Iir) return Boolean - is - Info : Ortho_Info_Acc; - begin - Info := Get_Info (Get_Object_Prefix (Sig)); - return Info.Kind = Kind_Object - and then Info.Object_Driver /= Null_Var; - end Has_Direct_Driver; - - procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir) - is - Sig_Type : constant Iir := Get_Type (Decl); - Sig_Info : constant Ortho_Info_Acc := Get_Info (Decl); - Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type); - Name_Node : Mnode; - begin - Open_Temp; - - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - Name_Node := Get_Var (Sig_Info.Object_Driver, - Type_Info, Mode_Value); - Name_Node := Stabilize (Name_Node); - -- Copy bounds from signal. - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), - M2Addr (Chap3.Get_Array_Bounds (Chap6.Translate_Name (Decl)))); - -- Allocate base. - Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); - elsif Is_Complex_Type (Type_Info) then - Name_Node := Get_Var (Sig_Info.Object_Driver, - Type_Info, Mode_Value); - Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); - end if; - - Close_Temp; - end Elab_Direct_Driver_Declaration_Storage; - - -- Create signal object. - -- Note: SIG can be a signal sub-element (used when signals are - -- collapsed). - -- If CHECK_NULL is TRUE, create the signal only if it was not yet - -- created. - procedure Elab_Signal_Declaration_Object - (Sig : Iir; Parent : Iir; Check_Null : Boolean) - is - Decl : constant Iir := Strip_Denoting_Name (Sig); - Sig_Type : constant Iir := Get_Type (Sig); - Base_Decl : constant Iir := Get_Object_Prefix (Sig); - Name_Node : Mnode; - Val : Iir; - Data : Elab_Signal_Data; - begin - New_Debug_Line_Stmt (Get_Line_Number (Sig)); - - Open_Temp; - - -- Set the name of the signal. - declare - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Ghdl_Signal_Name_Rti); - New_Association - (Assoc, - New_Lit (New_Global_Unchecked_Address - (Get_Info (Base_Decl).Object_Rti, - Rtis.Ghdl_Rti_Access))); - Rtis.Associate_Rti_Context (Assoc, Parent); - New_Procedure_Call (Assoc); - end; - - Name_Node := Chap6.Translate_Name (Decl); - if Get_Object_Kind (Name_Node) /= Mode_Signal then - raise Internal_Error; - end if; - - if Decl = Base_Decl then - Data.Already_Resolved := False; - Data.Check_Null := Check_Null; - Val := Get_Default_Value (Base_Decl); - if Val = Null_Iir then - Data.Has_Val := False; - else - Data.Has_Val := True; - Data.Val := E2M (Chap7.Translate_Expression (Val, Sig_Type), - Get_Info (Sig_Type), - Mode_Value); - end if; - else - -- Sub signal. - -- Do not add resolver. - -- Do not use default value. - Data.Already_Resolved := True; - Data.Has_Val := False; - Data.Check_Null := False; - end if; - Elab_Signal (Name_Node, Sig_Type, Data); - - Close_Temp; - end Elab_Signal_Declaration_Object; - - procedure Elab_Signal_Declaration - (Decl : Iir; Parent : Iir; Check_Null : Boolean) - is - begin - Elab_Signal_Declaration_Storage (Decl); - Elab_Signal_Declaration_Object (Decl, Parent, Check_Null); - end Elab_Signal_Declaration; - - procedure Elab_Signal_Attribute (Decl : Iir) - is - Assoc : O_Assoc_List; - Dtype : Iir; - Type_Info : Type_Info_Acc; - Info : Object_Info_Acc; - Prefix : Iir; - Prefix_Node : Mnode; - Res : O_Enode; - Val : O_Enode; - Param : Iir; - Subprg : O_Dnode; - begin - New_Debug_Line_Stmt (Get_Line_Number (Decl)); - - Info := Get_Info (Decl); - Dtype := Get_Type (Decl); - Type_Info := Get_Info (Dtype); - -- Create the signal (with the time) - case Get_Kind (Decl) is - when Iir_Kind_Stable_Attribute => - Subprg := Ghdl_Create_Stable_Signal; - when Iir_Kind_Quiet_Attribute => - Subprg := Ghdl_Create_Quiet_Signal; - when Iir_Kind_Transaction_Attribute => - Subprg := Ghdl_Create_Transaction_Signal; - when others => - Error_Kind ("elab_signal_attribute", Decl); - end case; - Start_Association (Assoc, Subprg); - case Get_Kind (Decl) is - when Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute => - Param := Get_Parameter (Decl); - if Param = Null_Iir then - Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); - else - Val := Chap7.Translate_Expression (Param); - end if; - New_Association (Assoc, Val); - when others => - null; - end case; - Res := New_Convert_Ov (New_Function_Call (Assoc), - Type_Info.Ortho_Type (Mode_Signal)); - New_Assign_Stmt (Get_Var (Info.Object_Var), Res); - - -- Register all signals this depends on. - Prefix := Get_Prefix (Decl); - Prefix_Node := Chap6.Translate_Name (Prefix); - Register_Signal (Prefix_Node, Get_Type (Prefix), - Ghdl_Signal_Attribute_Register_Prefix); - end Elab_Signal_Attribute; - - type Delayed_Signal_Data is record - Pfx : Mnode; - Param : Iir; - end record; - - procedure Create_Delayed_Signal_Noncomposite - (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) - is - pragma Unreferenced (Targ_Type); - Assoc : O_Assoc_List; - Type_Info : Type_Info_Acc; - Val : O_Enode; - begin - Start_Association (Assoc, Ghdl_Create_Delayed_Signal); - New_Association - (Assoc, - New_Convert_Ov (New_Value (M2Lv (Data.Pfx)), Ghdl_Signal_Ptr)); - if Data.Param = Null_Iir then - Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); - else - Val := Chap7.Translate_Expression (Data.Param); - end if; - New_Association (Assoc, Val); - Type_Info := Get_Type_Info (Targ); - New_Assign_Stmt - (M2Lv (Targ), - New_Convert_Ov (New_Function_Call (Assoc), - Type_Info.Ortho_Type (Mode_Signal))); - end Create_Delayed_Signal_Noncomposite; - - function Create_Delayed_Signal_Prepare_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) - return Delayed_Signal_Data - is - pragma Unreferenced (Targ_Type); - Res : Delayed_Signal_Data; - begin - Res.Param := Data.Param; - if Get_Type_Info (Targ).Type_Mode = Type_Mode_Record then - Res.Pfx := Stabilize (Data.Pfx); - else - Res.Pfx := Chap3.Get_Array_Base (Data.Pfx); - end if; - return Res; - end Create_Delayed_Signal_Prepare_Composite; - - function Create_Delayed_Signal_Update_Data_Array - (Data : Delayed_Signal_Data; Targ_Type : Iir; Index : O_Dnode) - return Delayed_Signal_Data - is - begin - return Delayed_Signal_Data' - (Pfx => Chap3.Index_Base (Data.Pfx, Targ_Type, - New_Obj_Value (Index)), - Param => Data.Param); - end Create_Delayed_Signal_Update_Data_Array; - - function Create_Delayed_Signal_Update_Data_Record - (Data : Delayed_Signal_Data; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Delayed_Signal_Data - is - pragma Unreferenced (Targ_Type); - begin - return Delayed_Signal_Data' - (Pfx => Chap6.Translate_Selected_Element (Data.Pfx, El), - Param => Data.Param); - end Create_Delayed_Signal_Update_Data_Record; - - procedure Create_Delayed_Signal_Finish_Data_Composite - (Data : in out Delayed_Signal_Data) - is - pragma Unreferenced (Data); - begin - null; - end Create_Delayed_Signal_Finish_Data_Composite; - - procedure Create_Delayed_Signal is new Foreach_Non_Composite - (Data_Type => Delayed_Signal_Data, - Composite_Data_Type => Delayed_Signal_Data, - Do_Non_Composite => Create_Delayed_Signal_Noncomposite, - Prepare_Data_Array => Create_Delayed_Signal_Prepare_Composite, - Update_Data_Array => Create_Delayed_Signal_Update_Data_Array, - Finish_Data_Array => Create_Delayed_Signal_Finish_Data_Composite, - Prepare_Data_Record => Create_Delayed_Signal_Prepare_Composite, - Update_Data_Record => Create_Delayed_Signal_Update_Data_Record, - Finish_Data_Record => Create_Delayed_Signal_Finish_Data_Composite); - - procedure Elab_Signal_Delayed_Attribute (Decl : Iir) - is - Name_Node : Mnode; - Sig_Type : Iir; - Type_Info : Type_Info_Acc; - Pfx_Node : Mnode; - Data: Delayed_Signal_Data; - begin - Name_Node := Chap6.Translate_Name (Decl); - Sig_Type := Get_Type (Decl); - Type_Info := Get_Info (Sig_Type); - - if Is_Complex_Type (Type_Info) then - Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); - -- We cannot stabilize NAME_NODE, since Allocate_Complex_Object - -- assign it. - Name_Node := Chap6.Translate_Name (Decl); - end if; - - Pfx_Node := Chap6.Translate_Name (Get_Prefix (Decl)); - Data := Delayed_Signal_Data'(Pfx => Pfx_Node, - Param => Get_Parameter (Decl)); - - Create_Delayed_Signal (Name_Node, Get_Type (Decl), Data); - end Elab_Signal_Delayed_Attribute; - - procedure Elab_File_Declaration (Decl : Iir_File_Declaration) - is - Constr : O_Assoc_List; - Name : Mnode; - File_Name : Iir; - Open_Kind : Iir; - Mode_Val : O_Enode; - Str : O_Enode; - Is_Text : Boolean; - Info : Type_Info_Acc; - begin - -- Elaborate the file. - Name := Chap6.Translate_Name (Decl); - if Get_Object_Kind (Name) /= Mode_Value then - raise Internal_Error; - end if; - Is_Text := Get_Text_File_Flag (Get_Type (Decl)); - if Is_Text then - Start_Association (Constr, Ghdl_Text_File_Elaborate); - else - Start_Association (Constr, Ghdl_File_Elaborate); - Info := Get_Info (Get_Type (Decl)); - if Info.T.File_Signature /= O_Dnode_Null then - New_Association - (Constr, New_Address (New_Obj (Info.T.File_Signature), - Char_Ptr_Type)); - else - New_Association (Constr, - New_Lit (New_Null_Access (Char_Ptr_Type))); - end if; - end if; - New_Assign_Stmt (M2Lv (Name), New_Function_Call (Constr)); - - -- If file_open_information is present, open the file. - File_Name := Get_File_Logical_Name (Decl); - if File_Name = Null_Iir then - return; - end if; - Open_Temp; - Name := Chap6.Translate_Name (Decl); - Open_Kind := Get_File_Open_Kind (Decl); - if Open_Kind /= Null_Iir then - Mode_Val := New_Convert_Ov - (Chap7.Translate_Expression (Open_Kind), Ghdl_I32_Type); - else - case Get_Mode (Decl) is - when Iir_In_Mode => - Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0)); - when Iir_Out_Mode => - Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1)); - when others => - raise Internal_Error; - end case; - end if; - Str := Chap7.Translate_Expression (File_Name, String_Type_Definition); - - if Is_Text then - Start_Association (Constr, Ghdl_Text_File_Open); - else - Start_Association (Constr, Ghdl_File_Open); - end if; - New_Association (Constr, M2E (Name)); - New_Association (Constr, Mode_Val); - New_Association (Constr, Str); - New_Procedure_Call (Constr); - Close_Temp; - end Elab_File_Declaration; - - procedure Final_File_Declaration (Decl : Iir_File_Declaration) - is - Constr : O_Assoc_List; - Name : Mnode; - Is_Text : Boolean; - begin - Is_Text := Get_Text_File_Flag (Get_Type (Decl)); - - Open_Temp; - Name := Chap6.Translate_Name (Decl); - Stabilize (Name); - - -- LRM 3.4.1 File Operations - -- An implicit call to FILE_CLOSE exists in a subprogram body for - -- every file object declared in the corresponding subprogram - -- declarative part. Each such call associates a unique file object - -- with the formal parameter F and is called whenever the - -- corresponding subprogram completes its execution. - if Is_Text then - Start_Association (Constr, Ghdl_Text_File_Close); - else - Start_Association (Constr, Ghdl_File_Close); - end if; - New_Association (Constr, M2E (Name)); - New_Procedure_Call (Constr); - - if Is_Text then - Start_Association (Constr, Ghdl_Text_File_Finalize); - else - Start_Association (Constr, Ghdl_File_Finalize); - end if; - New_Association (Constr, M2E (Name)); - New_Procedure_Call (Constr); - - Close_Temp; - end Final_File_Declaration; - - procedure Translate_Type_Declaration (Decl : Iir) - is - begin - Chap3.Translate_Named_Type_Definition (Get_Type_Definition (Decl), - Get_Identifier (Decl)); - end Translate_Type_Declaration; - - procedure Translate_Anonymous_Type_Declaration (Decl : Iir) - is - Mark : Id_Mark_Type; - Mark1 : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Push_Identifier_Prefix (Mark1, "BT"); - Chap3.Translate_Type_Definition (Get_Type_Definition (Decl)); - Pop_Identifier_Prefix (Mark1); - Pop_Identifier_Prefix (Mark); - end Translate_Anonymous_Type_Declaration; - - procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration) - is - begin - Chap3.Translate_Named_Type_Definition (Get_Type (Decl), - Get_Identifier (Decl)); - end Translate_Subtype_Declaration; - - procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration) - is - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Chap3.Translate_Bool_Type_Definition (Get_Type_Definition (Decl)); - Pop_Identifier_Prefix (Mark); - end Translate_Bool_Type_Declaration; - - procedure Translate_Object_Alias_Declaration - (Decl : Iir_Object_Alias_Declaration) - is - Decl_Type : Iir; - Info : Alias_Info_Acc; - Tinfo : Type_Info_Acc; - Atype : O_Tnode; - begin - Decl_Type := Get_Type (Decl); - - Chap3.Translate_Named_Type_Definition - (Decl_Type, Get_Identifier (Decl)); - - Info := Add_Info (Decl, Kind_Alias); - case Get_Kind (Get_Object_Prefix (Decl)) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration => - Info.Alias_Kind := Mode_Signal; - when others => - Info.Alias_Kind := Mode_Value; - end case; - - Tinfo := Get_Info (Decl_Type); - case Tinfo.Type_Mode is - when Type_Mode_Fat_Array => - -- create an object. - -- At elaboration: copy base from name, copy bounds from type, - -- check for matching bounds. - Atype := Get_Ortho_Type (Decl_Type, Info.Alias_Kind); - when Type_Mode_Array - | Type_Mode_Acc - | Type_Mode_Fat_Acc => - -- Create an object pointer. - -- At elaboration: copy base from name. - Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); - when Type_Mode_Scalar => - case Info.Alias_Kind is - when Mode_Signal => - Atype := Tinfo.Ortho_Type (Mode_Signal); - when Mode_Value => - Atype := Tinfo.Ortho_Ptr_Type (Mode_Value); - end case; - when Type_Mode_Record => - -- Create an object pointer. - -- At elaboration: copy base from name. - Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); - when others => - raise Internal_Error; - end case; - Info.Alias_Var := Create_Var (Create_Var_Identifier (Decl), Atype); - end Translate_Object_Alias_Declaration; - - procedure Elab_Object_Alias_Declaration - (Decl : Iir_Object_Alias_Declaration) - is - Decl_Type : Iir; - Name : Iir; - Name_Node : Mnode; - Alias_Node : Mnode; - Alias_Info : Alias_Info_Acc; - Name_Type : Iir; - Tinfo : Type_Info_Acc; - Kind : Object_Kind_Type; - begin - New_Debug_Line_Stmt (Get_Line_Number (Decl)); - - Decl_Type := Get_Type (Decl); - Tinfo := Get_Info (Decl_Type); - - Alias_Info := Get_Info (Decl); - Chap3.Elab_Object_Subtype (Decl_Type); - Name := Get_Name (Decl); - Name_Type := Get_Type (Name); - Name_Node := Chap6.Translate_Name (Name); - Kind := Get_Object_Kind (Name_Node); - - case Tinfo.Type_Mode is - when Type_Mode_Fat_Array => - Open_Temp; - Stabilize (Name_Node); - Alias_Node := Stabilize - (Get_Var (Alias_Info.Alias_Var, - Tinfo, Alias_Info.Alias_Kind)); - Copy_Fat_Pointer (Alias_Node, Name_Node); - Close_Temp; - when Type_Mode_Array => - Open_Temp; - Stabilize (Name_Node); - New_Assign_Stmt - (Get_Var (Alias_Info.Alias_Var), - M2E (Chap3.Get_Array_Base (Name_Node))); - Chap3.Check_Array_Match (Decl_Type, T2M (Decl_Type, Kind), - Name_Type, Name_Node, - Decl); - Close_Temp; - when Type_Mode_Acc - | Type_Mode_Fat_Acc => - New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), - M2Addr (Name_Node)); - when Type_Mode_Scalar => - case Alias_Info.Alias_Kind is - when Mode_Value => - New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), - M2Addr (Name_Node)); - when Mode_Signal => - New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), - M2E (Name_Node)); - end case; - when Type_Mode_Record => - Open_Temp; - Stabilize (Name_Node); - New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), - M2Addr (Name_Node)); - Close_Temp; - when others => - raise Internal_Error; - end case; - end Elab_Object_Alias_Declaration; - - procedure Translate_Port_Chain (Parent : Iir) - is - Port : Iir; - begin - Port := Get_Port_Chain (Parent); - while Port /= Null_Iir loop - Create_Signal (Port); - Port := Get_Chain (Port); - end loop; - end Translate_Port_Chain; - - procedure Translate_Generic_Chain (Parent : Iir) - is - Decl : Iir; - begin - Decl := Get_Generic_Chain (Parent); - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kinds_Interface_Object_Declaration => - Create_Object (Decl); - when Iir_Kind_Interface_Package_Declaration => - Create_Package_Interface (Decl); - when others => - Error_Kind ("translate_generic_chain", Decl); - end case; - Decl := Get_Chain (Decl); - end loop; - end Translate_Generic_Chain; - - -- Create instance record for a component. - procedure Translate_Component_Declaration (Decl : Iir) - is - Mark : Id_Mark_Type; - Info : Ortho_Info_Acc; - begin - Info := Add_Info (Decl, Kind_Component); - Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Push_Instance_Factory (Info.Comp_Scope'Access); - - Info.Comp_Link := Add_Instance_Factory_Field - (Wki_Instance, Rtis.Ghdl_Component_Link_Type); - - -- Generic and ports. - Translate_Generic_Chain (Decl); - Translate_Port_Chain (Decl); - - Pop_Instance_Factory (Info.Comp_Scope'Access); - New_Type_Decl (Create_Identifier ("_COMPTYPE"), - Get_Scope_Type (Info.Comp_Scope)); - Info.Comp_Ptr_Type := New_Access_Type - (Get_Scope_Type (Info.Comp_Scope)); - New_Type_Decl (Create_Identifier ("_COMPPTR"), Info.Comp_Ptr_Type); - Pop_Identifier_Prefix (Mark); - end Translate_Component_Declaration; - - procedure Translate_Declaration (Decl : Iir) - is - begin - case Get_Kind (Decl) is - when Iir_Kind_Use_Clause => - null; - when Iir_Kind_Configuration_Specification => - null; - when Iir_Kind_Disconnection_Specification => - null; - - when Iir_Kind_Component_Declaration => - Chap4.Translate_Component_Declaration (Decl); - when Iir_Kind_Type_Declaration => - Chap4.Translate_Type_Declaration (Decl); - when Iir_Kind_Anonymous_Type_Declaration => - Chap4.Translate_Anonymous_Type_Declaration (Decl); - when Iir_Kind_Subtype_Declaration => - Chap4.Translate_Subtype_Declaration (Decl); - - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - raise Internal_Error; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - null; - - when Iir_Kind_Protected_Type_Body => - null; - - --when Iir_Kind_Implicit_Function_Declaration => - --when Iir_Kind_Signal_Declaration - -- | Iir_Kind_Interface_Signal_Declaration => - -- Chap4.Create_Object (Decl); - - when Iir_Kind_Variable_Declaration - | Iir_Kind_Constant_Declaration => - Create_Object (Decl); - - when Iir_Kind_Signal_Declaration => - Create_Signal (Decl); - - when Iir_Kind_Object_Alias_Declaration => - Translate_Object_Alias_Declaration (Decl); - - when Iir_Kind_Non_Object_Alias_Declaration => - null; - - when Iir_Kind_File_Declaration => - Create_File_Object (Decl); - - when Iir_Kind_Attribute_Declaration => - -- Useless as attribute declarations have a type mark. - Chap3.Translate_Object_Subtype (Decl); - - when Iir_Kind_Attribute_Specification => - Chap5.Translate_Attribute_Specification (Decl); - - when Iir_Kinds_Signal_Attribute => - Chap4.Create_Implicit_Signal (Decl); - - when Iir_Kind_Guard_Signal_Declaration => - Create_Signal (Decl); - - when Iir_Kind_Group_Template_Declaration => - null; - when Iir_Kind_Group_Declaration => - null; - - when others => - Error_Kind ("translate_declaration", Decl); - end case; - end Translate_Declaration; - - procedure Translate_Resolution_Function (Func : Iir) - is - -- Type of the resolution function parameter. - El_Type : Iir; - El_Info : Type_Info_Acc; - Finfo : constant Subprg_Info_Acc := Get_Info (Func); - Interface_List : O_Inter_List; - Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; - Id : O_Ident; - Itype : O_Tnode; - Unused_Instance : O_Dnode; - begin - if Rinfo = null then - -- Not a resolution function - return; - end if; - - -- Declare the procedure. - Id := Create_Identifier (Func, Get_Overload_Number (Func), "_RESOLV"); - Start_Procedure_Decl (Interface_List, Id, Global_Storage); - - -- The instance. - if Subprgs.Has_Current_Subprg_Instance then - Subprgs.Add_Subprg_Instance_Interfaces (Interface_List, - Rinfo.Var_Instance); - else - -- Create a dummy instance parameter - New_Interface_Decl (Interface_List, Unused_Instance, - Wki_Instance, Ghdl_Ptr_Type); - Rinfo.Var_Instance := Subprgs.Null_Subprg_Instance; - end if; - - -- The signal. - El_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); - El_Type := Get_Element_Subtype (El_Type); - El_Info := Get_Info (El_Type); - -- FIXME: create a function for getting the type of an interface. - case El_Info.Type_Mode is - when Type_Mode_Thin => - Itype := El_Info.Ortho_Type (Mode_Signal); - when Type_Mode_Fat => - Itype := El_Info.Ortho_Ptr_Type (Mode_Signal); - when Type_Mode_Unknown => - raise Internal_Error; - end case; - New_Interface_Decl - (Interface_List, Rinfo.Var_Vals, Get_Identifier ("VALS"), Itype); - - New_Interface_Decl - (Interface_List, Rinfo.Var_Vec, Get_Identifier ("bool_vec"), - Ghdl_Bool_Array_Ptr); - New_Interface_Decl - (Interface_List, Rinfo.Var_Vlen, Get_Identifier ("vec_len"), - Ghdl_Index_Type); - New_Interface_Decl - (Interface_List, Rinfo.Var_Nbr_Drv, Get_Identifier ("nbr_drv"), - Ghdl_Index_Type); - New_Interface_Decl - (Interface_List, Rinfo.Var_Nbr_Ports, Get_Identifier ("nbr_ports"), - Ghdl_Index_Type); - - Finish_Subprogram_Decl (Interface_List, Rinfo.Resolv_Func); - end Translate_Resolution_Function; - - type Read_Source_Kind is (Read_Port, Read_Driver); - type Read_Source_Data is record - Sig : Mnode; - Drv_Index : O_Dnode; - Kind : Read_Source_Kind; - end record; - - procedure Read_Source_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) - is - Assoc : O_Assoc_List; - Targ_Info : Type_Info_Acc; - E : O_Enode; - begin - Targ_Info := Get_Info (Targ_Type); - case Data.Kind is - when Read_Port => - Start_Association (Assoc, Ghdl_Signal_Read_Port); - when Read_Driver => - Start_Association (Assoc, Ghdl_Signal_Read_Driver); - end case; - - New_Association - (Assoc, New_Convert_Ov (M2E (Data.Sig), Ghdl_Signal_Ptr)); - New_Association (Assoc, New_Obj_Value (Data.Drv_Index)); - E := New_Convert_Ov (New_Function_Call (Assoc), - Targ_Info.Ortho_Ptr_Type (Mode_Value)); - New_Assign_Stmt (M2Lv (Targ), - New_Value (New_Access_Element (E))); - end Read_Source_Non_Composite; - - function Read_Source_Prepare_Data_Array - (Targ: Mnode; Targ_Type : Iir; Data : Read_Source_Data) - return Read_Source_Data - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Data; - end Read_Source_Prepare_Data_Array; - - function Read_Source_Prepare_Data_Record - (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) - return Read_Source_Data - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Read_Source_Data'(Sig => Stabilize (Data.Sig), - Drv_Index => Data.Drv_Index, - Kind => Data.Kind); - end Read_Source_Prepare_Data_Record; - - function Read_Source_Update_Data_Array - (Data : Read_Source_Data; Targ_Type : Iir; Index : O_Dnode) - return Read_Source_Data - is - begin - return Read_Source_Data' - (Sig => Chap3.Index_Base (Data.Sig, Targ_Type, - New_Obj_Value (Index)), - Drv_Index => Data.Drv_Index, - Kind => Data.Kind); - end Read_Source_Update_Data_Array; - - function Read_Source_Update_Data_Record - (Data : Read_Source_Data; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Read_Source_Data - is - pragma Unreferenced (Targ_Type); - begin - return Read_Source_Data' - (Sig => Chap6.Translate_Selected_Element (Data.Sig, El), - Drv_Index => Data.Drv_Index, - Kind => Data.Kind); - end Read_Source_Update_Data_Record; - - procedure Read_Source_Finish_Data_Composite - (Data : in out Read_Source_Data) - is - pragma Unreferenced (Data); - begin - null; - end Read_Source_Finish_Data_Composite; - - procedure Read_Signal_Source is new Foreach_Non_Composite - (Data_Type => Read_Source_Data, - Composite_Data_Type => Read_Source_Data, - Do_Non_Composite => Read_Source_Non_Composite, - Prepare_Data_Array => Read_Source_Prepare_Data_Array, - Update_Data_Array => Read_Source_Update_Data_Array, - Finish_Data_Array => Read_Source_Finish_Data_Composite, - Prepare_Data_Record => Read_Source_Prepare_Data_Record, - Update_Data_Record => Read_Source_Update_Data_Record, - Finish_Data_Record => Read_Source_Finish_Data_Composite); - - procedure Translate_Resolution_Function_Body (Func : Iir) - is - -- Type of the resolution function parameter. - Arr_Type : Iir; - Base_Type : Iir; - Base_Info : Type_Info_Acc; - Index_Info : Index_Info_Acc; - - -- Type of parameter element. - El_Type : Iir; - El_Info : Type_Info_Acc; - - -- Type of the function return value. - Ret_Type : Iir; - Ret_Info : Type_Info_Acc; - - -- Type and info of the array index. - Index_Type : Iir; - Index_Tinfo : Type_Info_Acc; - - -- Local variables. - Var_I : O_Dnode; - Var_J : O_Dnode; - Var_Length : O_Dnode; - Var_Res : O_Dnode; - - Vals : Mnode; - Res : Mnode; - - If_Blk : O_If_Block; - Label : O_Snode; - - V : Mnode; - - Var_Bound : O_Dnode; - Var_Range_Ptr : O_Dnode; - Var_Array : O_Dnode; - Finfo : constant Subprg_Info_Acc := Get_Info (Func); - Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; - Assoc : O_Assoc_List; - - Data : Read_Source_Data; - begin - if Rinfo = null then - -- No resolver for this function - return; - end if; - - Ret_Type := Get_Return_Type (Func); - Ret_Info := Get_Info (Ret_Type); - - Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); - Base_Type := Get_Base_Type (Arr_Type); - Index_Info := Get_Info - (Get_First_Element (Get_Index_Subtype_Definition_List (Base_Type))); - Base_Info := Get_Info (Base_Type); - - El_Type := Get_Element_Subtype (Arr_Type); - El_Info := Get_Info (El_Type); - - Index_Type := Get_Index_Type (Arr_Type, 0); - Index_Tinfo := Get_Info (Index_Type); - - Start_Subprogram_Body (Rinfo.Resolv_Func); - if Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then - Subprgs.Start_Subprg_Instance_Use (Rinfo.Var_Instance); - end if; - Push_Local_Factory; - - -- A signal. - - New_Var_Decl - (Var_Res, Get_Identifier ("res"), - O_Storage_Local, Get_Object_Type (Ret_Info, Mode_Value)); - - -- I, J. - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_J, Get_Identifier ("J"), - O_Storage_Local, Ghdl_Index_Type); - - -- Length. - New_Var_Decl - (Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type); - - New_Var_Decl (Var_Bound, Get_Identifier ("BOUND"), O_Storage_Local, - Base_Info.T.Bounds_Type); - New_Var_Decl (Var_Array, Get_Identifier ("ARRAY"), O_Storage_Local, - Base_Info.Ortho_Type (Mode_Value)); - - New_Var_Decl (Var_Range_Ptr, Get_Identifier ("RANGE_PTR"), - O_Storage_Local, Index_Tinfo.T.Range_Ptr_Type); - - Open_Temp; - - case El_Info.Type_Mode is - when Type_Mode_Thin => - Vals := Dv2M (Rinfo.Var_Vals, El_Info, Mode_Signal); - when Type_Mode_Fat => - Vals := Dp2M (Rinfo.Var_Vals, El_Info, Mode_Signal); - when Type_Mode_Unknown => - raise Internal_Error; - end case; - - -- * length := vec_len + nports; - New_Assign_Stmt (New_Obj (Var_Length), - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Rinfo.Var_Vlen), - New_Obj_Value (Rinfo.Var_Nbr_Ports))); - - -- * range_ptr := BOUND.dim_1'address; - New_Assign_Stmt - (New_Obj (Var_Range_Ptr), - New_Address (New_Selected_Element (New_Obj (Var_Bound), - Index_Info.Index_Field), - Index_Tinfo.T.Range_Ptr_Type)); - - -- Create range from length - Chap3.Create_Range_From_Length - (Index_Type, Var_Length, Var_Range_Ptr, Func); - New_Assign_Stmt - (New_Selected_Element (New_Obj (Var_Array), - Base_Info.T.Bounds_Field (Mode_Value)), - New_Address (New_Obj (Var_Bound), Base_Info.T.Bounds_Ptr_Type)); - - -- Allocate the array. - Chap3.Allocate_Fat_Array_Base - (Alloc_Stack, Dv2M (Var_Array, Base_Info, Mode_Value), Base_Type); - - -- Fill the array - -- 1. From ports. - -- * I := 0; - Init_Var (Var_I); - -- * loop - Start_Loop_Stmt (Label); - -- * exit when I = nports; - Gen_Exit_When (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_I), - New_Obj_Value (Rinfo.Var_Nbr_Ports), - Ghdl_Bool_Type)); - -- fill array[i] - V := Chap3.Index_Base - (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), - Base_Type, New_Obj_Value (Var_I)); - Data := Read_Source_Data'(Vals, Var_I, Read_Port); - Read_Signal_Source (V, El_Type, Data); - - -- * I := I + 1; - Inc_Var (Var_I); - -- * end loop; - Finish_Loop_Stmt (Label); - - -- 2. From drivers. - -- * J := 0; - -- * loop - -- * exit when j = var_max; - -- * if vec[j] then - -- - -- * ptr := get_signal_driver (sig, j); - -- * array[i].XXX := *ptr - -- - -- * i := i + 1; - -- * end if; - -- * J := J + 1; - -- * end loop; - Init_Var (Var_J); - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_J), - New_Obj_Value (Rinfo.Var_Nbr_Drv), - Ghdl_Bool_Type)); - Start_If_Stmt - (If_Blk, - New_Value (New_Indexed_Acc_Value (New_Obj (Rinfo.Var_Vec), - New_Obj_Value (Var_J)))); - - V := Chap3.Index_Base - (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), - Base_Type, New_Obj_Value (Var_I)); - Data := Read_Source_Data'(Vals, Var_J, Read_Driver); - Read_Signal_Source (V, El_Type, Data); - - Inc_Var (Var_I); - Finish_If_Stmt (If_Blk); - - Inc_Var (Var_J); - Finish_Loop_Stmt (Label); - - if Finfo.Res_Interface /= O_Dnode_Null then - Res := Lo2M (Var_Res, Ret_Info, Mode_Value); - if Ret_Info.Type_Mode /= Type_Mode_Fat_Array then - Allocate_Complex_Object (Ret_Type, Alloc_Stack, Res); - end if; - end if; - - -- Call the resolution function. - if Finfo.Use_Stack2 then - Create_Temp_Stack2_Mark; - end if; - - Start_Association (Assoc, Finfo.Ortho_Func); - if Finfo.Res_Interface /= O_Dnode_Null then - New_Association (Assoc, M2E (Res)); - end if; - Subprgs.Add_Subprg_Instance_Assoc (Assoc, Finfo.Subprg_Instance); - New_Association - (Assoc, New_Address (New_Obj (Var_Array), - Base_Info.Ortho_Ptr_Type (Mode_Value))); - - if Finfo.Res_Interface = O_Dnode_Null then - Res := E2M (New_Function_Call (Assoc), Ret_Info, Mode_Value); - else - New_Procedure_Call (Assoc); - end if; - - if El_Type /= Ret_Type then - Res := E2M - (Chap7.Translate_Implicit_Conv (M2E (Res), Ret_Type, El_Type, - Mode_Value, Func), - El_Info, Mode_Value); - end if; - Chap7.Set_Driving_Value (Vals, El_Type, Res); - - Close_Temp; - Pop_Local_Factory; - if Subprgs.Has_Subprg_Instance (Rinfo.Var_Instance) then - Subprgs.Finish_Subprg_Instance_Use (Rinfo.Var_Instance); - end if; - Finish_Subprogram_Body; - end Translate_Resolution_Function_Body; - - procedure Translate_Declaration_Chain (Parent : Iir) - is - Info : Subprg_Info_Acc; - El : Iir; - begin - El := Get_Declaration_Chain (Parent); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration => - -- Translate interfaces. - if (not Flag_Discard_Unused or else Get_Use_Flag (El)) - and then not Is_Second_Subprogram_Specification (El) - then - Info := Add_Info (El, Kind_Subprg); - Chap2.Translate_Subprogram_Interfaces (El); - if Get_Kind (El) = Iir_Kind_Function_Declaration then - if Get_Resolution_Function_Flag (El) then - Info.Subprg_Resolv := new Subprg_Resolv_Info; - end if; - end if; - end if; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - null; - when Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration => - null; - when others => - Translate_Declaration (El); - end case; - El := Get_Chain (El); - end loop; - end Translate_Declaration_Chain; - - procedure Translate_Declaration_Chain_Subprograms (Parent : Iir) - is - El : Iir; - Infos : Chap7.Implicit_Subprogram_Infos; - begin - El := Get_Declaration_Chain (Parent); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Procedure_Declaration - | Iir_Kind_Function_Declaration => - -- Translate only if used. - if Get_Info (El) /= null then - Chap2.Translate_Subprogram_Declaration (El); - Translate_Resolution_Function (El); - end if; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - -- Do not translate body if generating only specs (for - -- subprograms in an entity). - if Global_Storage /= O_Storage_External - and then - (not Flag_Discard_Unused - or else - Get_Use_Flag (Get_Subprogram_Specification (El))) - then - Chap2.Translate_Subprogram_Body (El); - Translate_Resolution_Function_Body - (Get_Subprogram_Specification (El)); - end if; - when Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration => - Chap3.Translate_Type_Subprograms (El); - Chap7.Init_Implicit_Subprogram_Infos (Infos); - when Iir_Kind_Protected_Type_Body => - Chap3.Translate_Protected_Type_Body (El); - Chap3.Translate_Protected_Type_Body_Subprograms (El); - when Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration => - if Flag_Discard_Unused_Implicit - and then not Get_Use_Flag (El) - then - case Get_Implicit_Definition (El) is - when Iir_Predefined_Array_Equality - | Iir_Predefined_Array_Greater - | Iir_Predefined_Record_Equality => - -- Used implicitly in case statement or other - -- predefined equality. - Chap7.Translate_Implicit_Subprogram (El, Infos); - when others => - null; - end case; - else - Chap7.Translate_Implicit_Subprogram (El, Infos); - end if; - when others => - null; - end case; - El := Get_Chain (El); - end loop; - end Translate_Declaration_Chain_Subprograms; - - procedure Elab_Declaration_Chain (Parent : Iir; Need_Final : out Boolean) - is - Decl : Iir; - begin - Decl := Get_Declaration_Chain (Parent); - Need_Final := False; - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Use_Clause => - null; - when Iir_Kind_Component_Declaration => - null; - when Iir_Kind_Configuration_Specification => - null; - when Iir_Kind_Disconnection_Specification => - Chap5.Elab_Disconnection_Specification (Decl); - - when Iir_Kind_Type_Declaration - | Iir_Kind_Anonymous_Type_Declaration => - Chap3.Elab_Type_Declaration (Decl); - when Iir_Kind_Subtype_Declaration => - Chap3.Elab_Subtype_Declaration (Decl); - - when Iir_Kind_Protected_Type_Body => - null; - - --when Iir_Kind_Signal_Declaration => - -- Chap1.Elab_Signal (Decl); - when Iir_Kind_Variable_Declaration - | Iir_Kind_Constant_Declaration => - Elab_Object (Decl); - if Get_Kind (Get_Type (Decl)) - = Iir_Kind_Protected_Type_Declaration - then - Need_Final := True; - end if; - - when Iir_Kind_Signal_Declaration => - Elab_Signal_Declaration (Decl, Parent, False); - - when Iir_Kind_Object_Alias_Declaration => - Elab_Object_Alias_Declaration (Decl); - - when Iir_Kind_Non_Object_Alias_Declaration => - null; - - when Iir_Kind_File_Declaration => - Elab_File_Declaration (Decl); - Need_Final := True; - - when Iir_Kind_Attribute_Declaration => - Chap3.Elab_Object_Subtype (Get_Type (Decl)); - - when Iir_Kind_Attribute_Specification => - Chap5.Elab_Attribute_Specification (Decl); - - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Get_Info (Decl) /= null then - Chap2.Elab_Subprogram_Interfaces (Decl); - end if; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - null; - - when Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration => - null; - - when Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Transaction_Attribute => - Elab_Signal_Attribute (Decl); - - when Iir_Kind_Delayed_Attribute => - Elab_Signal_Delayed_Attribute (Decl); - - when Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration => - null; - - when others => - Error_Kind ("elab_declaration_chain", Decl); - end case; - - Decl := Get_Chain (Decl); - end loop; - end Elab_Declaration_Chain; - - procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean) - is - Decl : Iir; - begin - Decl := Get_Declaration_Chain (Parent); - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_File_Declaration => - Final_File_Declaration (Decl); - when Iir_Kind_Variable_Declaration => - if Get_Kind (Get_Type (Decl)) - = Iir_Kind_Protected_Type_Declaration - then - Fini_Protected_Object (Decl); - end if; - if Deallocate then - Fini_Object (Decl); - end if; - when Iir_Kind_Constant_Declaration => - if Deallocate then - Fini_Object (Decl); - end if; - when others => - null; - end case; - - Decl := Get_Chain (Decl); - end loop; - end Final_Declaration_Chain; - - type Conv_Mode is (Conv_Mode_In, Conv_Mode_Out); - - -- Create subprogram for an association conversion. - -- STMT is the statement/block_header containing the association. - -- BLOCK is the architecture/block containing the instance. - -- ASSOC is the association and MODE the conversion to work on. - -- CONV_INFO is the result place holder. - -- BASE_BLOCK is the base architecture/block containing the instance. - -- ENTITY is the entity/component instantiated (null for block_stmt) - procedure Translate_Association_Subprogram - (Stmt : Iir; - Block : Iir; - Assoc : Iir; - Mode : Conv_Mode; - Conv_Info : in out Assoc_Conv_Info; - Base_Block : Iir; - Entity : Iir) - is - Formal : constant Iir := Get_Formal (Assoc); - Actual : constant Iir := Get_Actual (Assoc); - - Mark2, Mark3 : Id_Mark_Type; - Inter_List : O_Inter_List; - In_Type, Out_Type : Iir; - In_Info, Out_Info : Type_Info_Acc; - Itype : O_Tnode; - El_List : O_Element_List; - Block_Info : constant Block_Info_Acc := Get_Info (Base_Block); - Stmt_Info : Block_Info_Acc; - Entity_Info : Ortho_Info_Acc; - Var_Data : O_Dnode; - - -- Variables for body. - E : O_Enode; - V : O_Dnode; - V1 : O_Lnode; - V_Out : Mnode; - R : O_Enode; - Constr : O_Assoc_List; - Subprg_Info : Subprg_Info_Acc; - Res : Mnode; - Imp : Iir; - Func : Iir; - begin - case Mode is - when Conv_Mode_In => - -- IN: from actual to formal. - Push_Identifier_Prefix (Mark2, "CONVIN"); - Out_Type := Get_Type (Formal); - In_Type := Get_Type (Actual); - Imp := Get_In_Conversion (Assoc); - - when Conv_Mode_Out => - -- OUT: from formal to actual. - Push_Identifier_Prefix (Mark2, "CONVOUT"); - In_Type := Get_Type (Formal); - Out_Type := Get_Type (Actual); - Imp := Get_Out_Conversion (Assoc); - - end case; - -- FIXME: individual assoc -> overload. - Push_Identifier_Prefix - (Mark3, Get_Identifier (Get_Association_Interface (Assoc))); - - -- Handle anonymous subtypes. - Chap3.Translate_Anonymous_Type_Definition (Out_Type, False); - Chap3.Translate_Anonymous_Type_Definition (In_Type, False); - Out_Info := Get_Info (Out_Type); - In_Info := Get_Info (In_Type); - - -- Start record containing data for the conversion function. - Start_Record_Type (El_List); - - -- Add instance field. - Conv_Info.Instance_Block := Base_Block; - New_Record_Field - (El_List, Conv_Info.Instance_Field, Wki_Instance, - Block_Info.Block_Decls_Ptr_Type); - - if Entity /= Null_Iir then - Conv_Info.Instantiated_Entity := Entity; - Entity_Info := Get_Info (Entity); - declare - Ptr : O_Tnode; - begin - if Entity_Info.Kind = Kind_Component then - Ptr := Entity_Info.Comp_Ptr_Type; - else - Ptr := Entity_Info.Block_Decls_Ptr_Type; - end if; - New_Record_Field - (El_List, Conv_Info.Instantiated_Field, - Get_Identifier ("instantiated"), Ptr); - end; - else - Conv_Info.Instantiated_Entity := Null_Iir; - Conv_Info.Instantiated_Field := O_Fnode_Null; - end if; - - -- Add input. - case In_Info.Type_Mode is - when Type_Mode_Thin => - Itype := In_Info.Ortho_Type (Mode_Signal); - when Type_Mode_Fat => - Itype := In_Info.Ortho_Ptr_Type (Mode_Signal); - when Type_Mode_Unknown => - raise Internal_Error; - end case; - New_Record_Field - (El_List, Conv_Info.In_Field, Get_Identifier ("val_in"), Itype); - - -- Add output. - New_Record_Field - (El_List, Conv_Info.Out_Field, Get_Identifier ("val_out"), - Get_Object_Type (Out_Info, Mode_Signal)); - Finish_Record_Type (El_List, Conv_Info.Record_Type); - New_Type_Decl (Create_Identifier ("DTYPE"), Conv_Info.Record_Type); - Conv_Info.Record_Ptr_Type := New_Access_Type (Conv_Info.Record_Type); - New_Type_Decl (Create_Identifier ("DPTR"), Conv_Info.Record_Ptr_Type); - - -- Declare the subprogram. - Start_Procedure_Decl - (Inter_List, Create_Identifier, O_Storage_Private); - New_Interface_Decl - (Inter_List, Var_Data, Get_Identifier ("data"), - Conv_Info.Record_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Conv_Info.Subprg); - - Start_Subprogram_Body (Conv_Info.Subprg); - Push_Local_Factory; - Open_Temp; - - -- Add an access to local block. - V := Create_Temp_Init - (Block_Info.Block_Decls_Ptr_Type, - New_Value_Selected_Acc_Value (New_Obj (Var_Data), - Conv_Info.Instance_Field)); - Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope, V); - - -- Add an access to instantiated entity. - -- This may be used to do some type checks. - if Conv_Info.Instantiated_Entity /= Null_Iir then - declare - Ptr_Type : O_Tnode; - begin - if Entity_Info.Kind = Kind_Component then - Ptr_Type := Entity_Info.Comp_Ptr_Type; - else - Ptr_Type := Entity_Info.Block_Decls_Ptr_Type; - end if; - V := Create_Temp_Init - (Ptr_Type, - New_Value_Selected_Acc_Value (New_Obj (Var_Data), - Conv_Info.Instantiated_Field)); - if Entity_Info.Kind = Kind_Component then - Set_Scope_Via_Param_Ptr (Entity_Info.Comp_Scope, V); - else - Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V); - end if; - end; - end if; - - -- Add access to the instantiation-specific data. - -- This is used only for anonymous subtype variables. - -- FIXME: what if STMT is a binding_indication ? - Stmt_Info := Get_Info (Stmt); - if Stmt_Info /= null - and then Has_Scope_Type (Stmt_Info.Block_Scope) - then - Set_Scope_Via_Field (Stmt_Info.Block_Scope, - Stmt_Info.Block_Parent_Field, - Get_Info (Block).Block_Scope'Access); - end if; - - -- Read signal value. - E := New_Value_Selected_Acc_Value (New_Obj (Var_Data), - Conv_Info.In_Field); - case Mode is - when Conv_Mode_In => - R := Chap7.Translate_Signal_Effective_Value (E, In_Type); - when Conv_Mode_Out => - R := Chap7.Translate_Signal_Driving_Value (E, In_Type); - end case; - - case Get_Kind (Imp) is - when Iir_Kind_Function_Call => - Func := Get_Implementation (Imp); - R := Chap7.Translate_Implicit_Conv - (R, In_Type, - Get_Type (Get_Interface_Declaration_Chain (Func)), - Mode_Value, Assoc); - - -- Create result value. - Subprg_Info := Get_Info (Func); - - if Subprg_Info.Use_Stack2 then - Create_Temp_Stack2_Mark; - end if; - - if Subprg_Info.Res_Interface /= O_Dnode_Null then - -- Composite result. - -- If we need to allocate, do it before starting the call! - declare - Res_Type : constant Iir := Get_Return_Type (Func); - Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); - begin - Res := Create_Temp (Res_Info); - if Res_Info.Type_Mode /= Type_Mode_Fat_Array then - Chap4.Allocate_Complex_Object - (Res_Type, Alloc_Stack, Res); - end if; - end; - end if; - - -- Call conversion function. - Start_Association (Constr, Subprg_Info.Ortho_Func); - - if Subprg_Info.Res_Interface /= O_Dnode_Null then - -- Composite result. - New_Association (Constr, M2E (Res)); - end if; - - Subprgs.Add_Subprg_Instance_Assoc - (Constr, Subprg_Info.Subprg_Instance); - - New_Association (Constr, R); - - if Subprg_Info.Res_Interface /= O_Dnode_Null then - -- Composite result. - New_Procedure_Call (Constr); - E := M2E (Res); - else - E := New_Function_Call (Constr); - end if; - Res := E2M - (Chap7.Translate_Implicit_Conv - (E, Get_Return_Type (Func), - Out_Type, Mode_Value, Imp), - Get_Info (Out_Type), Mode_Value); - - when Iir_Kind_Type_Conversion => - declare - Conv_Type : Iir; - begin - Conv_Type := Get_Type (Imp); - E := Chap7.Translate_Type_Conversion - (R, In_Type, Conv_Type, Assoc); - E := Chap7.Translate_Implicit_Conv - (E, Conv_Type, Out_Type, Mode_Value, Imp); - Res := E2M (E, Get_Info (Out_Type), Mode_Value); - end; - - when others => - Error_Kind ("Translate_Association_Subprogram", Imp); - end case; - - -- Assign signals. - V1 := New_Selected_Acc_Value (New_Obj (Var_Data), - Conv_Info.Out_Field); - V_Out := Lo2M (V1, Out_Info, Mode_Signal); - - case Mode is - when Conv_Mode_In => - Chap7.Set_Effective_Value (V_Out, Out_Type, Res); - when Conv_Mode_Out => - Chap7.Set_Driving_Value (V_Out, Out_Type, Res); - end case; - - Close_Temp; - if Stmt_Info /= null - and then Has_Scope_Type (Stmt_Info.Block_Scope) - then - Clear_Scope (Stmt_Info.Block_Scope); - end if; - if Conv_Info.Instantiated_Entity /= Null_Iir then - if Entity_Info.Kind = Kind_Component then - Clear_Scope (Entity_Info.Comp_Scope); - else - Clear_Scope (Entity_Info.Block_Scope); - end if; - end if; - Clear_Scope (Block_Info.Block_Scope); - - Pop_Local_Factory; - Finish_Subprogram_Body; - - Pop_Identifier_Prefix (Mark3); - Pop_Identifier_Prefix (Mark2); - end Translate_Association_Subprogram; - - -- ENTITY is null for block_statement. - procedure Translate_Association_Subprograms - (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir) - is - Assoc : Iir; - Info : Assoc_Info_Acc; - begin - Assoc := Get_Port_Map_Aspect_Chain (Stmt); - while Assoc /= Null_Iir loop - if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression - then - Info := null; - if Get_In_Conversion (Assoc) /= Null_Iir then - Info := Add_Info (Assoc, Kind_Assoc); - Translate_Association_Subprogram - (Stmt, Block, Assoc, Conv_Mode_In, Info.Assoc_In, - Base_Block, Entity); - end if; - if Get_Out_Conversion (Assoc) /= Null_Iir then - if Info = null then - Info := Add_Info (Assoc, Kind_Assoc); - end if; - Translate_Association_Subprogram - (Stmt, Block, Assoc, Conv_Mode_Out, Info.Assoc_Out, - Base_Block, Entity); - end if; - end if; - Assoc := Get_Chain (Assoc); - end loop; - end Translate_Association_Subprograms; - - procedure Elab_Conversion (Sig_In : Iir; - Sig_Out : Iir; - Reg_Subprg : O_Dnode; - Info : Assoc_Conv_Info; - Ndest : out Mnode) - is - Out_Type : Iir; - Out_Info : Type_Info_Acc; - Ssig : Mnode; - Constr : O_Assoc_List; - Var_Data : O_Dnode; - Data : Elab_Signal_Data; - begin - Out_Type := Get_Type (Sig_Out); - Out_Info := Get_Info (Out_Type); - - -- Allocate data for the subprogram. - Var_Data := Create_Temp (Info.Record_Ptr_Type); - New_Assign_Stmt - (New_Obj (Var_Data), - Gen_Alloc (Alloc_System, - New_Lit (New_Sizeof (Info.Record_Type, - Ghdl_Index_Type)), - Info.Record_Ptr_Type)); - - -- Set instance. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var_Data), Info.Instance_Field), - Get_Instance_Access (Info.Instance_Block)); - - -- Set instantiated unit instance (if any). - if Info.Instantiated_Entity /= Null_Iir then - declare - Inst_Addr : O_Enode; - Inst_Info : Ortho_Info_Acc; - begin - if Get_Kind (Info.Instantiated_Entity) - = Iir_Kind_Component_Declaration - then - Inst_Info := Get_Info (Info.Instantiated_Entity); - Inst_Addr := New_Address - (Get_Instance_Ref (Inst_Info.Comp_Scope), - Inst_Info.Comp_Ptr_Type); - else - Inst_Addr := Get_Instance_Access (Info.Instantiated_Entity); - end if; - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var_Data), - Info.Instantiated_Field), - Inst_Addr); - end; - end if; - - -- Set input. - Ssig := Chap6.Translate_Name (Sig_In); - Ssig := Stabilize (Ssig, True); - - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var_Data), Info.In_Field), - M2E (Ssig)); - - -- Create a copy of SIG_OUT. - Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), - Info.Out_Field), - Out_Info, Mode_Signal); - Chap4.Allocate_Complex_Object (Out_Type, Alloc_System, Ndest); - -- Note: NDEST will be assigned by ELAB_SIGNAL. - Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), - Info.Out_Field), - Out_Info, Mode_Signal); - Data := Elab_Signal_Data'(Has_Val => False, - Already_Resolved => True, - Val => Mnode_Null, - Check_Null => False, - If_Stmt => null); - Elab_Signal (Ndest, Out_Type, Data); - - Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), - Info.Out_Field), - Out_Info, Mode_Signal); - Ndest := Stabilize (Ndest, True); - - -- Register. - Start_Association (Constr, Reg_Subprg); - New_Association - (Constr, New_Lit (New_Subprogram_Address (Info.Subprg, - Ghdl_Ptr_Type))); - New_Association - (Constr, New_Convert_Ov (New_Obj_Value (Var_Data), Ghdl_Ptr_Type)); - - New_Association - (Constr, - New_Convert_Ov (M2E (Get_Leftest_Signal (Ssig, Get_Type (Sig_In))), - Ghdl_Signal_Ptr)); - New_Association (Constr, Get_Nbr_Signals (Ssig, Get_Type (Sig_In))); - - New_Association - (Constr, - New_Convert_Ov - (M2E (Get_Leftest_Signal (Ndest, Get_Type (Sig_Out))), - Ghdl_Signal_Ptr)); - New_Association (Constr, Get_Nbr_Signals (Ndest, Get_Type (Sig_Out))); - - New_Procedure_Call (Constr); - end Elab_Conversion; - - -- In conversion: from actual to formal. - procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode) - is - Assoc_Info : Assoc_Info_Acc; - begin - Assoc_Info := Get_Info (Assoc); - - Elab_Conversion - (Get_Actual (Assoc), Get_Formal (Assoc), - Ghdl_Signal_In_Conversion, Assoc_Info.Assoc_In, Ndest); - end Elab_In_Conversion; - - -- Out conversion: from formal to actual. - procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode) - is - Assoc_Info : Assoc_Info_Acc; - begin - Assoc_Info := Get_Info (Assoc); - - Elab_Conversion - (Get_Formal (Assoc), Get_Actual (Assoc), - Ghdl_Signal_Out_Conversion, Assoc_Info.Assoc_Out, Ndest); - end Elab_Out_Conversion; - - -- Create a record that describe thes location of an IIR node and - -- returns the address of it. - function Get_Location (N : Iir) return O_Dnode - is - Constr : O_Record_Aggr_List; - Aggr : O_Cnode; - Name : Name_Id; - Line : Natural; - Col : Natural; - C : O_Dnode; - begin - Files_Map.Location_To_Position (Get_Location (N), Name, Line, Col); - - New_Const_Decl (C, Create_Uniq_Identifier, O_Storage_Private, - Ghdl_Location_Type_Node); - Start_Const_Value (C); - Start_Record_Aggr (Constr, Ghdl_Location_Type_Node); - New_Record_Aggr_El - (Constr, New_Global_Address (Current_Filename_Node, Char_Ptr_Type)); - New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, - Integer_64 (Line))); - New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, - Integer_64 (Col))); - Finish_Record_Aggr (Constr, Aggr); - Finish_Const_Value (C, Aggr); - - return C; - --return New_Global_Address (C, Ghdl_Location_Ptr_Node); - end Get_Location; - end Chap4; - - package body Chap5 is - procedure Translate_Attribute_Specification - (Spec : Iir_Attribute_Specification) - is - Attr : constant Iir_Attribute_Declaration := - Get_Named_Entity (Get_Attribute_Designator (Spec)); - Atinfo : constant Type_Info_Acc := Get_Info (Get_Type (Attr)); - Mark : Id_Mark_Type; - Info : Object_Info_Acc; - begin - Push_Identifier_Prefix_Uniq (Mark); - Info := Add_Info (Spec, Kind_Object); - Info.Object_Var := Create_Var - (Create_Var_Identifier (Attr), - Chap4.Get_Object_Type (Atinfo, Mode_Value), - Global_Storage); - Pop_Identifier_Prefix (Mark); - end Translate_Attribute_Specification; - - procedure Elab_Attribute_Specification - (Spec : Iir_Attribute_Specification) - is - Attr : constant Iir_Attribute_Declaration := - Get_Named_Entity (Get_Attribute_Designator (Spec)); - begin - -- Kludge - Set_Info (Attr, Get_Info (Spec)); - Chap4.Elab_Object_Value (Attr, Get_Expression (Spec)); - Clear_Info (Attr); - end Elab_Attribute_Specification; - - procedure Gen_Elab_Disconnect_Non_Composite (Targ : Mnode; - Targ_Type : Iir; - Time : O_Dnode) - is - pragma Unreferenced (Targ_Type); - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Ghdl_Signal_Set_Disconnect); - New_Association - (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); - New_Association (Assoc, New_Obj_Value (Time)); - New_Procedure_Call (Assoc); - end Gen_Elab_Disconnect_Non_Composite; - - function Gen_Elab_Disconnect_Prepare - (Targ : Mnode; Targ_Type : Iir; Time : O_Dnode) - return O_Dnode - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Time; - end Gen_Elab_Disconnect_Prepare; - - function Gen_Elab_Disconnect_Update_Data_Array (Time : O_Dnode; - Targ_Type : Iir; - Index : O_Dnode) - return O_Dnode - is - pragma Unreferenced (Targ_Type, Index); - begin - return Time; - end Gen_Elab_Disconnect_Update_Data_Array; - - function Gen_Elab_Disconnect_Update_Data_Record - (Time : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) - return O_Dnode - is - pragma Unreferenced (Targ_Type, El); - begin - return Time; - end Gen_Elab_Disconnect_Update_Data_Record; - - procedure Gen_Elab_Disconnect_Finish_Data_Composite - (Data : in out O_Dnode) - is - pragma Unreferenced (Data); - begin - null; - end Gen_Elab_Disconnect_Finish_Data_Composite; - - procedure Gen_Elab_Disconnect is new Foreach_Non_Composite - (Data_Type => O_Dnode, - Composite_Data_Type => O_Dnode, - Do_Non_Composite => Gen_Elab_Disconnect_Non_Composite, - Prepare_Data_Array => Gen_Elab_Disconnect_Prepare, - Update_Data_Array => Gen_Elab_Disconnect_Update_Data_Array, - Finish_Data_Array => Gen_Elab_Disconnect_Finish_Data_Composite, - Prepare_Data_Record => Gen_Elab_Disconnect_Prepare, - Update_Data_Record => Gen_Elab_Disconnect_Update_Data_Record, - Finish_Data_Record => Gen_Elab_Disconnect_Finish_Data_Composite); - - procedure Elab_Disconnection_Specification - (Spec : Iir_Disconnection_Specification) - is - Val : O_Dnode; - List : constant Iir_List := Get_Signal_List (Spec); - El : Iir; - begin - Val := Create_Temp_Init - (Std_Time_Otype, - Chap7.Translate_Expression (Get_Expression (Spec))); - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Gen_Elab_Disconnect (Chap6.Translate_Name (El), - Get_Type (El), Val); - end loop; - end Elab_Disconnection_Specification; - - type Connect_Mode is - ( - -- Actual is a source for the formal. - Connect_Source, - - -- Both. - Connect_Both, - - -- Effective value of actual is the effective value of the formal. - Connect_Effective, - - -- Actual is a value. - Connect_Value - ); - - type Connect_Data is record - Actual_Node : Mnode; - Actual_Type : Iir; - - -- Mode of the connection. - Mode : Connect_Mode; - - -- If true, formal signal is a copy of the actual. - By_Copy : Boolean; - end record; - - -- Connect_effective: FORMAL is set from ACTUAL. - -- Connect_Source: ACTUAL is set from FORMAL (source of ACTUAL). - procedure Connect_Scalar (Formal_Node : Mnode; - Formal_Type : Iir; - Data : Connect_Data) - is - Act_Node, Form_Node : Mnode; - begin - if Data.By_Copy then - New_Assign_Stmt (M2Lv (Formal_Node), M2E (Data.Actual_Node)); - return; - end if; - - case Data.Mode is - when Connect_Both => - Open_Temp; - Act_Node := Stabilize (Data.Actual_Node, True); - Form_Node := Stabilize (Formal_Node, True); - when Connect_Source - | Connect_Effective => - Act_Node := Data.Actual_Node; - Form_Node := Formal_Node; - when Connect_Value => - null; - end case; - - if Data.Mode in Connect_Source .. Connect_Both then - -- Formal is a source to actual. - declare - Constr : O_Assoc_List; - begin - Start_Association (Constr, Ghdl_Signal_Add_Source); - New_Association (Constr, New_Convert_Ov (M2E (Act_Node), - Ghdl_Signal_Ptr)); - New_Association (Constr, New_Convert_Ov (M2E (Form_Node), - Ghdl_Signal_Ptr)); - New_Procedure_Call (Constr); - end; - end if; - - if Data.Mode in Connect_Both .. Connect_Effective then - -- The effective value of formal is the effective value of actual. - declare - Constr : O_Assoc_List; - begin - Start_Association (Constr, Ghdl_Signal_Effective_Value); - New_Association (Constr, New_Convert_Ov (M2E (Form_Node), - Ghdl_Signal_Ptr)); - New_Association (Constr, New_Convert_Ov (M2E (Act_Node), - Ghdl_Signal_Ptr)); - New_Procedure_Call (Constr); - end; - end if; - - if Data.Mode = Connect_Value then - declare - Type_Info : Type_Info_Acc; - Subprg : O_Dnode; - Constr : O_Assoc_List; - Conv : O_Tnode; - begin - Type_Info := Get_Info (Formal_Type); - case Type_Info.Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Signal_Associate_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Subprg := Ghdl_Signal_Associate_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Subprg := Ghdl_Signal_Associate_E32; - Conv := Ghdl_I32_Type; - when Type_Mode_I32 => - Subprg := Ghdl_Signal_Associate_I32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 => - Subprg := Ghdl_Signal_Associate_I64; - Conv := Ghdl_I64_Type; - when Type_Mode_F64 => - Subprg := Ghdl_Signal_Associate_F64; - Conv := Ghdl_Real_Type; - when others => - Error_Kind ("connect_scalar", Formal_Type); - end case; - Start_Association (Constr, Subprg); - New_Association (Constr, - New_Convert_Ov (New_Value (M2Lv (Formal_Node)), - Ghdl_Signal_Ptr)); - New_Association (Constr, - New_Convert_Ov (M2E (Data.Actual_Node), Conv)); - New_Procedure_Call (Constr); - end; - end if; - - if Data.Mode = Connect_Both then - Close_Temp; - end if; - end Connect_Scalar; - - function Connect_Prepare_Data_Composite - (Targ : Mnode; Formal_Type : Iir; Data : Connect_Data) - return Connect_Data - is - pragma Unreferenced (Targ, Formal_Type); - Res : Connect_Data; - Atype : Iir; - begin - Atype := Get_Base_Type (Data.Actual_Type); - if Get_Kind (Atype) = Iir_Kind_Record_Type_Definition then - Res := Data; - Stabilize (Res.Actual_Node); - return Res; - else - return Data; - end if; - end Connect_Prepare_Data_Composite; - - function Connect_Update_Data_Array (Data : Connect_Data; - Formal_Type : Iir; - Index : O_Dnode) - return Connect_Data - is - pragma Unreferenced (Formal_Type); - Res : Connect_Data; - begin - -- FIXME: should check matching elements! - Res := (Actual_Node => - Chap3.Index_Base (Chap3.Get_Array_Base (Data.Actual_Node), - Data.Actual_Type, New_Obj_Value (Index)), - Actual_Type => Get_Element_Subtype (Data.Actual_Type), - Mode => Data.Mode, - By_Copy => Data.By_Copy); - return Res; - end Connect_Update_Data_Array; - - function Connect_Update_Data_Record (Data : Connect_Data; - Formal_Type : Iir; - El : Iir_Element_Declaration) - return Connect_Data - is - pragma Unreferenced (Formal_Type); - Res : Connect_Data; - begin - Res := (Actual_Node => - Chap6.Translate_Selected_Element (Data.Actual_Node, El), - Actual_Type => Get_Type (El), - Mode => Data.Mode, - By_Copy => Data.By_Copy); - return Res; - end Connect_Update_Data_Record; - - procedure Connect_Finish_Data_Composite (Data : in out Connect_Data) - is - pragma Unreferenced (Data); - begin - null; - end Connect_Finish_Data_Composite; - - procedure Connect is new Foreach_Non_Composite - (Data_Type => Connect_Data, - Composite_Data_Type => Connect_Data, - Do_Non_Composite => Connect_Scalar, - Prepare_Data_Array => Connect_Prepare_Data_Composite, - Update_Data_Array => Connect_Update_Data_Array, - Finish_Data_Array => Connect_Finish_Data_Composite, - Prepare_Data_Record => Connect_Prepare_Data_Composite, - Update_Data_Record => Connect_Update_Data_Record, - Finish_Data_Record => Connect_Finish_Data_Composite); - - procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir) - is - Act_Node : Mnode; - Bounds : Mnode; - Tinfo : Type_Info_Acc; - Bound_Var : O_Dnode; - Actual_Type : Iir; - begin - Actual_Type := Get_Type (Actual); - Open_Temp; - if Is_Fully_Constrained_Type (Actual_Type) then - Chap3.Create_Array_Subtype (Actual_Type, False); - Tinfo := Get_Info (Actual_Type); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); - if Get_Alloc_Kind_For_Var (Tinfo.T.Array_Bounds) = Alloc_Stack then - -- We need a copy. - Bound_Var := Create_Temp (Tinfo.T.Bounds_Ptr_Type); - New_Assign_Stmt - (New_Obj (Bound_Var), - Gen_Alloc (Alloc_System, - New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, - Ghdl_Index_Type)), - Tinfo.T.Bounds_Ptr_Type)); - Gen_Memcpy (New_Obj_Value (Bound_Var), - M2Addr (Bounds), - New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, - Ghdl_Index_Type))); - Bounds := Dp2M (Bound_Var, Tinfo, Mode_Value, - Tinfo.T.Bounds_Type, - Tinfo.T.Bounds_Ptr_Type); - end if; - else - Bounds := Chap3.Get_Array_Bounds (Chap6.Translate_Name (Actual)); - end if; - Act_Node := Chap6.Translate_Name (Port); - New_Assign_Stmt - (-- FIXME: this works only because it is not stabilized, - -- and therefore the bounds field is returned and not - -- a pointer to the bounds. - M2Lp (Chap3.Get_Array_Bounds (Act_Node)), - M2Addr (Bounds)); - Close_Temp; - end Elab_Unconstrained_Port; - - -- Return TRUE if EXPR is a signal name. - function Is_Signal (Expr : Iir) return Boolean - is - Obj : Iir; - begin - Obj := Sem_Names.Name_To_Object (Expr); - if Obj /= Null_Iir then - return Is_Signal_Object (Obj); - else - return False; - end if; - end Is_Signal; - - procedure Elab_Port_Map_Aspect_Assoc (Assoc : Iir; By_Copy : Boolean) - is - Formal : constant Iir := Get_Formal (Assoc); - Actual : constant Iir := Get_Actual (Assoc); - Formal_Type : constant Iir := Get_Type (Formal); - Actual_Type : constant Iir := Get_Type (Actual); - Inter : constant Iir := Get_Association_Interface (Assoc); - Formal_Node, Actual_Node : Mnode; - Data : Connect_Data; - Mode : Connect_Mode; - begin - if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then - raise Internal_Error; - end if; - - Open_Temp; - if Get_In_Conversion (Assoc) = Null_Iir - and then Get_Out_Conversion (Assoc) = Null_Iir - then - Formal_Node := Chap6.Translate_Name (Formal); - if Get_Object_Kind (Formal_Node) /= Mode_Signal then - raise Internal_Error; - end if; - if Is_Signal (Actual) then - -- LRM93 4.3.1.2 - -- For a signal of a scalar type, each source is either - -- a driver or an OUT, INOUT, BUFFER or LINKAGE port of - -- a component instance or of a block statement with - -- which the signalis associated. - - -- LRM93 12.6.2 - -- For a scalar signal S, the effective value of S is - -- determined in the following manner: - -- * If S is [...] a port of mode BUFFER or [...], - -- then the effective value of S is the same as - -- the driving value of S. - -- * If S is a connected port of mode IN or INOUT, - -- then the effective value of S is the same as - -- the effective value of the actual part of the - -- association element that associates an actual - -- with S. - -- * [...] - case Get_Mode (Inter) is - when Iir_In_Mode => - Mode := Connect_Effective; - when Iir_Inout_Mode => - Mode := Connect_Both; - when Iir_Out_Mode - | Iir_Buffer_Mode - | Iir_Linkage_Mode => - Mode := Connect_Source; - when Iir_Unknown_Mode => - raise Internal_Error; - end case; - - -- translate actual (abort if not a signal). - Actual_Node := Chap6.Translate_Name (Actual); - if Get_Object_Kind (Actual_Node) /= Mode_Signal then - raise Internal_Error; - end if; - else - declare - Actual_Val : O_Enode; - begin - Actual_Val := Chap7.Translate_Expression - (Actual, Formal_Type); - Actual_Node := E2M - (Actual_Val, Get_Info (Formal_Type), Mode_Value); - Mode := Connect_Value; - end; - end if; - - if Get_Kind (Formal_Type) in Iir_Kinds_Array_Type_Definition - then - -- Check length matches. - Stabilize (Formal_Node); - Stabilize (Actual_Node); - Chap3.Check_Array_Match (Formal_Type, Formal_Node, - Actual_Type, Actual_Node, - Assoc); - end if; - - Data := (Actual_Node => Actual_Node, - Actual_Type => Actual_Type, - Mode => Mode, - By_Copy => By_Copy); - Connect (Formal_Node, Formal_Type, Data); - else - if Get_In_Conversion (Assoc) /= Null_Iir then - Chap4.Elab_In_Conversion (Assoc, Actual_Node); - Formal_Node := Chap6.Translate_Name (Formal); - Data := (Actual_Node => Actual_Node, - Actual_Type => Formal_Type, - Mode => Connect_Effective, - By_Copy => False); - Connect (Formal_Node, Formal_Type, Data); - end if; - if Get_Out_Conversion (Assoc) /= Null_Iir then - -- flow: FORMAL to ACTUAL - Chap4.Elab_Out_Conversion (Assoc, Formal_Node); - Actual_Node := Chap6.Translate_Name (Actual); - Data := (Actual_Node => Actual_Node, - Actual_Type => Actual_Type, - Mode => Connect_Source, - By_Copy => False); - Connect (Formal_Node, Actual_Type, Data); - end if; - end if; - - Close_Temp; - end Elab_Port_Map_Aspect_Assoc; - - -- Return TRUE if the collapse_signal_flag is set for each individual - -- association. - function Inherit_Collapse_Flag (Assoc : Iir) return Boolean - is - El : Iir; - begin - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Individual => - El := Get_Individual_Association_Chain (Assoc); - while El /= Null_Iir loop - if Inherit_Collapse_Flag (El) = False then - return False; - end if; - El := Get_Chain (El); - end loop; - return True; - when Iir_Kind_Choice_By_Expression - | Iir_Kind_Choice_By_Range - | Iir_Kind_Choice_By_Name => - El := Assoc; - while El /= Null_Iir loop - if not Inherit_Collapse_Flag (Get_Associated_Expr (Assoc)) - then - return False; - end if; - El := Get_Chain (El); - end loop; - return True; - when Iir_Kind_Association_Element_By_Expression => - return Get_Collapse_Signal_Flag (Assoc); - when others => - Error_Kind ("inherit_collapse_flag", Assoc); - end case; - end Inherit_Collapse_Flag; - - procedure Elab_Generic_Map_Aspect (Mapping : Iir) - is - Assoc : Iir; - Formal : Iir; - begin - -- Elab generics, and associate. - Assoc := Get_Generic_Map_Aspect_Chain (Mapping); - while Assoc /= Null_Iir loop - Open_Temp; - Formal := Get_Formal (Assoc); - if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then - Formal := Get_Named_Entity (Formal); - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Expression => - declare - Targ : Mnode; - begin - if Get_Whole_Association_Flag (Assoc) then - Chap4.Elab_Object_Storage (Formal); - Targ := Chap6.Translate_Name (Formal); - Chap4.Elab_Object_Init - (Targ, Formal, Get_Actual (Assoc)); - else - Targ := Chap6.Translate_Name (Formal); - Chap7.Translate_Assign - (Targ, Get_Actual (Assoc), Get_Type (Formal)); - end if; - end; - when Iir_Kind_Association_Element_Open => - Chap4.Elab_Object_Value (Formal, Get_Default_Value (Formal)); - when Iir_Kind_Association_Element_By_Individual => - -- Create the object. - declare - Formal_Type : constant Iir := Get_Type (Formal); - Obj_Info : constant Object_Info_Acc := Get_Info (Formal); - Obj_Type : constant Iir := Get_Actual_Type (Assoc); - Formal_Node : Mnode; - Type_Info : Type_Info_Acc; - Bounds : Mnode; - begin - Chap3.Elab_Object_Subtype (Formal_Type); - Type_Info := Get_Info (Formal_Type); - Formal_Node := Get_Var - (Obj_Info.Object_Var, Type_Info, Mode_Value); - Stabilize (Formal_Node); - if Obj_Type = Null_Iir then - Chap4.Allocate_Complex_Object - (Formal_Type, Alloc_System, Formal_Node); - else - Chap3.Create_Array_Subtype (Obj_Type, False); - Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type); - Chap3.Translate_Object_Allocation - (Formal_Node, Alloc_System, Formal_Type, Bounds); - end if; - end; - when Iir_Kind_Association_Element_Package => - pragma Assert (Get_Kind (Formal) = - Iir_Kind_Interface_Package_Declaration); - declare - Uninst_Pkg : constant Iir := Get_Named_Entity - (Get_Uninstantiated_Package_Name (Formal)); - Uninst_Info : constant Ortho_Info_Acc := - Get_Info (Uninst_Pkg); - Formal_Info : constant Ortho_Info_Acc := - Get_Info (Formal); - Actual : constant Iir := Get_Named_Entity - (Get_Actual (Assoc)); - Actual_Info : constant Ortho_Info_Acc := - Get_Info (Actual); - begin - New_Assign_Stmt - (Get_Var (Formal_Info.Package_Instance_Spec_Var), - New_Address - (Get_Instance_Ref - (Actual_Info.Package_Instance_Spec_Scope), - Uninst_Info.Package_Spec_Ptr_Type)); - New_Assign_Stmt - (Get_Var (Formal_Info.Package_Instance_Body_Var), - New_Address - (Get_Instance_Ref - (Actual_Info.Package_Instance_Body_Scope), - Uninst_Info.Package_Body_Ptr_Type)); - end; - when others => - Error_Kind ("elab_generic_map_aspect(1)", Assoc); - end case; - Close_Temp; - Assoc := Get_Chain (Assoc); - end loop; - end Elab_Generic_Map_Aspect; - - procedure Elab_Port_Map_Aspect (Mapping : Iir; Block_Parent : Iir) - is - Assoc : Iir; - Formal : Iir; - Formal_Base : Iir; - Fb_Type : Iir; - Fbt_Info : Type_Info_Acc; - Collapse_Individual : Boolean := False; - begin - -- Ports. - Assoc := Get_Port_Map_Aspect_Chain (Mapping); - while Assoc /= Null_Iir loop - Formal := Get_Formal (Assoc); - Formal_Base := Get_Association_Interface (Assoc); - Fb_Type := Get_Type (Formal_Base); - - Open_Temp; - -- Set bounds of unconstrained ports. - Fbt_Info := Get_Info (Fb_Type); - if Fbt_Info.Type_Mode = Type_Mode_Fat_Array then - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Expression => - if Get_Whole_Association_Flag (Assoc) then - Elab_Unconstrained_Port (Formal, Get_Actual (Assoc)); - end if; - when Iir_Kind_Association_Element_Open => - declare - Actual_Type : Iir; - Bounds : Mnode; - Formal_Node : Mnode; - begin - Actual_Type := - Get_Type (Get_Default_Value (Formal_Base)); - Chap3.Create_Array_Subtype (Actual_Type, True); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); - Formal_Node := Chap6.Translate_Name (Formal); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), - M2Addr (Bounds)); - end; - when Iir_Kind_Association_Element_By_Individual => - declare - Actual_Type : Iir; - Bounds : Mnode; - Formal_Node : Mnode; - begin - Actual_Type := Get_Actual_Type (Assoc); - Chap3.Create_Array_Subtype (Actual_Type, False); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); - Formal_Node := Chap6.Translate_Name (Formal); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), - M2Addr (Bounds)); - end; - when others => - Error_Kind ("elab_map_aspect(2)", Assoc); - end case; - end if; - Close_Temp; - - -- Allocate storage of ports. - Open_Temp; - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Individual - | Iir_Kind_Association_Element_Open => - Chap4.Elab_Signal_Declaration_Storage (Formal); - when Iir_Kind_Association_Element_By_Expression => - if Get_Whole_Association_Flag (Assoc) then - Chap4.Elab_Signal_Declaration_Storage (Formal); - end if; - when others => - Error_Kind ("elab_map_aspect(3)", Assoc); - end case; - Close_Temp; - - -- Create or copy signals. - Open_Temp; - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Expression => - if Get_Whole_Association_Flag (Assoc) then - if Get_Collapse_Signal_Flag (Assoc) then - -- For collapsed association, copy signals. - Elab_Port_Map_Aspect_Assoc (Assoc, True); - else - -- Create non-collapsed signals. - Chap4.Elab_Signal_Declaration_Object - (Formal, Block_Parent, False); - -- And associate. - Elab_Port_Map_Aspect_Assoc (Assoc, False); - end if; - else - -- By sub-element. - -- Either the whole signal is collapsed or it was already - -- created. - -- And associate. - Elab_Port_Map_Aspect_Assoc (Assoc, Collapse_Individual); - end if; - when Iir_Kind_Association_Element_Open => - -- Create non-collapsed signals. - Chap4.Elab_Signal_Declaration_Object - (Formal, Block_Parent, False); - when Iir_Kind_Association_Element_By_Individual => - -- Inherit the collapse flag. - -- If it is set for all sub-associations, continue. - -- Otherwise, create signals and do not collapse. - -- FIXME: this may be slightly optimized. - if not Inherit_Collapse_Flag (Assoc) then - -- Create the formal. - Chap4.Elab_Signal_Declaration_Object - (Formal, Block_Parent, False); - Collapse_Individual := False; - else - Collapse_Individual := True; - end if; - when others => - Error_Kind ("elab_map_aspect(4)", Assoc); - end case; - Close_Temp; - - Assoc := Get_Chain (Assoc); - end loop; - end Elab_Port_Map_Aspect; - - procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir) is - begin - -- The generic map must be done before the elaboration of - -- the ports, since a port subtype may depend on a generic. - Elab_Generic_Map_Aspect (Mapping); - - Elab_Port_Map_Aspect (Mapping, Block_Parent); - end Elab_Map_Aspect; - end Chap5; - - package body Chap6 is - function Get_Array_Bound_Length (Arr : Mnode; - Arr_Type : Iir; - Dim : Natural) - return O_Enode - is - Index_Type : constant Iir := Get_Index_Type (Arr_Type, Dim - 1); - Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); - Constraint : Iir; - begin - if Tinfo.Type_Locally_Constrained then - Constraint := Get_Range_Constraint (Index_Type); - return New_Lit (Chap7.Translate_Static_Range_Length (Constraint)); - else - return M2E - (Chap3.Range_To_Length - (Chap3.Get_Array_Range (Arr, Arr_Type, Dim))); - end if; - end Get_Array_Bound_Length; - - procedure Gen_Bound_Error (Loc : Iir) - is - Constr : O_Assoc_List; - Name : Name_Id; - Line, Col : Natural; - begin - Files_Map.Location_To_Position (Get_Location (Loc), Name, Line, Col); - - Start_Association (Constr, Ghdl_Bound_Check_Failed_L1); - Assoc_Filename_Line (Constr, Line); - New_Procedure_Call (Constr); - end Gen_Bound_Error; - - procedure Gen_Program_Error (Loc : Iir; Code : Natural) - is - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Ghdl_Program_Error); - - if Current_Filename_Node = O_Dnode_Null then - New_Association (Assoc, New_Lit (New_Null_Access (Char_Ptr_Type))); - New_Association (Assoc, - New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0))); - else - Assoc_Filename_Line (Assoc, Get_Line_Number (Loc)); - end if; - New_Association - (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Code)))); - New_Procedure_Call (Assoc); - end Gen_Program_Error; - - -- Generate code to emit a failure if COND is TRUE, indicating an - -- index violation for dimension DIM of an array. LOC is usually - -- the expression which has computed the index and is used only for - -- its location. - procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural) - is - pragma Unreferenced (Dim); - If_Blk : O_If_Block; - begin - Start_If_Stmt (If_Blk, Cond); - Gen_Bound_Error (Loc); - Finish_If_Stmt (If_Blk); - end Check_Bound_Error; - - -- Return TRUE if an array whose index type is RNG_TYPE indexed by - -- an expression of type EXPR_TYPE needs a bound check. - function Need_Index_Check (Expr_Type : Iir; Rng_Type : Iir) - return Boolean - is - Rng : Iir; - begin - -- Do checks if type of the expression is not a subtype. - -- FIXME: EXPR_TYPE shound not be NULL_IIR (generate stmt) - if Expr_Type = Null_Iir then - return True; - end if; - case Get_Kind (Expr_Type) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition => - null; - when others => - return True; - end case; - - -- No check if the expression has the type of the index. - if Expr_Type = Rng_Type then - return False; - end if; - - -- No check for 'Range or 'Reverse_Range. - Rng := Get_Range_Constraint (Expr_Type); - if (Get_Kind (Rng) = Iir_Kind_Range_Array_Attribute - or Get_Kind (Rng) = Iir_Kind_Reverse_Range_Array_Attribute) - and then Get_Type (Rng) = Rng_Type - then - return False; - end if; - - return True; - end Need_Index_Check; - - procedure Get_Deep_Range_Expression - (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean) - is - T : Iir; - R : Iir; - begin - Is_Reverse := False; - - -- T is an integer/enumeration subtype. - T := Atype; - loop - case Get_Kind (T) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition => - -- These types have a range. - null; - when others => - Error_Kind ("get_deep_range_expression(1)", T); - end case; - - R := Get_Range_Constraint (T); - case Get_Kind (R) is - when Iir_Kind_Range_Expression => - Rng := R; - return; - when Iir_Kind_Range_Array_Attribute => - null; - when Iir_Kind_Reverse_Range_Array_Attribute => - Is_Reverse := not Is_Reverse; - when others => - Error_Kind ("get_deep_range_expression(2)", R); - end case; - T := Get_Index_Subtype (R); - if T = Null_Iir then - Rng := Null_Iir; - return; - end if; - end loop; - end Get_Deep_Range_Expression; - - function Translate_Index_To_Offset (Rng : Mnode; - Index : O_Enode; - Index_Expr : Iir; - Range_Type : Iir; - Loc : Iir) - return O_Enode - is - Need_Check : Boolean; - Dir : O_Enode; - If_Blk : O_If_Block; - Res : O_Dnode; - Off : O_Dnode; - Bound : O_Enode; - Cond1, Cond2: O_Enode; - Index_Node : O_Dnode; - Bound_Node : O_Dnode; - Index_Info : Type_Info_Acc; - Deep_Rng : Iir; - Deep_Reverse : Boolean; - begin - Index_Info := Get_Info (Get_Base_Type (Range_Type)); - if Index_Expr = Null_Iir then - Need_Check := True; - Deep_Rng := Null_Iir; - Deep_Reverse := False; - else - Need_Check := Need_Index_Check (Get_Type (Index_Expr), Range_Type); - Get_Deep_Range_Expression (Range_Type, Deep_Rng, Deep_Reverse); - end if; - - Res := Create_Temp (Ghdl_Index_Type); - - Open_Temp; - - Off := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); - - Bound := M2E (Chap3.Range_To_Left (Rng)); - - if Deep_Rng /= Null_Iir then - if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then - -- Direction TO: INDEX - LEFT. - New_Assign_Stmt (New_Obj (Off), - New_Dyadic_Op (ON_Sub_Ov, - Index, Bound)); - else - -- Direction DOWNTO: LEFT - INDEX. - New_Assign_Stmt (New_Obj (Off), - New_Dyadic_Op (ON_Sub_Ov, - Bound, Index)); - end if; - else - Index_Node := Create_Temp_Init - (Index_Info.Ortho_Type (Mode_Value), Index); - Bound_Node := Create_Temp_Init - (Index_Info.Ortho_Type (Mode_Value), Bound); - Dir := M2E (Chap3.Range_To_Dir (Rng)); - - -- Non-static direction. - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Eq, Dir, - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - -- Direction TO: INDEX - LEFT. - New_Assign_Stmt (New_Obj (Off), - New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Index_Node), - New_Obj_Value (Bound_Node))); - New_Else_Stmt (If_Blk); - -- Direction DOWNTO: LEFT - INDEX. - New_Assign_Stmt (New_Obj (Off), - New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Bound_Node), - New_Obj_Value (Index_Node))); - Finish_If_Stmt (If_Blk); - end if; - - -- Get the offset. - New_Assign_Stmt - (New_Obj (Res), New_Convert_Ov (New_Obj_Value (Off), - Ghdl_Index_Type)); - - -- Check bounds. - if Need_Check then - Cond1 := New_Compare_Op - (ON_Lt, - New_Obj_Value (Off), - New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), - 0)), - Ghdl_Bool_Type); - - Cond2 := New_Compare_Op - (ON_Ge, - New_Obj_Value (Res), - M2E (Chap3.Range_To_Length (Rng)), - Ghdl_Bool_Type); - Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); - end if; - - Close_Temp; - - return New_Obj_Value (Res); - end Translate_Index_To_Offset; - - -- Translate index EXPR in dimension DIM of thin array into an - -- offset. - -- This checks bounds. - function Translate_Thin_Index_Offset (Index_Type : Iir; - Dim : Natural; - Expr : Iir) - return O_Enode - is - Index_Range : constant Iir := Get_Range_Constraint (Index_Type); - Obound : O_Cnode; - Res : O_Dnode; - Cond2: O_Enode; - Index : O_Enode; - Index_Base_Type : Iir; - V : Iir_Int64; - B : Iir_Int64; - begin - B := Eval_Pos (Get_Left_Limit (Index_Range)); - if Get_Expr_Staticness (Expr) = Locally then - V := Eval_Pos (Eval_Static_Expr (Expr)); - if Get_Direction (Index_Range) = Iir_To then - B := V - B; - else - B := B - V; - end if; - return New_Lit - (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (B))); - else - Index_Base_Type := Get_Base_Type (Index_Type); - Index := Chap7.Translate_Expression (Expr, Index_Base_Type); - - if Get_Direction (Index_Range) = Iir_To then - -- Direction TO: INDEX - LEFT. - if B /= 0 then - Obound := Chap7.Translate_Static_Range_Left - (Index_Range, Index_Base_Type); - Index := New_Dyadic_Op (ON_Sub_Ov, Index, New_Lit (Obound)); - end if; - else - -- Direction DOWNTO: LEFT - INDEX. - Obound := Chap7.Translate_Static_Range_Left - (Index_Range, Index_Base_Type); - Index := New_Dyadic_Op (ON_Sub_Ov, New_Lit (Obound), Index); - end if; - - -- Get the offset. - Index := New_Convert_Ov (Index, Ghdl_Index_Type); - - -- Since the value is unsigned, both left and right bounds are - -- checked in the same time. - if Get_Type (Expr) /= Index_Type then - Res := Create_Temp_Init (Ghdl_Index_Type, Index); - - Cond2 := New_Compare_Op - (ON_Ge, New_Obj_Value (Res), - New_Lit (Chap7.Translate_Static_Range_Length (Index_Range)), - Ghdl_Bool_Type); - Check_Bound_Error (Cond2, Expr, Dim); - Index := New_Obj_Value (Res); - end if; - - return Index; - end if; - end Translate_Thin_Index_Offset; - - -- Translate an indexed name. - type Indexed_Name_Data is record - Offset : O_Dnode; - Res : Mnode; - end record; - - function Translate_Indexed_Name_Init (Prefix_Orig : Mnode; Expr : Iir) - return Indexed_Name_Data - is - Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); - Prefix_Info : constant Type_Info_Acc := Get_Info (Prefix_Type); - Index_List : constant Iir_List := Get_Index_List (Expr); - Type_List : constant Iir_List := Get_Index_Subtype_List (Prefix_Type); - Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); - Prefix : Mnode; - Index : Iir; - Offset : O_Dnode; - R : O_Enode; - Length : O_Enode; - Itype : Iir; - Ibasetype : Iir; - Range_Ptr : Mnode; - begin - case Prefix_Info.Type_Mode is - when Type_Mode_Fat_Array => - Prefix := Stabilize (Prefix_Orig); - when Type_Mode_Array => - Prefix := Prefix_Orig; - when others => - raise Internal_Error; - end case; - Offset := Create_Temp (Ghdl_Index_Type); - for Dim in 1 .. Nbr_Dim loop - Index := Get_Nth_Element (Index_List, Dim - 1); - Itype := Get_Index_Type (Type_List, Dim - 1); - Ibasetype := Get_Base_Type (Itype); - Open_Temp; - -- Compute index for the current dimension. - case Prefix_Info.Type_Mode is - when Type_Mode_Fat_Array => - Range_Ptr := Stabilize - (Chap3.Get_Array_Range (Prefix, Prefix_Type, Dim)); - R := Translate_Index_To_Offset - (Range_Ptr, - Chap7.Translate_Expression (Index, Ibasetype), - Null_Iir, Itype, Index); - when Type_Mode_Array => - if Prefix_Info.Type_Locally_Constrained then - R := Translate_Thin_Index_Offset (Itype, Dim, Index); - else - -- Manually extract range since there is no infos for - -- index subtype. - Range_Ptr := Chap3.Bounds_To_Range - (Chap3.Get_Array_Type_Bounds (Prefix_Type), - Prefix_Type, Dim); - Stabilize (Range_Ptr); - R := Translate_Index_To_Offset - (Range_Ptr, - Chap7.Translate_Expression (Index, Ibasetype), - Index, Itype, Index); - end if; - when others => - raise Internal_Error; - end case; - if Dim = 1 then - -- First dimension. - New_Assign_Stmt (New_Obj (Offset), R); - else - -- If there are more dimension(s) to follow, then multiply - -- the current offset by the length of the current dimension. - if Prefix_Info.Type_Locally_Constrained then - Length := New_Lit (Chap7.Translate_Static_Range_Length - (Get_Range_Constraint (Itype))); - else - Length := M2E (Chap3.Range_To_Length (Range_Ptr)); - end if; - New_Assign_Stmt - (New_Obj (Offset), - New_Dyadic_Op (ON_Add_Ov, - New_Dyadic_Op (ON_Mul_Ov, - New_Obj_Value (Offset), - Length), - R)); - end if; - Close_Temp; - end loop; - - return (Offset => Offset, - Res => Chap3.Index_Base - (Chap3.Get_Array_Base (Prefix), Prefix_Type, - New_Obj_Value (Offset))); - end Translate_Indexed_Name_Init; - - function Translate_Indexed_Name_Finish - (Prefix : Mnode; Expr : Iir; Data : Indexed_Name_Data) - return Mnode - is - begin - return Chap3.Index_Base (Chap3.Get_Array_Base (Prefix), - Get_Type (Get_Prefix (Expr)), - New_Obj_Value (Data.Offset)); - end Translate_Indexed_Name_Finish; - - function Translate_Indexed_Name (Prefix : Mnode; Expr : Iir) - return Mnode - is - begin - return Translate_Indexed_Name_Init (Prefix, Expr).Res; - end Translate_Indexed_Name; - - type Slice_Name_Data is record - Off : Unsigned_64; - Is_Off : Boolean; - - Unsigned_Diff : O_Dnode; - - -- Variable pointing to the prefix. - Prefix_Var : Mnode; - - -- Variable pointing to slice. - Slice_Range : Mnode; - end record; - - procedure Translate_Slice_Name_Init - (Prefix : Mnode; Expr : Iir_Slice_Name; Data : out Slice_Name_Data) - is - -- Type of the prefix. - Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); - - -- Type info of the prefix. - Prefix_Info : Type_Info_Acc; - - -- Type of the first (and only) index of the prefix array type. - Index_Type : constant Iir := Get_Index_Type (Prefix_Type, 0); - - -- Type of the slice. - Slice_Type : constant Iir := Get_Type (Expr); - Slice_Info : Type_Info_Acc; - - -- True iff the direction of the slice is known at compile time. - Static_Range : Boolean; - - -- Suffix of the slice (discrete range). - Expr_Range : constant Iir := Get_Suffix (Expr); - - -- Variable pointing to the prefix. - Prefix_Var : Mnode; - - -- Type info of the range base type. - Index_Info : Type_Info_Acc; - - -- Variables pointing to slice and prefix ranges. - Slice_Range : Mnode; - Prefix_Range : Mnode; - - Diff : O_Dnode; - Unsigned_Diff : O_Dnode; - If_Blk, If_Blk1 : O_If_Block; - begin - -- Evaluate slice bounds. - Chap3.Create_Array_Subtype (Slice_Type, True); - - -- The info may have just been created. - Prefix_Info := Get_Info (Prefix_Type); - Slice_Info := Get_Info (Slice_Type); - - if Slice_Info.Type_Mode = Type_Mode_Array - and then Slice_Info.Type_Locally_Constrained - and then Prefix_Info.Type_Mode = Type_Mode_Array - and then Prefix_Info.Type_Locally_Constrained - then - Data.Is_Off := True; - Data.Prefix_Var := Prefix; - - -- Both prefix and result are constrained array. - declare - Prefix_Left, Slice_Left : Iir_Int64; - Off : Iir_Int64; - Slice_Index_Type : Iir; - Slice_Range : Iir; - Slice_Length : Iir_Int64; - Index_Range : Iir; - begin - Index_Range := Get_Range_Constraint (Index_Type); - Prefix_Left := Eval_Pos (Get_Left_Limit (Index_Range)); - Slice_Index_Type := Get_Index_Type (Slice_Type, 0); - Slice_Range := Get_Range_Constraint (Slice_Index_Type); - Slice_Left := Eval_Pos (Get_Left_Limit (Slice_Range)); - Slice_Length := Eval_Discrete_Range_Length (Slice_Range); - if Slice_Length = 0 then - -- Null slice. - Data.Off := 0; - return; - end if; - if Get_Direction (Index_Range) /= Get_Direction (Slice_Range) - then - -- This is allowed with vhdl87 - Off := 0; - Slice_Length := 0; - else - -- Both prefix and slice are thin array. - case Get_Direction (Index_Range) is - when Iir_To => - Off := Slice_Left - Prefix_Left; - when Iir_Downto => - Off := Prefix_Left - Slice_Left; - end case; - if Off < 0 then - -- Must have been caught by sem. - raise Internal_Error; - end if; - if Off + Slice_Length - > Eval_Discrete_Range_Length (Index_Range) - then - -- Must have been caught by sem. - raise Internal_Error; - end if; - end if; - Data.Off := Unsigned_64 (Off); - - return; - end; - end if; - - Data.Is_Off := False; - - -- Save prefix. - Prefix_Var := Stabilize (Prefix); - - Index_Info := Get_Info (Get_Base_Type (Index_Type)); - - -- Save prefix bounds. - Prefix_Range := Stabilize - (Chap3.Get_Array_Range (Prefix_Var, Prefix_Type, 1)); - - -- Save slice bounds. - Slice_Range := Stabilize - (Chap3.Bounds_To_Range (Chap3.Get_Array_Type_Bounds (Slice_Type), - Slice_Type, 1)); - - -- TRUE if the direction of the slice is known. - Static_Range := Get_Kind (Expr_Range) = Iir_Kind_Range_Expression; - - -- Check direction against same direction, error if different. - -- FIXME: what about v87 -> if different then null slice - if not Static_Range - or else Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition - then - -- Check same direction. - Check_Bound_Error - (New_Compare_Op (ON_Neq, - M2E (Chap3.Range_To_Dir (Prefix_Range)), - M2E (Chap3.Range_To_Dir (Slice_Range)), - Ghdl_Bool_Type), - Expr, 1); - end if; - - Unsigned_Diff := Create_Temp (Ghdl_Index_Type); - - -- Check if not a null slice. - -- The bounds of a null slice may be out of range. So DIFF cannot - -- be computed by substraction. - Start_If_Stmt - (If_Blk, - New_Compare_Op - (ON_Eq, - M2E (Chap3.Range_To_Length (Slice_Range)), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Obj (Unsigned_Diff), New_Lit (Ghdl_Index_0)); - New_Else_Stmt (If_Blk); - Diff := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); - - -- Compute the offset in the prefix. - if not Static_Range then - Start_If_Stmt - (If_Blk1, New_Compare_Op (ON_Eq, - M2E (Chap3.Range_To_Dir (Slice_Range)), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - end if; - if not Static_Range or else Get_Direction (Expr_Range) = Iir_To then - -- Diff = slice - bounds. - New_Assign_Stmt - (New_Obj (Diff), - New_Dyadic_Op (ON_Sub_Ov, - M2E (Chap3.Range_To_Left (Slice_Range)), - M2E (Chap3.Range_To_Left (Prefix_Range)))); - end if; - if not Static_Range then - New_Else_Stmt (If_Blk1); - end if; - if not Static_Range or else Get_Direction (Expr_Range) = Iir_Downto - then - -- Diff = bounds - slice. - New_Assign_Stmt - (New_Obj (Diff), - New_Dyadic_Op (ON_Sub_Ov, - M2E (Chap3.Range_To_Left (Prefix_Range)), - M2E (Chap3.Range_To_Left (Slice_Range)))); - end if; - if not Static_Range then - Finish_If_Stmt (If_Blk1); - end if; - - -- Note: this also check for overflow. - New_Assign_Stmt - (New_Obj (Unsigned_Diff), - New_Convert_Ov (New_Obj_Value (Diff), Ghdl_Index_Type)); - - -- Check bounds. - declare - Err_1 : O_Enode; - Err_2 : O_Enode; - begin - -- Bounds error if left of slice is before left of prefix. - Err_1 := New_Compare_Op - (ON_Lt, - New_Obj_Value (Diff), - New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), - 0)), - Ghdl_Bool_Type); - -- Bounds error if right of slice is after right of prefix. - Err_2 := New_Compare_Op - (ON_Gt, - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Unsigned_Diff), - M2E (Chap3.Range_To_Length (Slice_Range))), - M2E (Chap3.Range_To_Length (Prefix_Range)), - Ghdl_Bool_Type); - Check_Bound_Error (New_Dyadic_Op (ON_Or, Err_1, Err_2), Expr, 1); - end; - Finish_If_Stmt (If_Blk); - - Data.Slice_Range := Slice_Range; - Data.Prefix_Var := Prefix_Var; - Data.Unsigned_Diff := Unsigned_Diff; - Data.Is_Off := False; - end Translate_Slice_Name_Init; - - function Translate_Slice_Name_Finish - (Prefix : Mnode; Expr : Iir_Slice_Name; Data : Slice_Name_Data) - return Mnode - is - -- Type of the slice. - Slice_Type : constant Iir := Get_Type (Expr); - Slice_Info : constant Type_Info_Acc := Get_Info (Slice_Type); - - -- Object kind of the prefix. - Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); - - Res_D : O_Dnode; - begin - if Data.Is_Off then - return Chap3.Slice_Base - (Prefix, Slice_Type, New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, Data.Off))); - else - -- Create the result (fat array) and assign the bounds field. - case Slice_Info.Type_Mode is - when Type_Mode_Fat_Array => - Res_D := Create_Temp (Slice_Info.Ortho_Type (Kind)); - New_Assign_Stmt - (New_Selected_Element (New_Obj (Res_D), - Slice_Info.T.Bounds_Field (Kind)), - New_Value (M2Lp (Data.Slice_Range))); - New_Assign_Stmt - (New_Selected_Element (New_Obj (Res_D), - Slice_Info.T.Base_Field (Kind)), - M2E (Chap3.Slice_Base - (Chap3.Get_Array_Base (Prefix), - Slice_Type, - New_Obj_Value (Data.Unsigned_Diff)))); - return Dv2M (Res_D, Slice_Info, Kind); - when Type_Mode_Array => - return Chap3.Slice_Base - (Chap3.Get_Array_Base (Prefix), - Slice_Type, - New_Obj_Value (Data.Unsigned_Diff)); - when others => - raise Internal_Error; - end case; - end if; - end Translate_Slice_Name_Finish; - - function Translate_Slice_Name (Prefix : Mnode; Expr : Iir_Slice_Name) - return Mnode - is - Data : Slice_Name_Data; - begin - Translate_Slice_Name_Init (Prefix, Expr, Data); - return Translate_Slice_Name_Finish (Data.Prefix_Var, Expr, Data); - end Translate_Slice_Name; - - function Translate_Interface_Name - (Inter : Iir; Info : Ortho_Info_Acc; Kind : Object_Kind_Type) - return Mnode - is - Type_Info : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); - begin - case Info.Kind is - when Kind_Object => - -- For a generic or a port. - return Get_Var (Info.Object_Var, Type_Info, Kind); - when Kind_Interface => - -- For a parameter. - if Info.Interface_Field = O_Fnode_Null then - -- Normal case: the parameter was translated as an ortho - -- interface. - case Type_Info.Type_Mode is - when Type_Mode_Unknown => - raise Internal_Error; - when Type_Mode_By_Value => - return Dv2M (Info.Interface_Node, Type_Info, Kind); - when Type_Mode_By_Copy - | Type_Mode_By_Ref => - -- Parameter is passed by reference. - return Dp2M (Info.Interface_Node, Type_Info, Kind); - end case; - else - -- The parameter was put somewhere else. - declare - Subprg : constant Iir := Get_Parent (Inter); - Subprg_Info : constant Subprg_Info_Acc := - Get_Info (Subprg); - Linter : O_Lnode; - begin - if Info.Interface_Node = O_Dnode_Null then - -- The parameter is passed via a field of the RESULT - -- record parameter. - if Subprg_Info.Res_Record_Var = Null_Var then - Linter := New_Obj (Subprg_Info.Res_Interface); - else - -- Unnesting case. - Linter := Get_Var (Subprg_Info.Res_Record_Var); - end if; - return Lv2M (New_Selected_Element - (New_Acc_Value (Linter), - Info.Interface_Field), - Type_Info, Kind); - else - -- Unnesting case: the parameter was copied in the - -- subprogram frame so that nested subprograms can - -- reference it. Use field in FRAME. - Linter := New_Selected_Element - (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Scope), - Info.Interface_Field); - case Type_Info.Type_Mode is - when Type_Mode_Unknown => - raise Internal_Error; - when Type_Mode_By_Value => - return Lv2M (Linter, Type_Info, Kind); - when Type_Mode_By_Copy - | Type_Mode_By_Ref => - -- Parameter is passed by reference. - return Lp2M (Linter, Type_Info, Kind); - end case; - end if; - end; - end if; - when others => - raise Internal_Error; - end case; - end Translate_Interface_Name; - - function Translate_Selected_Element (Prefix : Mnode; - El : Iir_Element_Declaration) - return Mnode - is - El_Info : constant Field_Info_Acc := Get_Info (El); - El_Type : constant Iir := Get_Type (El); - El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); - Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); - Stable_Prefix : Mnode; - begin - if Is_Complex_Type (El_Tinfo) then - -- The element is in fact an offset. - Stable_Prefix := Stabilize (Prefix); - return E2M - (New_Unchecked_Address - (New_Slice - (New_Access_Element - (New_Unchecked_Address - (M2Lv (Stable_Prefix), Char_Ptr_Type)), - Chararray_Type, - New_Value - (New_Selected_Element (M2Lv (Stable_Prefix), - El_Info.Field_Node (Kind)))), - El_Tinfo.Ortho_Ptr_Type (Kind)), - El_Tinfo, Kind); - else - return Lv2M (New_Selected_Element (M2Lv (Prefix), - El_Info.Field_Node (Kind)), - El_Tinfo, Kind); - end if; - end Translate_Selected_Element; - --- function Translate_Formal_Interface_Name (Scope_Type : O_Tnode; --- Scope_Param : O_Lnode; --- Name : Iir; --- Kind : Object_Kind_Type) --- return Mnode --- is --- Type_Info : Type_Info_Acc; --- Info : Ortho_Info_Acc; --- Res : Mnode; --- begin --- Type_Info := Get_Info (Get_Type (Name)); --- Info := Get_Info (Name); --- Push_Scope_Soft (Scope_Type, Scope_Param); --- Res := Get_Var (Info.Object_Var, Type_Info, Kind); --- Clear_Scope_Soft (Scope_Type); --- return Res; --- end Translate_Formal_Interface_Name; - --- function Translate_Formal_Name (Scope_Type : O_Tnode; --- Scope_Param : O_Lnode; --- Name : Iir) --- return Mnode --- is --- Prefix : Iir; --- Prefix_Name : Mnode; --- begin --- case Get_Kind (Name) is --- when Iir_Kind_Interface_Constant_Declaration => --- return Translate_Formal_Interface_Name --- (Scope_Type, Scope_Param, Name, Mode_Value); - --- when Iir_Kind_Interface_Signal_Declaration => --- return Translate_Formal_Interface_Name --- (Scope_Type, Scope_Param, Name, Mode_Signal); - --- when Iir_Kind_Indexed_Name => --- Prefix := Get_Prefix (Name); --- Prefix_Name := Translate_Formal_Name --- (Scope_Type, Scope_Param, Prefix); --- return Translate_Indexed_Name (Prefix_Name, Name); - --- when Iir_Kind_Slice_Name => --- Prefix := Get_Prefix (Name); --- Prefix_Name := Translate_Formal_Name --- (Scope_Type, Scope_Param, Prefix); --- return Translate_Slice_Name (Prefix_Name, Name); - --- when Iir_Kind_Selected_Element => --- Prefix := Get_Prefix (Name); --- Prefix_Name := Translate_Formal_Name --- (Scope_Type, Scope_Param, Prefix); --- return Translate_Selected_Element --- (Prefix_Name, Get_Selected_Element (Name)); - --- when others => --- Error_Kind ("translate_generic_name", Name); --- end case; --- end Translate_Formal_Name; - - function Translate_Name (Name : Iir) return Mnode - is - Name_Type : constant Iir := Get_Type (Name); - Name_Info : constant Ortho_Info_Acc := Get_Info (Name); - Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); - begin - case Get_Kind (Name) is - when Iir_Kind_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration => - return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Value); - - when Iir_Kind_Attribute_Name => - return Translate_Name (Get_Named_Entity (Name)); - when Iir_Kind_Attribute_Value => - return Get_Var - (Get_Info (Get_Attribute_Specification (Name)).Object_Var, - Type_Info, Mode_Value); - - when Iir_Kind_Object_Alias_Declaration => - -- Alias_Var is not like an object variable, since it is - -- always a pointer to the aliased object. - declare - R : O_Lnode; - begin - R := Get_Var (Name_Info.Alias_Var); - case Type_Info.Type_Mode is - when Type_Mode_Fat_Array => - return Get_Var (Name_Info.Alias_Var, Type_Info, - Name_Info.Alias_Kind); - when Type_Mode_Array - | Type_Mode_Record - | Type_Mode_Acc - | Type_Mode_Fat_Acc => - R := Get_Var (Name_Info.Alias_Var); - return Lp2M (R, Type_Info, Name_Info.Alias_Kind); - when Type_Mode_Scalar => - R := Get_Var (Name_Info.Alias_Var); - if Name_Info.Alias_Kind = Mode_Signal then - return Lv2M (R, Type_Info, Name_Info.Alias_Kind); - else - return Lp2M (R, Type_Info, Name_Info.Alias_Kind); - end if; - when others => - raise Internal_Error; - end case; - end; - - when Iir_Kind_Signal_Declaration - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Guard_Signal_Declaration => - return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); - - when Iir_Kind_Interface_Constant_Declaration => - return Translate_Interface_Name (Name, Name_Info, Mode_Value); - - when Iir_Kind_Interface_File_Declaration => - return Translate_Interface_Name (Name, Name_Info, Mode_Value); - - when Iir_Kind_Interface_Variable_Declaration => - return Translate_Interface_Name (Name, Name_Info, Mode_Value); - - when Iir_Kind_Interface_Signal_Declaration => - return Translate_Interface_Name (Name, Name_Info, Mode_Signal); - - when Iir_Kind_Indexed_Name => - return Translate_Indexed_Name - (Translate_Name (Get_Prefix (Name)), Name); - - when Iir_Kind_Slice_Name => - return Translate_Slice_Name - (Translate_Name (Get_Prefix (Name)), Name); - - when Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference => - declare - Pfx : O_Enode; - begin - Pfx := Chap7.Translate_Expression (Get_Prefix (Name)); - -- FIXME: what about fat pointer ?? - return Lv2M (New_Access_Element (Pfx), - Type_Info, Mode_Value); - end; - - when Iir_Kind_Selected_Element => - return Translate_Selected_Element - (Translate_Name (Get_Prefix (Name)), - Get_Selected_Element (Name)); - - when Iir_Kind_Function_Call => - -- This can appear as a prefix of a name, therefore, the - -- result is always a composite type or an access type. - declare - Imp : constant Iir := Get_Implementation (Name); - Obj : Iir; - Assoc_Chain : Iir; - begin - if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration - then - -- FIXME : to be done - raise Internal_Error; - else - Canon.Canon_Subprogram_Call (Name); - Assoc_Chain := Get_Parameter_Association_Chain (Name); - Obj := Get_Method_Object (Name); - return E2M - (Chap7.Translate_Function_Call (Imp, Assoc_Chain, Obj), - Type_Info, Mode_Value); - end if; - end; - - when Iir_Kind_Image_Attribute => - -- Can appear as a prefix. - return E2M (Chap14.Translate_Image_Attribute (Name), - Type_Info, Mode_Value); - - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - return Translate_Name (Get_Named_Entity (Name)); - - when others => - Error_Kind ("translate_name", Name); - end case; - end Translate_Name; - - procedure Translate_Direct_Driver - (Name : Iir; Sig : out Mnode; Drv : out Mnode) - is - Name_Type : constant Iir := Get_Type (Name); - Name_Info : constant Ortho_Info_Acc := Get_Info (Name); - Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); - begin - case Get_Kind (Name) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - Translate_Direct_Driver (Get_Named_Entity (Name), Sig, Drv); - when Iir_Kind_Object_Alias_Declaration => - Translate_Direct_Driver (Get_Name (Name), Sig, Drv); - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration => - Sig := Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); - Drv := Get_Var (Name_Info.Object_Driver, Type_Info, Mode_Value); - when Iir_Kind_Slice_Name => - declare - Data : Slice_Name_Data; - Pfx_Sig : Mnode; - Pfx_Drv : Mnode; - begin - Translate_Direct_Driver - (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); - Translate_Slice_Name_Init (Pfx_Sig, Name, Data); - Sig := Translate_Slice_Name_Finish - (Data.Prefix_Var, Name, Data); - Drv := Translate_Slice_Name_Finish (Pfx_Drv, Name, Data); - end; - when Iir_Kind_Indexed_Name => - declare - Data : Indexed_Name_Data; - Pfx_Sig : Mnode; - Pfx_Drv : Mnode; - begin - Translate_Direct_Driver - (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); - Data := Translate_Indexed_Name_Init (Pfx_Sig, Name); - Sig := Data.Res; - Drv := Translate_Indexed_Name_Finish (Pfx_Drv, Name, Data); - end; - when Iir_Kind_Selected_Element => - declare - El : Iir; - Pfx_Sig : Mnode; - Pfx_Drv : Mnode; - begin - Translate_Direct_Driver - (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); - El := Get_Selected_Element (Name); - Sig := Translate_Selected_Element (Pfx_Sig, El); - Drv := Translate_Selected_Element (Pfx_Drv, El); - end; - when others => - Error_Kind ("translate_direct_driver", Name); - end case; - end Translate_Direct_Driver; - end Chap6; - - package body Chap7 is - function Is_Static_Constant (Decl : Iir_Constant_Declaration) - return Boolean - is - Expr : constant Iir := Get_Default_Value (Decl); - Atype : Iir; - Info : Iir; - begin - if Expr = Null_Iir - or else Get_Kind (Expr) = Iir_Kind_Overflow_Literal - then - -- Deferred constant. - return False; - end if; - - if Get_Expr_Staticness (Decl) = Locally then - return True; - end if; - - -- Only aggregates are handled. - if Get_Kind (Expr) /= Iir_Kind_Aggregate then - return False; - end if; - - Atype := Get_Type (Decl); - -- Bounds must be known (and static). - if Get_Type_Staticness (Atype) /= Locally then - return False; - end if; - - -- Currently, only array aggregates are handled. - if Get_Kind (Get_Base_Type (Atype)) /= Iir_Kind_Array_Type_Definition - then - return False; - end if; - - -- Aggregate elements must be locally static. - -- Note: this does not yet handled aggregates of aggregates. - if Get_Value_Staticness (Expr) /= Locally then - return False; - end if; - Info := Get_Aggregate_Info (Expr); - while Info /= Null_Iir loop - if Get_Aggr_Dynamic_Flag (Info) then - raise Internal_Error; - end if; - - -- Currently, only positionnal aggregates are handled. - if Get_Aggr_Named_Flag (Info) then - return False; - end if; - -- Currently, others choice are not handled. - if Get_Aggr_Others_Flag (Info) then - return False; - end if; - - Info := Get_Sub_Aggregate_Info (Info); - end loop; - return True; - end Is_Static_Constant; - - procedure Translate_Static_String_Literal_Inner - (List : in out O_Array_Aggr_List; - Str : Iir; - El_Type : Iir) - is - use Name_Table; - - Literal_List : Iir_List; - Lit : Iir; - Len : Nat32; - Ptr : String_Fat_Acc; - begin - Literal_List := - Get_Enumeration_Literal_List (Get_Base_Type (El_Type)); - Len := Get_String_Length (Str); - Ptr := Get_String_Fat_Acc (Str); - for I in 1 .. Len loop - Lit := Find_Name_In_List (Literal_List, Get_Identifier (Ptr (I))); - New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); - end loop; - end Translate_Static_String_Literal_Inner; - - procedure Translate_Static_Bit_String_Literal_Inner - (List : in out O_Array_Aggr_List; - Lit : Iir_Bit_String_Literal; - El_Type : Iir) - is - pragma Unreferenced (El_Type); - L_0 : O_Cnode; - L_1 : O_Cnode; - Ptr : String_Fat_Acc; - Len : Nat32; - V : O_Cnode; - begin - L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit)); - L_1 := Get_Ortho_Expr (Get_Bit_String_1 (Lit)); - Ptr := Get_String_Fat_Acc (Lit); - Len := Get_String_Length (Lit); - for I in 1 .. Len loop - case Ptr (I) is - when '0' => - V := L_0; - when '1' => - V := L_1; - when others => - raise Internal_Error; - end case; - New_Array_Aggr_El (List, V); - end loop; - end Translate_Static_Bit_String_Literal_Inner; - - procedure Translate_Static_Aggregate_1 (List : in out O_Array_Aggr_List; - Aggr : Iir; - Info : Iir; - El_Type : Iir) - is - Assoc : Iir; - N_Info : Iir; - Sub : Iir; - begin - N_Info := Get_Sub_Aggregate_Info (Info); - - case Get_Kind (Aggr) is - when Iir_Kind_Aggregate => - Assoc := Get_Association_Choices_Chain (Aggr); - while Assoc /= Null_Iir loop - Sub := Get_Associated_Expr (Assoc); - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - if N_Info = Null_Iir then - New_Array_Aggr_El - (List, - Translate_Static_Expression (Sub, El_Type)); - else - Translate_Static_Aggregate_1 - (List, Sub, N_Info, El_Type); - end if; - when others => - Error_Kind ("translate_static_aggregate_1(2)", Assoc); - end case; - Assoc := Get_Chain (Assoc); - end loop; - when Iir_Kind_String_Literal => - if N_Info /= Null_Iir then - raise Internal_Error; - end if; - Translate_Static_String_Literal_Inner (List, Aggr, El_Type); - when Iir_Kind_Bit_String_Literal => - if N_Info /= Null_Iir then - raise Internal_Error; - end if; - Translate_Static_Bit_String_Literal_Inner (List, Aggr, El_Type); - when others => - Error_Kind ("translate_static_aggregate_1", Aggr); - end case; - end Translate_Static_Aggregate_1; - - function Translate_Static_Aggregate (Aggr : Iir) - return O_Cnode - is - Aggr_Type : constant Iir := Get_Type (Aggr); - El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); - List : O_Array_Aggr_List; - Res : O_Cnode; - begin - Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); - Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); - - Translate_Static_Aggregate_1 - (List, Aggr, Get_Aggregate_Info (Aggr), El_Type); - Finish_Array_Aggr (List, Res); - return Res; - end Translate_Static_Aggregate; - - function Translate_Static_Simple_Aggregate (Aggr : Iir) - return O_Cnode - is - Aggr_Type : Iir; - El_List : Iir_List; - El : Iir; - El_Type : Iir; - List : O_Array_Aggr_List; - Res : O_Cnode; - begin - Aggr_Type := Get_Type (Aggr); - Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); - El_Type := Get_Element_Subtype (Aggr_Type); - El_List := Get_Simple_Aggregate_List (Aggr); - Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); - - for I in Natural loop - El := Get_Nth_Element (El_List, I); - exit when El = Null_Iir; - New_Array_Aggr_El - (List, Translate_Static_Expression (El, El_Type)); - end loop; - - Finish_Array_Aggr (List, Res); - return Res; - end Translate_Static_Simple_Aggregate; - - function Translate_Static_String_Literal (Str : Iir) - return O_Cnode - is - use Name_Table; - - Lit_Type : Iir; - Element_Type : Iir; - Arr_Type : O_Tnode; - List : O_Array_Aggr_List; - Res : O_Cnode; - begin - Lit_Type := Get_Type (Str); - - Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); - Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value); - - Start_Array_Aggr (List, Arr_Type); - - Element_Type := Get_Element_Subtype (Lit_Type); - - Translate_Static_String_Literal_Inner (List, Str, Element_Type); - - Finish_Array_Aggr (List, Res); - return Res; - end Translate_Static_String_Literal; - - -- Create a variable (constant) for string or bit string literal STR. - -- The type of the literal element is ELEMENT_TYPE, and the ortho type - -- of the string (a constrained array type) is STR_TYPE. - function Create_String_Literal_Var_Inner - (Str : Iir; Element_Type : Iir; Str_Type : O_Tnode) - return Var_Type - is - use Name_Table; - - Val_Aggr : O_Array_Aggr_List; - Res : O_Cnode; - begin - Start_Array_Aggr (Val_Aggr, Str_Type); - case Get_Kind (Str) is - when Iir_Kind_String_Literal => - Translate_Static_String_Literal_Inner - (Val_Aggr, Str, Element_Type); - when Iir_Kind_Bit_String_Literal => - Translate_Static_Bit_String_Literal_Inner - (Val_Aggr, Str, Element_Type); - when others => - raise Internal_Error; - end case; - Finish_Array_Aggr (Val_Aggr, Res); - - return Create_Global_Const - (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res); - end Create_String_Literal_Var_Inner; - - -- Create a variable (constant) for string or bit string literal STR. - function Create_String_Literal_Var (Str : Iir) return Var_Type is - use Name_Table; - - Str_Type : constant Iir := Get_Type (Str); - Arr_Type : O_Tnode; - begin - -- Create the string value. - Arr_Type := New_Constrained_Array_Type - (Get_Info (Str_Type).T.Base_Type (Mode_Value), - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Get_String_Length (Str)))); - - return Create_String_Literal_Var_Inner - (Str, Get_Element_Subtype (Str_Type), Arr_Type); - end Create_String_Literal_Var; - - -- Some strings literal have an unconstrained array type, - -- eg: 'image of constant. Its type is not constrained - -- because it is not so in VHDL! - function Translate_Non_Static_String_Literal (Str : Iir) - return O_Enode - is - use Name_Table; - - Lit_Type : constant Iir := Get_Type (Str); - Type_Info : constant Type_Info_Acc := Get_Info (Lit_Type); - Index_Type : constant Iir := Get_Index_Type (Lit_Type, 0); - Index_Type_Info : constant Type_Info_Acc := Get_Info (Index_Type); - Bound_Aggr : O_Record_Aggr_List; - Index_Aggr : O_Record_Aggr_List; - Res_Aggr : O_Record_Aggr_List; - Res : O_Cnode; - Len : Int32; - Val : Var_Type; - Bound : Var_Type; - R : O_Enode; - begin - -- Create the string value. - Len := Get_String_Length (Str); - Val := Create_String_Literal_Var (Str); - - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - -- Create the string bound. - Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type); - Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type); - New_Record_Aggr_El - (Index_Aggr, - New_Signed_Literal - (Index_Type_Info.Ortho_Type (Mode_Value), 0)); - New_Record_Aggr_El - (Index_Aggr, - New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value), - Integer_64 (Len - 1))); - New_Record_Aggr_El - (Index_Aggr, Ghdl_Dir_To_Node); - New_Record_Aggr_El - (Index_Aggr, - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); - Finish_Record_Aggr (Index_Aggr, Res); - New_Record_Aggr_El (Bound_Aggr, Res); - Finish_Record_Aggr (Bound_Aggr, Res); - Bound := Create_Global_Const - (Create_Uniq_Identifier, Type_Info.T.Bounds_Type, - O_Storage_Private, Res); - - -- The descriptor. - Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value)); - New_Record_Aggr_El - (Res_Aggr, - New_Global_Address (Get_Var_Label (Val), - Type_Info.T.Base_Ptr_Type (Mode_Value))); - New_Record_Aggr_El - (Res_Aggr, - New_Global_Address (Get_Var_Label (Bound), - Type_Info.T.Bounds_Ptr_Type)); - Finish_Record_Aggr (Res_Aggr, Res); - - Val := Create_Global_Const - (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), - O_Storage_Private, Res); - elsif Type_Info.Type_Mode = Type_Mode_Array then - -- Type of string literal isn't statically known; check the - -- length. - Chap6.Check_Bound_Error - (New_Compare_Op - (ON_Neq, - New_Lit (New_Index_Lit (Unsigned_64 (Len))), - Chap3.Get_Array_Type_Length (Lit_Type), - Ghdl_Bool_Type), - Str, 1); - else - raise Internal_Error; - end if; - - R := New_Address (Get_Var (Val), - Type_Info.Ortho_Ptr_Type (Mode_Value)); - return R; - end Translate_Non_Static_String_Literal; - - -- Only for Strings of STD.Character. - function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id) - return O_Cnode - is - use Name_Table; - - Literal_List : Iir_List; - Lit : Iir; - List : O_Array_Aggr_List; - Res : O_Cnode; - begin - Chap3.Translate_Anonymous_Type_Definition (Str_Type, True); - - Start_Array_Aggr (List, Get_Ortho_Type (Str_Type, Mode_Value)); - - Literal_List := - Get_Enumeration_Literal_List (Character_Type_Definition); - Image (Str_Ident); - for I in 1 .. Name_Length loop - Lit := Get_Nth_Element (Literal_List, - Character'Pos (Name_Buffer (I))); - New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); - end loop; - - Finish_Array_Aggr (List, Res); - return Res; - end Translate_Static_String; - - function Translate_Static_Bit_String_Literal - (Lit : Iir_Bit_String_Literal) - return O_Cnode - is - Lit_Type : Iir; - Res : O_Cnode; - List : O_Array_Aggr_List; - begin - Lit_Type := Get_Type (Lit); - Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); - Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); - Translate_Static_Bit_String_Literal_Inner (List, Lit, Lit_Type); - Finish_Array_Aggr (List, Res); - return Res; - end Translate_Static_Bit_String_Literal; - - function Translate_String_Literal (Str : Iir) return O_Enode - is - Str_Type : constant Iir := Get_Type (Str); - Var : Var_Type; - Info : Type_Info_Acc; - Res : O_Cnode; - R : O_Enode; - begin - if Get_Constraint_State (Str_Type) = Fully_Constrained - and then - Get_Type_Staticness (Get_Index_Type (Str_Type, 0)) = Locally - then - Chap3.Create_Array_Subtype (Str_Type, True); - case Get_Kind (Str) is - when Iir_Kind_String_Literal => - Res := Translate_Static_String_Literal (Str); - when Iir_Kind_Bit_String_Literal => - Res := Translate_Static_Bit_String_Literal (Str); - when Iir_Kind_Simple_Aggregate => - Res := Translate_Static_Simple_Aggregate (Str); - when Iir_Kind_Simple_Name_Attribute => - Res := Translate_Static_String - (Get_Type (Str), Get_Simple_Name_Identifier (Str)); - when others => - raise Internal_Error; - end case; - Info := Get_Info (Str_Type); - Var := Create_Global_Const - (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), - O_Storage_Private, Res); - R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); - return R; - else - return Translate_Non_Static_String_Literal (Str); - end if; - end Translate_String_Literal; - - function Translate_Static_Implicit_Conv - (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) return O_Cnode - is - Expr_Info : Type_Info_Acc; - Res_Info : Type_Info_Acc; - Val : Var_Type; - Res : O_Cnode; - List : O_Record_Aggr_List; - Bound : Var_Type; - begin - if Res_Type = Expr_Type then - return Expr; - end if; - if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then - raise Internal_Error; - end if; - if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition then - return Expr; - end if; - if Get_Kind (Res_Type) /= Iir_Kind_Array_Type_Definition then - raise Internal_Error; - end if; - Expr_Info := Get_Info (Expr_Type); - Res_Info := Get_Info (Res_Type); - Val := Create_Global_Const - (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), - O_Storage_Private, Expr); - Bound := Expr_Info.T.Array_Bounds; - if Bound = Null_Var then - Bound := Create_Global_Const - (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type, - O_Storage_Private, - Chap3.Create_Static_Array_Subtype_Bounds (Expr_Type)); - Expr_Info.T.Array_Bounds := Bound; - end if; - - Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); - New_Record_Aggr_El - (List, New_Global_Address (Get_Var_Label (Val), - Res_Info.T.Base_Ptr_Type (Mode_Value))); - New_Record_Aggr_El - (List, New_Global_Address (Get_Var_Label (Bound), - Expr_Info.T.Bounds_Ptr_Type)); - Finish_Record_Aggr (List, Res); - return Res; - end Translate_Static_Implicit_Conv; - - function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) - return O_Cnode - is - begin - case Get_Kind (Expr) is - when Iir_Kind_Integer_Literal => - return New_Signed_Literal - (Res_Type, Integer_64 (Get_Value (Expr))); - - when Iir_Kind_Enumeration_Literal => - return Get_Ortho_Expr (Get_Enumeration_Decl (Expr)); - - when Iir_Kind_Floating_Point_Literal => - return New_Float_Literal - (Res_Type, IEEE_Float_64 (Get_Fp_Value (Expr))); - - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal - | Iir_Kind_Unit_Declaration => - return New_Signed_Literal - (Res_Type, Integer_64 (Get_Physical_Value (Expr))); - - when others => - Error_Kind ("translate_numeric_literal", Expr); - end case; - exception - when Constraint_Error => - -- Can be raised by Get_Physical_Unit_Value because of the kludge - -- on staticness. - Error_Msg_Elab ("numeric literal not in range", Expr); - return New_Signed_Literal (Res_Type, 0); - end Translate_Numeric_Literal; - - function Translate_Numeric_Literal (Expr : Iir; Res_Type : Iir) - return O_Cnode - is - Expr_Type : Iir; - Expr_Otype : O_Tnode; - Tinfo : Type_Info_Acc; - begin - Expr_Type := Get_Type (Expr); - Tinfo := Get_Info (Expr_Type); - if Res_Type /= Null_Iir then - Expr_Otype := Get_Ortho_Type (Res_Type, Mode_Value); - else - if Tinfo = null then - -- FIXME: this is a working kludge, in the case where EXPR_TYPE - -- is a subtype which was not yet translated. - -- (eg: evaluated array attribute) - Tinfo := Get_Info (Get_Base_Type (Expr_Type)); - end if; - Expr_Otype := Tinfo.Ortho_Type (Mode_Value); - end if; - return Translate_Numeric_Literal (Expr, Expr_Otype); - end Translate_Numeric_Literal; - - function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) - return O_Cnode - is - Expr_Type : constant Iir := Get_Type (Expr); - begin - case Get_Kind (Expr) is - when Iir_Kind_Integer_Literal - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Floating_Point_Literal - | Iir_Kind_Physical_Int_Literal - | Iir_Kind_Unit_Declaration - | Iir_Kind_Physical_Fp_Literal => - return Translate_Numeric_Literal (Expr, Res_Type); - - when Iir_Kind_String_Literal => - return Translate_Static_Implicit_Conv - (Translate_Static_String_Literal (Expr), Expr_Type, Res_Type); - when Iir_Kind_Bit_String_Literal => - return Translate_Static_Implicit_Conv - (Translate_Static_Bit_String_Literal (Expr), - Expr_Type, Res_Type); - when Iir_Kind_Simple_Aggregate => - return Translate_Static_Implicit_Conv - (Translate_Static_Simple_Aggregate (Expr), - Expr_Type, Res_Type); - when Iir_Kind_Aggregate => - return Translate_Static_Implicit_Conv - (Translate_Static_Aggregate (Expr), Expr_Type, Res_Type); - - when Iir_Kinds_Denoting_Name => - return Translate_Static_Expression - (Get_Named_Entity (Expr), Res_Type); - when others => - Error_Kind ("translate_static_expression", Expr); - end case; - end Translate_Static_Expression; - - function Translate_Static_Range_Left - (Expr : Iir; Range_Type : Iir := Null_Iir) - return O_Cnode - is - Left : O_Cnode; - Bound : Iir; - begin - Bound := Get_Left_Limit (Expr); - Left := Chap7.Translate_Static_Expression (Bound, Range_Type); --- if Range_Type /= Null_Iir and then Get_Type (Bound) /= Range_Type then --- Left := New_Convert_Ov --- (Left, Get_Ortho_Type (Range_Type, Mode_Value)); --- end if; - return Left; - end Translate_Static_Range_Left; - - function Translate_Static_Range_Right - (Expr : Iir; Range_Type : Iir := Null_Iir) - return O_Cnode - is - Right : O_Cnode; - begin - Right := Chap7.Translate_Static_Expression (Get_Right_Limit (Expr), - Range_Type); --- if Range_Type /= Null_Iir then --- Right := New_Convert_Ov --- (Right, Get_Ortho_Type (Range_Type, Mode_Value)); --- end if; - return Right; - end Translate_Static_Range_Right; - - function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode - is - begin - case Get_Direction (Expr) is - when Iir_To => - return Ghdl_Dir_To_Node; - when Iir_Downto => - return Ghdl_Dir_Downto_Node; - end case; - end Translate_Static_Range_Dir; - - function Translate_Static_Range_Length (Expr : Iir) return O_Cnode - is - Ulen : Unsigned_64; - begin - Ulen := Unsigned_64 (Eval_Discrete_Range_Length (Expr)); - return New_Unsigned_Literal (Ghdl_Index_Type, Ulen); - end Translate_Static_Range_Length; - - function Translate_Range_Expression_Left (Expr : Iir; - Range_Type : Iir := Null_Iir) - return O_Enode - is - Left : O_Enode; - begin - Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); - if Range_Type /= Null_Iir then - Left := New_Convert_Ov (Left, - Get_Ortho_Type (Range_Type, Mode_Value)); - end if; - return Left; - end Translate_Range_Expression_Left; - - function Translate_Range_Expression_Right (Expr : Iir; - Range_Type : Iir := Null_Iir) - return O_Enode - is - Right : O_Enode; - begin - Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); - if Range_Type /= Null_Iir then - Right := New_Convert_Ov (Right, - Get_Ortho_Type (Range_Type, Mode_Value)); - end if; - return Right; - end Translate_Range_Expression_Right; - - -- Compute the length of LEFT DIR (to/downto) RIGHT. - function Compute_Range_Length - (Left : O_Enode; Right : O_Enode; Dir : Iir_Direction) - return O_Enode - is - L : O_Enode; - R : O_Enode; - Val : O_Enode; - Tmp : O_Dnode; - Res : O_Dnode; - If_Blk : O_If_Block; - Rng_Type : O_Tnode; - begin - Rng_Type := Ghdl_I32_Type; - L := New_Convert_Ov (Left, Rng_Type); - R := New_Convert_Ov (Right, Rng_Type); - - case Dir is - when Iir_To => - Val := New_Dyadic_Op (ON_Sub_Ov, R, L); - when Iir_Downto => - Val := New_Dyadic_Op (ON_Sub_Ov, L, R); - end case; - - Res := Create_Temp (Ghdl_Index_Type); - Open_Temp; - Tmp := Create_Temp (Rng_Type); - New_Assign_Stmt (New_Obj (Tmp), Val); - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Lt, New_Obj_Value (Tmp), - New_Lit (New_Signed_Literal (Rng_Type, 0)), - Ghdl_Bool_Type)); - Init_Var (Res); - New_Else_Stmt (If_Blk); - Val := New_Convert_Ov (New_Obj_Value (Tmp), Ghdl_Index_Type); - Val := New_Dyadic_Op (ON_Add_Ov, Val, New_Lit (Ghdl_Index_1)); - New_Assign_Stmt (New_Obj (Res), Val); - Finish_If_Stmt (If_Blk); - Close_Temp; - return New_Obj_Value (Res); - end Compute_Range_Length; - - function Translate_Range_Expression_Length (Expr : Iir) return O_Enode - is - Left, Right : O_Enode; - begin - if Get_Expr_Staticness (Expr) = Locally then - return New_Lit (Translate_Static_Range_Length (Expr)); - else - Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); - Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); - - return Compute_Range_Length (Left, Right, Get_Direction (Expr)); - end if; - end Translate_Range_Expression_Length; - - function Translate_Range_Length (Expr : Iir) return O_Enode is - begin - case Get_Kind (Expr) is - when Iir_Kind_Range_Expression => - return Translate_Range_Expression_Length (Expr); - when Iir_Kind_Range_Array_Attribute => - return Chap14.Translate_Length_Array_Attribute (Expr, Null_Iir); - when others => - Error_Kind ("translate_range_length", Expr); - end case; - end Translate_Range_Length; - - function Translate_Association (Assoc : Iir) return O_Enode - is - Formal : constant Iir := Get_Formal (Assoc); - Formal_Base : constant Iir := Get_Association_Interface (Assoc); - Actual : Iir; - begin - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_By_Expression => - Actual := Get_Actual (Assoc); - when Iir_Kind_Association_Element_Open => - Actual := Get_Default_Value (Formal); - when others => - Error_Kind ("translate_association", Assoc); - end case; - - case Get_Kind (Formal_Base) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - return Chap3.Maybe_Insert_Scalar_Check - (Translate_Expression (Actual, Get_Type (Formal)), - Actual, Get_Type (Formal)); - when Iir_Kind_Interface_Signal_Declaration => - return Translate_Implicit_Conv - (M2E (Chap6.Translate_Name (Actual)), - Get_Type (Actual), - Get_Type (Formal_Base), - Mode_Signal, Assoc); - when others => - Error_Kind ("translate_association", Formal); - end case; - end Translate_Association; - - function Translate_Function_Call - (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) - return O_Enode - is - Info : constant Subprg_Info_Acc := Get_Info (Imp); - Constr : O_Assoc_List; - Assoc : Iir; - Res : Mnode; - begin - if Info.Use_Stack2 then - Create_Temp_Stack2_Mark; - end if; - - if Info.Res_Interface /= O_Dnode_Null then - -- Composite result. - -- If we need to allocate, do it before starting the call! - declare - Res_Type : Iir; - Res_Info : Type_Info_Acc; - begin - Res_Type := Get_Return_Type (Imp); - Res_Info := Get_Info (Res_Type); - Res := Create_Temp (Res_Info); - if Res_Info.Type_Mode /= Type_Mode_Fat_Array then - Chap4.Allocate_Complex_Object (Res_Type, Alloc_Stack, Res); - end if; - end; - end if; - - Start_Association (Constr, Info.Ortho_Func); - - if Info.Res_Interface /= O_Dnode_Null then - -- Composite result. - New_Association (Constr, M2E (Res)); - end if; - - -- If the subprogram is a method, pass the protected object. - if Obj /= Null_Iir then - New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); - else - Subprgs.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); - end if; - - Assoc := Assoc_Chain; - while Assoc /= Null_Iir loop - -- FIXME: evaluate expression before, because we - -- may allocate objects. - New_Association (Constr, Translate_Association (Assoc)); - Assoc := Get_Chain (Assoc); - end loop; - - if Info.Res_Interface /= O_Dnode_Null then - -- Composite result. - New_Procedure_Call (Constr); - return M2E (Res); - else - return New_Function_Call (Constr); - end if; - end Translate_Function_Call; - - function Translate_Operator_Function_Call - (Imp : Iir; Left : Iir; Right : Iir; Res_Type : Iir) - return O_Enode - is - function Create_Assoc (Actual : Iir; Formal : Iir) - return Iir - is - R : Iir; - begin - R := Create_Iir (Iir_Kind_Association_Element_By_Expression); - Location_Copy (R, Actual); - Set_Actual (R, Actual); - Set_Formal (R, Formal); - return R; - end Create_Assoc; - - Inter : Iir; - El_L : Iir; - El_R : Iir; - Res : O_Enode; - begin - Inter := Get_Interface_Declaration_Chain (Imp); - - El_L := Create_Assoc (Left, Inter); - - if Right /= Null_Iir then - Inter := Get_Chain (Inter); - El_R := Create_Assoc (Right, Inter); - Set_Chain (El_L, El_R); - end if; - - Res := Translate_Function_Call (Imp, El_L, Null_Iir); - - Free_Iir (El_L); - if Right /= Null_Iir then - Free_Iir (El_R); - end if; - - return Translate_Implicit_Conv - (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Left); - end Translate_Operator_Function_Call; - - function Convert_Constrained_To_Unconstrained - (Expr : Mnode; Res_Type : Iir) - return Mnode - is - Type_Info : constant Type_Info_Acc := Get_Info (Res_Type); - Kind : constant Object_Kind_Type := Get_Object_Kind (Expr); - Stable_Expr : Mnode; - Res : Mnode; - begin - Res := Create_Temp (Type_Info, Kind); - Stable_Expr := Stabilize (Expr); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Base (Res)), - New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (Stable_Expr)), - Type_Info.T.Base_Ptr_Type (Kind))); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Res)), - M2Addr (Chap3.Get_Array_Bounds (Stable_Expr))); - return Res; - end Convert_Constrained_To_Unconstrained; - - function Convert_Array_To_Thin_Array (Expr : Mnode; - Expr_Type : Iir; - Atype : Iir; - Loc : Iir) - return Mnode - is - Expr_Indexes : constant Iir_List := - Get_Index_Subtype_List (Expr_Type); - Expr_Stable : Mnode; - Success_Label, Failure_Label : O_Snode; - begin - Expr_Stable := Stabilize (Expr); - - Open_Temp; - -- Check each dimension. - Start_Loop_Stmt (Success_Label); - Start_Loop_Stmt (Failure_Label); - for I in 1 .. Get_Nbr_Elements (Expr_Indexes) loop - Gen_Exit_When - (Failure_Label, - New_Compare_Op - (ON_Neq, - Chap6.Get_Array_Bound_Length - (Expr_Stable, Expr_Type, I), - Chap6.Get_Array_Bound_Length - (T2M (Atype, Get_Object_Kind (Expr_Stable)), Atype, I), - Ghdl_Bool_Type)); - end loop; - New_Exit_Stmt (Success_Label); - Finish_Loop_Stmt (Failure_Label); - Chap6.Gen_Bound_Error (Loc); - Finish_Loop_Stmt (Success_Label); - Close_Temp; - - return Chap3.Get_Array_Base (Expr_Stable); - end Convert_Array_To_Thin_Array; - - function Translate_Implicit_Array_Conversion - (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) - return Mnode - is - Ainfo : Type_Info_Acc; - Einfo : Type_Info_Acc; - begin - pragma Assert - (Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition); - - if Res_Type = Expr_Type then - return Expr; - end if; - - Ainfo := Get_Info (Res_Type); - Einfo := Get_Info (Expr_Type); - case Ainfo.Type_Mode is - when Type_Mode_Fat_Array => - -- X to unconstrained. - case Einfo.Type_Mode is - when Type_Mode_Fat_Array => - -- unconstrained to unconstrained. - return Expr; - when Type_Mode_Array => - -- constrained to unconstrained. - return Convert_Constrained_To_Unconstrained - (Expr, Res_Type); - when others => - raise Internal_Error; - end case; - when Type_Mode_Array => - -- X to constrained. - if Einfo.Type_Locally_Constrained - and then Ainfo.Type_Locally_Constrained - then - -- FIXME: optimize static vs non-static - -- constrained to constrained. - if not Chap3.Locally_Array_Match (Expr_Type, Res_Type) then - -- FIXME: generate a bound error ? - -- Even if this is caught at compile-time, - -- the code is not required to run. - Chap6.Gen_Bound_Error (Loc); - end if; - return Expr; - else - -- Unbounded/bounded array to bounded array. - return Convert_Array_To_Thin_Array - (Expr, Expr_Type, Res_Type, Loc); - end if; - when others => - raise Internal_Error; - end case; - end Translate_Implicit_Array_Conversion; - - -- Convert (if necessary) EXPR translated from EXPR_ORIG to type ATYPE. - function Translate_Implicit_Conv (Expr : O_Enode; - Expr_Type : Iir; - Atype : Iir; - Is_Sig : Object_Kind_Type; - Loc : Iir) - return O_Enode is - begin - -- Same type: nothing to do. - if Atype = Expr_Type then - return Expr; - end if; - - if Expr_Type = Universal_Integer_Type_Definition then - return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); - elsif Expr_Type = Universal_Real_Type_Definition then - return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); - elsif Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition then - return M2E (Translate_Implicit_Array_Conversion - (E2M (Expr, Get_Info (Expr_Type), Is_Sig), - Expr_Type, Atype, Loc)); - else - return Expr; - end if; - end Translate_Implicit_Conv; - - type Predefined_To_Onop_Type is array (Iir_Predefined_Functions) - of ON_Op_Kind; - Predefined_To_Onop : constant Predefined_To_Onop_Type := - (Iir_Predefined_Boolean_Or => ON_Or, - Iir_Predefined_Boolean_Not => ON_Not, - Iir_Predefined_Boolean_And => ON_And, - Iir_Predefined_Boolean_Xor => ON_Xor, - - Iir_Predefined_Bit_Not => ON_Not, - Iir_Predefined_Bit_And => ON_And, - Iir_Predefined_Bit_Or => ON_Or, - Iir_Predefined_Bit_Xor => ON_Xor, - - Iir_Predefined_Integer_Equality => ON_Eq, - Iir_Predefined_Integer_Inequality => ON_Neq, - Iir_Predefined_Integer_Less_Equal => ON_Le, - Iir_Predefined_Integer_Less => ON_Lt, - Iir_Predefined_Integer_Greater => ON_Gt, - Iir_Predefined_Integer_Greater_Equal => ON_Ge, - Iir_Predefined_Integer_Plus => ON_Add_Ov, - Iir_Predefined_Integer_Minus => ON_Sub_Ov, - Iir_Predefined_Integer_Mul => ON_Mul_Ov, - Iir_Predefined_Integer_Rem => ON_Rem_Ov, - Iir_Predefined_Integer_Mod => ON_Mod_Ov, - Iir_Predefined_Integer_Div => ON_Div_Ov, - Iir_Predefined_Integer_Absolute => ON_Abs_Ov, - Iir_Predefined_Integer_Negation => ON_Neg_Ov, - - Iir_Predefined_Enum_Equality => ON_Eq, - Iir_Predefined_Enum_Inequality => ON_Neq, - Iir_Predefined_Enum_Greater_Equal => ON_Ge, - Iir_Predefined_Enum_Greater => ON_Gt, - Iir_Predefined_Enum_Less => ON_Lt, - Iir_Predefined_Enum_Less_Equal => ON_Le, - - Iir_Predefined_Physical_Equality => ON_Eq, - Iir_Predefined_Physical_Inequality => ON_Neq, - Iir_Predefined_Physical_Less => ON_Lt, - Iir_Predefined_Physical_Less_Equal => ON_Le, - Iir_Predefined_Physical_Greater => ON_Gt, - Iir_Predefined_Physical_Greater_Equal => ON_Ge, - Iir_Predefined_Physical_Negation => ON_Neg_Ov, - Iir_Predefined_Physical_Absolute => ON_Abs_Ov, - Iir_Predefined_Physical_Minus => ON_Sub_Ov, - Iir_Predefined_Physical_Plus => ON_Add_Ov, - - Iir_Predefined_Floating_Greater => ON_Gt, - Iir_Predefined_Floating_Greater_Equal => ON_Ge, - Iir_Predefined_Floating_Less => ON_Lt, - Iir_Predefined_Floating_Less_Equal => ON_Le, - Iir_Predefined_Floating_Equality => ON_Eq, - Iir_Predefined_Floating_Inequality => ON_Neq, - Iir_Predefined_Floating_Minus => ON_Sub_Ov, - Iir_Predefined_Floating_Plus => ON_Add_Ov, - Iir_Predefined_Floating_Mul => ON_Mul_Ov, - Iir_Predefined_Floating_Div => ON_Div_Ov, - Iir_Predefined_Floating_Negation => ON_Neg_Ov, - Iir_Predefined_Floating_Absolute => ON_Abs_Ov, - - others => ON_Nil); - - function Translate_Shortcut_Operator - (Imp : Iir_Implicit_Function_Declaration; Left, Right : Iir) - return O_Enode - is - Rtype : Iir; - Res : O_Dnode; - Res_Type : O_Tnode; - If_Blk : O_If_Block; - Val : Integer; - V : O_Cnode; - Kind : Iir_Predefined_Functions; - Invert : Boolean; - begin - Rtype := Get_Return_Type (Imp); - Res_Type := Get_Ortho_Type (Rtype, Mode_Value); - Res := Create_Temp (Res_Type); - Open_Temp; - New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Left)); - Close_Temp; - Kind := Get_Implicit_Definition (Imp); - - -- Short cut: RIGHT is the result (and must be evaluated) iff - -- LEFT is equal to VAL (ie '0' or false for 0, '1' or true for 1). - case Kind is - when Iir_Predefined_Bit_And - | Iir_Predefined_Boolean_And => - Invert := False; - Val := 1; - when Iir_Predefined_Bit_Nand - | Iir_Predefined_Boolean_Nand => - Invert := True; - Val := 1; - when Iir_Predefined_Bit_Or - | Iir_Predefined_Boolean_Or => - Invert := False; - Val := 0; - when Iir_Predefined_Bit_Nor - | Iir_Predefined_Boolean_Nor => - Invert := True; - Val := 0; - when others => - Ada.Text_IO.Put_Line - ("translate_shortcut_operator: cannot handle " - & Iir_Predefined_Functions'Image (Kind)); - raise Internal_Error; - end case; - - V := Get_Ortho_Expr - (Get_Nth_Element (Get_Enumeration_Literal_List (Rtype), Val)); - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Eq, - New_Obj_Value (Res), New_Lit (V), - Ghdl_Bool_Type)); - Open_Temp; - New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Right)); - Close_Temp; - Finish_If_Stmt (If_Blk); - if Invert then - return New_Monadic_Op (ON_Not, New_Obj_Value (Res)); - else - return New_Obj_Value (Res); - end if; - end Translate_Shortcut_Operator; - - function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) - return O_Enode - is - Constr : O_Assoc_List; - begin - Start_Association (Constr, Func); - New_Association (Constr, Left); - if Right /= O_Enode_Null then - New_Association (Constr, Right); - end if; - return New_Function_Call (Constr); - end Translate_Lib_Operator; - - function Translate_Predefined_Lib_Operator - (Left, Right : O_Enode; Func : Iir_Implicit_Function_Declaration) - return O_Enode - is - Info : constant Subprg_Info_Acc := Get_Info (Func); - Constr : O_Assoc_List; - begin - Start_Association (Constr, Info.Ortho_Func); - Subprgs.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); - New_Association (Constr, Left); - if Right /= O_Enode_Null then - New_Association (Constr, Right); - end if; - return New_Function_Call (Constr); - end Translate_Predefined_Lib_Operator; - - function Translate_Predefined_Array_Operator - (Left, Right : O_Enode; Func : Iir) - return O_Enode - is - Res : O_Dnode; - Constr : O_Assoc_List; - Info : Type_Info_Acc; - Func_Info : Subprg_Info_Acc; - begin - Create_Temp_Stack2_Mark; - Info := Get_Info (Get_Return_Type (Func)); - Res := Create_Temp (Info.Ortho_Type (Mode_Value)); - Func_Info := Get_Info (Func); - Start_Association (Constr, Func_Info.Ortho_Func); - Subprgs.Add_Subprg_Instance_Assoc (Constr, Func_Info.Subprg_Instance); - New_Association (Constr, - New_Address (New_Obj (Res), - Info.Ortho_Ptr_Type (Mode_Value))); - New_Association (Constr, Left); - if Right /= O_Enode_Null then - New_Association (Constr, Right); - end if; - New_Procedure_Call (Constr); - return New_Address (New_Obj (Res), Info.Ortho_Ptr_Type (Mode_Value)); - end Translate_Predefined_Array_Operator; - - function Translate_Predefined_Array_Operator_Convert - (Left, Right : O_Enode; Func : Iir; Res_Type : Iir) - return O_Enode - is - Res : O_Enode; - Ret_Type : Iir; - begin - Ret_Type := Get_Return_Type (Func); - Res := Translate_Predefined_Array_Operator (Left, Right, Func); - return Translate_Implicit_Conv - (Res, Ret_Type, Res_Type, Mode_Value, Func); - end Translate_Predefined_Array_Operator_Convert; - - -- Create an array aggregate containing one element, EL. - function Translate_Element_To_Array (El : O_Enode; Arr_Type : Iir) - return O_Enode - is - Res : O_Dnode; - Ainfo : Type_Info_Acc; - Einfo : Type_Info_Acc; - V : O_Dnode; - begin - Ainfo := Get_Info (Arr_Type); - Einfo := Get_Info (Get_Element_Subtype (Arr_Type)); - Res := Create_Temp (Ainfo.Ortho_Type (Mode_Value)); - if Is_Composite (Einfo) then - New_Assign_Stmt - (New_Selected_Element (New_Obj (Res), - Ainfo.T.Base_Field (Mode_Value)), - New_Convert_Ov (El, Ainfo.T.Base_Ptr_Type (Mode_Value))); - else - V := Create_Temp_Init (Einfo.Ortho_Type (Mode_Value), El); - New_Assign_Stmt - (New_Selected_Element (New_Obj (Res), - Ainfo.T.Base_Field (Mode_Value)), - New_Convert_Ov (New_Address (New_Obj (V), - Einfo.Ortho_Ptr_Type (Mode_Value)), - Ainfo.T.Base_Ptr_Type (Mode_Value))); - end if; - New_Assign_Stmt - (New_Selected_Element (New_Obj (Res), - Ainfo.T.Bounds_Field (Mode_Value)), - New_Address (Get_Var (Ainfo.T.Array_1bound), - Ainfo.T.Bounds_Ptr_Type)); - return New_Address (New_Obj (Res), Ainfo.Ortho_Ptr_Type (Mode_Value)); - end Translate_Element_To_Array; - - function Translate_Concat_Operator - (Left_Tree, Right_Tree : O_Enode; - Imp : Iir_Implicit_Function_Declaration; - Res_Type : Iir; - Loc : Iir) - return O_Enode - is - Ret_Type : constant Iir := Get_Return_Type (Imp); - Kind : constant Iir_Predefined_Functions := - Get_Implicit_Definition (Imp); - Arr_El1 : O_Enode; - Arr_El2 : O_Enode; - Res : O_Enode; - begin - case Kind is - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Element_Element_Concat => - Arr_El1 := Translate_Element_To_Array (Left_Tree, Ret_Type); - when others => - Arr_El1 := Left_Tree; - end case; - case Kind is - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Arr_El2 := Translate_Element_To_Array (Right_Tree, Ret_Type); - when others => - Arr_El2 := Right_Tree; - end case; - Res := Translate_Predefined_Array_Operator (Arr_El1, Arr_El2, Imp); - return Translate_Implicit_Conv - (Res, Ret_Type, Res_Type, Mode_Value, Loc); - end Translate_Concat_Operator; - - function Translate_Scalar_Min_Max - (Op : ON_Op_Kind; - Left, Right : Iir; - Res_Type : Iir) - return O_Enode - is - Res_Otype : constant O_Tnode := - Get_Ortho_Type (Res_Type, Mode_Value); - Res, L, R : O_Dnode; - If_Blk : O_If_Block; - begin - -- Create a variable for the result. - Res := Create_Temp (Res_Otype); - - Open_Temp; - L := Create_Temp_Init - (Res_Otype, Translate_Expression (Left, Res_Type)); - R := Create_Temp_Init - (Res_Otype, Translate_Expression (Right, Res_Type)); - - Start_If_Stmt (If_Blk, New_Compare_Op (Op, - New_Obj_Value (L), - New_Obj_Value (R), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Obj (Res), New_Obj_Value (L)); - New_Else_Stmt (If_Blk); - New_Assign_Stmt (New_Obj (Res), New_Obj_Value (R)); - Finish_If_Stmt (If_Blk); - Close_Temp; - - return New_Obj_Value (Res); - end Translate_Scalar_Min_Max; - - function Translate_Predefined_Vector_Min_Max (Is_Min : Boolean; - Left : Iir; - Res_Type : Iir) - return O_Enode - is - Res_Otype : constant O_Tnode := - Get_Ortho_Type (Res_Type, Mode_Value); - Left_Type : constant Iir := Get_Type (Left); - Res, El, Len : O_Dnode; - Arr : Mnode; - If_Blk : O_If_Block; - Label : O_Snode; - Op : ON_Op_Kind; - begin - -- Create a variable for the result. - Res := Create_Temp (Res_Otype); - - Open_Temp; - if Is_Min then - Op := ON_Lt; - else - Op := ON_Gt; - end if; - New_Assign_Stmt - (New_Obj (Res), - Chap14.Translate_High_Low_Type_Attribute (Res_Type, Is_Min)); - - El := Create_Temp (Res_Otype); - Arr := Stabilize (E2M (Translate_Expression (Left), - Get_Info (Left_Type), Mode_Value)); - Len := Create_Temp_Init - (Ghdl_Index_Type, - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (Arr, Left_Type, 1)))); - - -- Create: - -- loop - -- exit when LEN = 0; - -- LEN := LEN - 1; - -- if ARR[LEN] </> RES then - -- RES := ARR[LEN]; - -- end if; - -- end loop; - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - Dec_Var (Len); - New_Assign_Stmt - (New_Obj (El), - M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), - Left_Type, New_Obj_Value (Len)))); - Start_If_Stmt (If_Blk, New_Compare_Op (Op, - New_Obj_Value (El), - New_Obj_Value (Res), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Obj (Res), New_Obj_Value (El)); - Finish_If_Stmt (If_Blk); - Finish_Loop_Stmt (Label); - - Close_Temp; - - return New_Obj_Value (Res); - end Translate_Predefined_Vector_Min_Max; - - function Translate_Std_Ulogic_Match (Func : O_Dnode; - L, R : O_Enode; - Res_Type : O_Tnode) - return O_Enode - is - Constr : O_Assoc_List; - begin - Start_Association (Constr, Func); - New_Association (Constr, New_Convert_Ov (L, Ghdl_I32_Type)); - New_Association (Constr, New_Convert_Ov (R, Ghdl_I32_Type)); - return New_Convert_Ov (New_Function_Call (Constr), Res_Type); - end Translate_Std_Ulogic_Match; - - function Translate_To_String (Subprg : O_Dnode; - Res_Type : Iir; - Loc : Iir; - Val : O_Enode; - Arg2 : O_Enode := O_Enode_Null; - Arg3 : O_Enode := O_Enode_Null) - return O_Enode - is - Val_Type : constant Iir := Get_Base_Type (Res_Type); - Res : O_Dnode; - Assoc : O_Assoc_List; - begin - Res := Create_Temp (Std_String_Node); - Create_Temp_Stack2_Mark; - Start_Association (Assoc, Subprg); - New_Association (Assoc, - New_Address (New_Obj (Res), Std_String_Ptr_Node)); - New_Association (Assoc, Val); - if Arg2 /= O_Enode_Null then - New_Association (Assoc, Arg2); - if Arg3 /= O_Enode_Null then - New_Association (Assoc, Arg3); - end if; - end if; - New_Procedure_Call (Assoc); - return M2E (Translate_Implicit_Array_Conversion - (Dv2M (Res, Get_Info (Val_Type), Mode_Value), - Val_Type, Res_Type, Loc)); - end Translate_To_String; - - function Translate_Bv_To_String (Subprg : O_Dnode; - Val : O_Enode; - Val_Type : Iir; - Res_Type : Iir; - Loc : Iir) - return O_Enode - is - Arr : Mnode; - begin - Arr := Stabilize (E2M (Val, Get_Info (Val_Type), Mode_Value)); - return Translate_To_String - (Subprg, Res_Type, Loc, - M2E (Chap3.Get_Array_Base (Arr)), - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (Arr, Val_Type, 1)))); - end Translate_Bv_To_String; - - subtype Predefined_Boolean_Logical is Iir_Predefined_Functions range - Iir_Predefined_Boolean_And .. Iir_Predefined_Boolean_Xnor; - - function Translate_Predefined_Logical - (Op : Predefined_Boolean_Logical; Left, Right : O_Enode) - return O_Enode is - begin - case Op is - when Iir_Predefined_Boolean_And => - return New_Dyadic_Op (ON_And, Left, Right); - when Iir_Predefined_Boolean_Or => - return New_Dyadic_Op (ON_Or, Left, Right); - when Iir_Predefined_Boolean_Nand => - return New_Monadic_Op - (ON_Not, New_Dyadic_Op (ON_And, Left, Right)); - when Iir_Predefined_Boolean_Nor => - return New_Monadic_Op - (ON_Not, New_Dyadic_Op (ON_Or, Left, Right)); - when Iir_Predefined_Boolean_Xor => - return New_Dyadic_Op (ON_Xor, Left, Right); - when Iir_Predefined_Boolean_Xnor => - return New_Monadic_Op - (ON_Not, New_Dyadic_Op (ON_Xor, Left, Right)); - end case; - end Translate_Predefined_Logical; - - function Translate_Predefined_TF_Array_Element - (Op : Predefined_Boolean_Logical; - Left, Right : Iir; - Res_Type : Iir; - Loc : Iir) - return O_Enode - is - Arr_Type : constant Iir := Get_Type (Left); - Res_Btype : constant Iir := Get_Base_Type (Res_Type); - Res_Info : constant Type_Info_Acc := Get_Info (Res_Btype); - Base_Ptr_Type : constant O_Tnode := - Res_Info.T.Base_Ptr_Type (Mode_Value); - Arr : Mnode; - El : O_Dnode; - Base : O_Dnode; - Len : O_Dnode; - Label : O_Snode; - Res : Mnode; - begin - -- Translate the array. - Arr := Stabilize (E2M (Translate_Expression (Left), - Get_Info (Arr_Type), Mode_Value)); - - -- Extract its length. - Len := Create_Temp_Init - (Ghdl_Index_Type, - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); - - -- Allocate the result array. - Base := Create_Temp_Init - (Base_Ptr_Type, - Gen_Alloc (Alloc_Stack, New_Obj_Value (Len), Base_Ptr_Type)); - - Open_Temp; - -- Translate the element. - El := Create_Temp_Init (Get_Ortho_Type (Get_Type (Right), Mode_Value), - Translate_Expression (Right)); - -- Create: - -- loop - -- exit when LEN = 0; - -- LEN := LEN - 1; - -- BASE[LEN] := EL op ARR[LEN]; - -- end loop; - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - Dec_Var (Len); - New_Assign_Stmt - (New_Indexed_Acc_Value (New_Obj (Base), - New_Obj_Value (Len)), - Translate_Predefined_Logical - (Op, - New_Obj_Value (El), - M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), - Arr_Type, New_Obj_Value (Len))))); - Finish_Loop_Stmt (Label); - Close_Temp; - - Res := Create_Temp (Res_Info, Mode_Value); - New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), - New_Obj_Value (Base)); - New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (Res)), - M2Addr (Chap3.Get_Array_Bounds (Arr))); - - return Translate_Implicit_Conv (M2E (Res), Res_Btype, Res_Type, - Mode_Value, Loc); - end Translate_Predefined_TF_Array_Element; - - function Translate_Predefined_TF_Reduction - (Op : ON_Op_Kind; Operand : Iir; Res_Type : Iir) - return O_Enode - is - Arr_Type : constant Iir := Get_Type (Operand); - Enums : constant Iir_List := - Get_Enumeration_Literal_List (Get_Base_Type (Res_Type)); - Init_Enum : Iir; - - Res : O_Dnode; - Arr_Expr : O_Enode; - Arr : Mnode; - Len : O_Dnode; - Label : O_Snode; - begin - if Op = ON_And then - Init_Enum := Get_Nth_Element (Enums, 1); - else - Init_Enum := Get_Nth_Element (Enums, 0); - end if; - - Res := Create_Temp_Init (Get_Ortho_Type (Res_Type, Mode_Value), - New_Lit (Get_Ortho_Expr (Init_Enum))); - - Open_Temp; - -- Translate the array. Note that Translate_Expression may create - -- the info for the array type, so be sure to call it before calling - -- Get_Info. - Arr_Expr := Translate_Expression (Operand); - Arr := Stabilize (E2M (Arr_Expr, Get_Info (Arr_Type), Mode_Value)); - - -- Extract its length. - Len := Create_Temp_Init - (Ghdl_Index_Type, - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); - - -- Create: - -- loop - -- exit when LEN = 0; - -- LEN := LEN - 1; - -- RES := RES op ARR[LEN]; - -- end loop; - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - Dec_Var (Len); - New_Assign_Stmt - (New_Obj (Res), - New_Dyadic_Op - (Op, - New_Obj_Value (Res), - M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), - Arr_Type, New_Obj_Value (Len))))); - Finish_Loop_Stmt (Label); - Close_Temp; - - return New_Obj_Value (Res); - end Translate_Predefined_TF_Reduction; - - function Translate_Predefined_Array_Min_Max - (Is_Min : Boolean; - Left, Right : O_Enode; - Left_Type, Right_Type : Iir; - Res_Type : Iir; - Imp : Iir; - Loc : Iir) - return O_Enode - is - Arr_Type : constant Iir := Get_Base_Type (Left_Type); - Arr_Info : constant Type_Info_Acc := Get_Info (Arr_Type); - L, R : Mnode; - If_Blk : O_If_Block; - Res : Mnode; - begin - Res := Create_Temp (Arr_Info, Mode_Value); - L := Stabilize (E2M (Left, Get_Info (Left_Type), Mode_Value)); - R := Stabilize (E2M (Right, Get_Info (Right_Type), Mode_Value)); - Start_If_Stmt - (If_Blk, - New_Compare_Op - (ON_Eq, - Translate_Predefined_Lib_Operator (M2E (L), M2E (R), Imp), - New_Lit (Ghdl_Compare_Lt), - Std_Boolean_Type_Node)); - if Is_Min then - Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion - (L, Left_Type, Arr_Type, Loc)); - else - Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion - (R, Right_Type, Arr_Type, Loc)); - end if; - New_Else_Stmt (If_Blk); - if Is_Min then - Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion - (R, Right_Type, Arr_Type, Loc)); - else - Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion - (L, Left_Type, Arr_Type, Loc)); - end if; - Finish_If_Stmt (If_Blk); - - return M2E (Translate_Implicit_Array_Conversion - (Res, Arr_Type, Res_Type, Loc)); - end Translate_Predefined_Array_Min_Max; - - function Translate_Predefined_TF_Edge - (Is_Rising : Boolean; Left : Iir) - return O_Enode - is - Enums : constant Iir_List := - Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Left))); - Name : Mnode; - begin - Name := Stabilize (Chap6.Translate_Name (Left), True); - return New_Dyadic_Op - (ON_And, - New_Value (Chap14.Get_Signal_Field - (Name, Ghdl_Signal_Event_Field)), - New_Compare_Op - (ON_Eq, - New_Value (New_Access_Element (M2E (Name))), - New_Lit (Get_Ortho_Expr - (Get_Nth_Element (Enums, Boolean'Pos (Is_Rising)))), - Std_Boolean_Type_Node)); - end Translate_Predefined_TF_Edge; - - function Translate_Predefined_Std_Ulogic_Array_Match - (Subprg : O_Dnode; Left, Right : Iir; Res_Type : Iir) - return O_Enode - is - Res_Otype : constant O_Tnode := - Get_Ortho_Type (Res_Type, Mode_Value); - L_Type : constant Iir := Get_Type (Left); - R_Type : constant Iir := Get_Type (Right); - L_Expr, R_Expr : O_Enode; - L, R : Mnode; - Assoc : O_Assoc_List; - - Res : O_Dnode; - begin - Res := Create_Temp (Ghdl_I32_Type); - - Open_Temp; - -- Translate the arrays. Note that Translate_Expression may create - -- the info for the array type, so be sure to call it before calling - -- Get_Info. - L_Expr := Translate_Expression (Left); - L := Stabilize (E2M (L_Expr, Get_Info (L_Type), Mode_Value)); - - R_Expr := Translate_Expression (Right); - R := Stabilize (E2M (R_Expr, Get_Info (R_Type), Mode_Value)); - - Start_Association (Assoc, Subprg); - New_Association - (Assoc, - New_Convert_Ov (M2E (Chap3.Get_Array_Base (L)), Ghdl_Ptr_Type)); - New_Association - (Assoc, - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (L, L_Type, 1)))); - - New_Association - (Assoc, - New_Convert_Ov (M2E (Chap3.Get_Array_Base (R)), Ghdl_Ptr_Type)); - New_Association - (Assoc, - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (R, R_Type, 1)))); - - New_Assign_Stmt (New_Obj (Res), New_Function_Call (Assoc)); - - Close_Temp; - - return New_Convert_Ov (New_Obj_Value (Res), Res_Otype); - end Translate_Predefined_Std_Ulogic_Array_Match; - - function Translate_Predefined_Operator - (Imp : Iir_Implicit_Function_Declaration; - Left, Right : Iir; - Res_Type : Iir; - Loc : Iir) - return O_Enode - is - Kind : constant Iir_Predefined_Functions := - Get_Implicit_Definition (Imp); - Left_Tree : O_Enode; - Right_Tree : O_Enode; - Left_Type : Iir; - Right_Type : Iir; - Res_Otype : O_Tnode; - Op : ON_Op_Kind; - Inter : Iir; - Res : O_Enode; - begin - case Kind is - when Iir_Predefined_Bit_And - | Iir_Predefined_Bit_Or - | Iir_Predefined_Bit_Nand - | Iir_Predefined_Bit_Nor - | Iir_Predefined_Boolean_And - | Iir_Predefined_Boolean_Or - | Iir_Predefined_Boolean_Nand - | Iir_Predefined_Boolean_Nor => - -- Right operand of shortcur operators may not be evaluated. - return Translate_Shortcut_Operator (Imp, Left, Right); - - -- Operands of min/max are evaluated in a declare block. - when Iir_Predefined_Enum_Minimum - | Iir_Predefined_Integer_Minimum - | Iir_Predefined_Floating_Minimum - | Iir_Predefined_Physical_Minimum => - return Translate_Scalar_Min_Max (ON_Le, Left, Right, Res_Type); - when Iir_Predefined_Enum_Maximum - | Iir_Predefined_Integer_Maximum - | Iir_Predefined_Floating_Maximum - | Iir_Predefined_Physical_Maximum => - return Translate_Scalar_Min_Max (ON_Ge, Left, Right, Res_Type); - - -- Avoid implicit conversion of the array parameters to the - -- unbounded type for optimizing purpose. FIXME: should do the - -- same for the result. - when Iir_Predefined_TF_Array_Element_And => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Loc); - when Iir_Predefined_TF_Element_Array_And => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Loc); - when Iir_Predefined_TF_Array_Element_Or => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Loc); - when Iir_Predefined_TF_Element_Array_Or => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Loc); - when Iir_Predefined_TF_Array_Element_Nand => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Loc); - when Iir_Predefined_TF_Element_Array_Nand => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Loc); - when Iir_Predefined_TF_Array_Element_Nor => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Loc); - when Iir_Predefined_TF_Element_Array_Nor => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Loc); - when Iir_Predefined_TF_Array_Element_Xor => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Loc); - when Iir_Predefined_TF_Element_Array_Xor => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Loc); - when Iir_Predefined_TF_Array_Element_Xnor => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Loc); - when Iir_Predefined_TF_Element_Array_Xnor => - return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Loc); - - -- Avoid implicit conversion of the array parameters to the - -- unbounded type for optimizing purpose. - when Iir_Predefined_TF_Reduction_And => - return Translate_Predefined_TF_Reduction - (ON_And, Left, Res_Type); - when Iir_Predefined_TF_Reduction_Or => - return Translate_Predefined_TF_Reduction - (ON_Or, Left, Res_Type); - when Iir_Predefined_TF_Reduction_Nand => - return New_Monadic_Op - (ON_Not, - Translate_Predefined_TF_Reduction (ON_And, Left, Res_Type)); - when Iir_Predefined_TF_Reduction_Nor => - return New_Monadic_Op - (ON_Not, - Translate_Predefined_TF_Reduction (ON_Or, Left, Res_Type)); - when Iir_Predefined_TF_Reduction_Xor => - return Translate_Predefined_TF_Reduction - (ON_Xor, Left, Res_Type); - when Iir_Predefined_TF_Reduction_Xnor => - return New_Monadic_Op - (ON_Not, - Translate_Predefined_TF_Reduction (ON_Xor, Left, Res_Type)); - - when Iir_Predefined_Vector_Minimum => - return Translate_Predefined_Vector_Min_Max - (True, Left, Res_Type); - when Iir_Predefined_Vector_Maximum => - return Translate_Predefined_Vector_Min_Max - (False, Left, Res_Type); - - when Iir_Predefined_Bit_Rising_Edge - | Iir_Predefined_Boolean_Rising_Edge => - return Translate_Predefined_TF_Edge (True, Left); - when Iir_Predefined_Bit_Falling_Edge - | Iir_Predefined_Boolean_Falling_Edge => - return Translate_Predefined_TF_Edge (False, Left); - - when Iir_Predefined_Std_Ulogic_Array_Match_Equality => - return Translate_Predefined_Std_Ulogic_Array_Match - (Ghdl_Std_Ulogic_Array_Match_Eq, Left, Right, Res_Type); - when Iir_Predefined_Std_Ulogic_Array_Match_Inequality => - return Translate_Predefined_Std_Ulogic_Array_Match - (Ghdl_Std_Ulogic_Array_Match_Ne, Left, Right, Res_Type); - - when others => - null; - end case; - - -- Evaluate parameters. - Res_Otype := Get_Ortho_Type (Res_Type, Mode_Value); - Inter := Get_Interface_Declaration_Chain (Imp); - if Left = Null_Iir then - Left_Tree := O_Enode_Null; - else - Left_Type := Get_Type (Inter); - Left_Tree := Translate_Expression (Left, Left_Type); - end if; - - if Right = Null_Iir then - Right_Tree := O_Enode_Null; - else - Right_Type := Get_Type (Get_Chain (Inter)); - Right_Tree := Translate_Expression (Right, Right_Type); - end if; - - Op := Predefined_To_Onop (Kind); - if Op /= ON_Nil then - case Op is - when ON_Eq - | ON_Neq - | ON_Ge - | ON_Gt - | ON_Le - | ON_Lt => - Res := New_Compare_Op (Op, Left_Tree, Right_Tree, - Std_Boolean_Type_Node); - when ON_Add_Ov - | ON_Sub_Ov - | ON_Mul_Ov - | ON_Div_Ov - | ON_Rem_Ov - | ON_Mod_Ov - | ON_Xor => - Res := New_Dyadic_Op (Op, Left_Tree, Right_Tree); - when ON_Abs_Ov - | ON_Neg_Ov - | ON_Not => - Res := New_Monadic_Op (Op, Left_Tree); - when others => - Ada.Text_IO.Put_Line - ("translate_predefined_operator: cannot handle " - & ON_Op_Kind'Image (Op)); - raise Internal_Error; - end case; - Res := Translate_Implicit_Conv - (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Loc); - return Res; - end if; - - case Kind is - when Iir_Predefined_Bit_Xnor - | Iir_Predefined_Boolean_Xnor => - return Translate_Predefined_Logical - (Iir_Predefined_Boolean_Xnor, Left_Tree, Right_Tree); - when Iir_Predefined_Bit_Match_Equality => - return New_Compare_Op (ON_Eq, Left_Tree, Right_Tree, - Get_Ortho_Type (Res_Type, Mode_Value)); - when Iir_Predefined_Bit_Match_Inequality => - return New_Compare_Op (ON_Neq, Left_Tree, Right_Tree, - Get_Ortho_Type (Res_Type, Mode_Value)); - - when Iir_Predefined_Bit_Condition => - return New_Compare_Op - (ON_Eq, Left_Tree, New_Lit (Get_Ortho_Expr (Bit_1)), - Std_Boolean_Type_Node); - - when Iir_Predefined_Integer_Identity - | Iir_Predefined_Floating_Identity - | Iir_Predefined_Physical_Identity => - return Translate_Implicit_Conv - (Left_Tree, Left_Type, Res_Type, Mode_Value, Loc); - - when Iir_Predefined_Access_Equality - | Iir_Predefined_Access_Inequality => - if Is_Composite (Get_Info (Left_Type)) then - -- a fat pointer. - declare - T : Type_Info_Acc; - B : Type_Info_Acc; - L, R : O_Dnode; - V1, V2 : O_Enode; - Op1, Op2 : ON_Op_Kind; - begin - if Kind = Iir_Predefined_Access_Equality then - Op1 := ON_Eq; - Op2 := ON_And; - else - Op1 := ON_Neq; - Op2 := ON_Or; - end if; - T := Get_Info (Left_Type); - B := Get_Info (Get_Designated_Type (Left_Type)); - L := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); - R := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); - New_Assign_Stmt (New_Obj (L), Left_Tree); - New_Assign_Stmt (New_Obj (R), Right_Tree); - V1 := New_Compare_Op - (Op1, - New_Value_Selected_Acc_Value - (New_Obj (L), B.T.Base_Field (Mode_Value)), - New_Value_Selected_Acc_Value - (New_Obj (R), B.T.Base_Field (Mode_Value)), - Std_Boolean_Type_Node); - V2 := New_Compare_Op - (Op1, - New_Value_Selected_Acc_Value - (New_Obj (L), B.T.Bounds_Field (Mode_Value)), - New_Value_Selected_Acc_Value - (New_Obj (R), B.T.Bounds_Field (Mode_Value)), - Std_Boolean_Type_Node); - return New_Dyadic_Op (Op2, V1, V2); - end; - else - -- a thin pointer. - if Kind = Iir_Predefined_Access_Equality then - return New_Compare_Op - (ON_Eq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); - else - return New_Compare_Op - (ON_Neq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); - end if; - end if; - - when Iir_Predefined_Physical_Integer_Div => - return New_Dyadic_Op (ON_Div_Ov, Left_Tree, - New_Convert_Ov (Right_Tree, Res_Otype)); - when Iir_Predefined_Physical_Physical_Div => - return New_Convert_Ov - (New_Dyadic_Op (ON_Div_Ov, Left_Tree, Right_Tree), Res_Otype); - - -- LRM 7.2.6 - -- Multiplication of a value P of a physical type Tp by a - -- value I of type INTEGER is equivalent to the following - -- computation: Tp'Val (Tp'Pos (P) * I) - -- FIXME: this is not what is really done... - when Iir_Predefined_Integer_Physical_Mul => - return New_Dyadic_Op (ON_Mul_Ov, - New_Convert_Ov (Left_Tree, Res_Otype), - Right_Tree); - when Iir_Predefined_Physical_Integer_Mul => - return New_Dyadic_Op (ON_Mul_Ov, Left_Tree, - New_Convert_Ov (Right_Tree, Res_Otype)); - - -- LRM 7.2.6 - -- Multiplication of a value P of a physical type Tp by a - -- value F of type REAL is equivalten to the following - -- computation: Tp'Val (INTEGER (REAL (Tp'Pos (P)) * F)) - -- FIXME: we do not restrict with INTEGER. - when Iir_Predefined_Physical_Real_Mul => - declare - Right_Otype : O_Tnode; - begin - Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); - return New_Convert_Ov - (New_Dyadic_Op (ON_Mul_Ov, - New_Convert_Ov (Left_Tree, Right_Otype), - Right_Tree), - Res_Otype); - end; - when Iir_Predefined_Physical_Real_Div => - declare - Right_Otype : O_Tnode; - begin - Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); - return New_Convert_Ov - (New_Dyadic_Op (ON_Div_Ov, - New_Convert_Ov (Left_Tree, Right_Otype), - Right_Tree), - Res_Otype); - end; - when Iir_Predefined_Real_Physical_Mul => - declare - Left_Otype : O_Tnode; - begin - Left_Otype := Get_Ortho_Type (Left_Type, Mode_Value); - return New_Convert_Ov - (New_Dyadic_Op (ON_Mul_Ov, - Left_Tree, - New_Convert_Ov (Right_Tree, Left_Otype)), - Res_Otype); - end; - - when Iir_Predefined_Universal_R_I_Mul => - return New_Dyadic_Op (ON_Mul_Ov, - Left_Tree, - New_Convert_Ov (Right_Tree, Res_Otype)); - - when Iir_Predefined_Floating_Exp => - Res := Translate_Lib_Operator - (New_Convert_Ov (Left_Tree, Std_Real_Otype), - Right_Tree, Ghdl_Real_Exp); - return New_Convert_Ov (Res, Res_Otype); - when Iir_Predefined_Integer_Exp => - Res := Translate_Lib_Operator - (New_Convert_Ov (Left_Tree, Std_Integer_Otype), - Right_Tree, - Ghdl_Integer_Exp); - return New_Convert_Ov (Res, Res_Otype); - - when Iir_Predefined_Array_Inequality - | Iir_Predefined_Record_Inequality => - return New_Monadic_Op - (ON_Not, Translate_Predefined_Lib_Operator - (Left_Tree, Right_Tree, Imp)); - when Iir_Predefined_Array_Equality - | Iir_Predefined_Record_Equality => - return Translate_Predefined_Lib_Operator - (Left_Tree, Right_Tree, Imp); - - when Iir_Predefined_Array_Greater => - return New_Compare_Op - (ON_Eq, - Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, - Imp), - New_Lit (Ghdl_Compare_Gt), - Std_Boolean_Type_Node); - when Iir_Predefined_Array_Greater_Equal => - return New_Compare_Op - (ON_Ge, - Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, - Imp), - New_Lit (Ghdl_Compare_Eq), - Std_Boolean_Type_Node); - when Iir_Predefined_Array_Less => - return New_Compare_Op - (ON_Eq, - Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, - Imp), - New_Lit (Ghdl_Compare_Lt), - Std_Boolean_Type_Node); - when Iir_Predefined_Array_Less_Equal => - return New_Compare_Op - (ON_Le, - Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, - Imp), - New_Lit (Ghdl_Compare_Eq), - Std_Boolean_Type_Node); - - when Iir_Predefined_TF_Array_And - | Iir_Predefined_TF_Array_Or - | Iir_Predefined_TF_Array_Nand - | Iir_Predefined_TF_Array_Nor - | Iir_Predefined_TF_Array_Xor - | Iir_Predefined_TF_Array_Xnor - | Iir_Predefined_TF_Array_Not - | Iir_Predefined_Array_Srl - | Iir_Predefined_Array_Sra - | Iir_Predefined_Array_Ror => - return Translate_Predefined_Array_Operator_Convert - (Left_Tree, Right_Tree, Imp, Res_Type); - - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Rol => - Right_Tree := New_Monadic_Op (ON_Neg_Ov, Right_Tree); - return Translate_Predefined_Array_Operator_Convert - (Left_Tree, Right_Tree, Imp, Res_Type); - - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - return Translate_Concat_Operator - (Left_Tree, Right_Tree, Imp, Res_Type, Loc); - - when Iir_Predefined_Endfile => - return Translate_Lib_Operator - (Left_Tree, O_Enode_Null, Ghdl_File_Endfile); - - when Iir_Predefined_Now_Function => - return New_Obj_Value (Ghdl_Now); - - when Iir_Predefined_Std_Ulogic_Match_Equality => - return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Eq, - Left_Tree, Right_Tree, Res_Otype); - when Iir_Predefined_Std_Ulogic_Match_Inequality => - return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Ne, - Left_Tree, Right_Tree, Res_Otype); - when Iir_Predefined_Std_Ulogic_Match_Less => - return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Lt, - Left_Tree, Right_Tree, Res_Otype); - when Iir_Predefined_Std_Ulogic_Match_Less_Equal => - return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Le, - Left_Tree, Right_Tree, Res_Otype); - when Iir_Predefined_Std_Ulogic_Match_Greater => - return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Lt, - Right_Tree, Left_Tree, Res_Otype); - when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => - return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Le, - Right_Tree, Left_Tree, Res_Otype); - - when Iir_Predefined_Bit_Array_Match_Equality => - return New_Compare_Op - (ON_Eq, - Translate_Predefined_Lib_Operator - (Left_Tree, Right_Tree, Imp), - New_Lit (Std_Boolean_True_Node), - Res_Otype); - when Iir_Predefined_Bit_Array_Match_Inequality => - return New_Compare_Op - (ON_Eq, - Translate_Predefined_Lib_Operator - (Left_Tree, Right_Tree, Imp), - New_Lit (Std_Boolean_False_Node), - Res_Otype); - - when Iir_Predefined_Array_Minimum => - return Translate_Predefined_Array_Min_Max - (True, Left_Tree, Right_Tree, Left_Type, Right_Type, - Res_Type, Imp, Loc); - when Iir_Predefined_Array_Maximum => - return Translate_Predefined_Array_Min_Max - (False, Left_Tree, Right_Tree, Left_Type, Right_Type, - Res_Type, Imp, Loc); - - when Iir_Predefined_Integer_To_String => - case Get_Info (Left_Type).Type_Mode is - when Type_Mode_I32 => - return Translate_To_String - (Ghdl_To_String_I32, Res_Type, Loc, - New_Convert_Ov (Left_Tree, Ghdl_I32_Type)); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Enum_To_String => - -- LRM08 5.7 String representations - -- - For a given value of type CHARACTER, [...] - -- - -- So special case for character. - if Get_Base_Type (Left_Type) = Character_Type_Definition then - return Translate_To_String - (Ghdl_To_String_Char, Res_Type, Loc, Left_Tree); - end if; - - -- LRM08 5.7 String representations - -- - For a given value of type other than CHARACTER, [...] - declare - Conv : O_Tnode; - Subprg : O_Dnode; - begin - case Get_Info (Left_Type).Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_To_String_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Subprg := Ghdl_To_String_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Subprg := Ghdl_To_String_E32; - Conv := Ghdl_I32_Type; - when others => - raise Internal_Error; - end case; - return Translate_To_String - (Subprg, Res_Type, Loc, - New_Convert_Ov (Left_Tree, Conv), - New_Lit (Rtis.New_Rti_Address - (Get_Info (Left_Type).Type_Rti))); - end; - when Iir_Predefined_Floating_To_String => - return Translate_To_String - (Ghdl_To_String_F64, Res_Type, Loc, - New_Convert_Ov (Left_Tree, Ghdl_Real_Type)); - when Iir_Predefined_Real_To_String_Digits => - return Translate_To_String - (Ghdl_To_String_F64_Digits, Res_Type, Loc, - New_Convert_Ov (Left_Tree, Ghdl_Real_Type), - New_Convert_Ov (Right_Tree, Ghdl_I32_Type)); - when Iir_Predefined_Real_To_String_Format => - return Translate_To_String - (Ghdl_To_String_F64_Format, Res_Type, Loc, - New_Convert_Ov (Left_Tree, Ghdl_Real_Type), - Right_Tree); - when Iir_Predefined_Physical_To_String => - declare - Conv : O_Tnode; - Subprg : O_Dnode; - begin - case Get_Info (Left_Type).Type_Mode is - when Type_Mode_P32 => - Subprg := Ghdl_To_String_P32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 => - Subprg := Ghdl_To_String_P64; - Conv := Ghdl_I64_Type; - when others => - raise Internal_Error; - end case; - return Translate_To_String - (Subprg, Res_Type, Loc, - New_Convert_Ov (Left_Tree, Conv), - New_Lit (Rtis.New_Rti_Address - (Get_Info (Left_Type).Type_Rti))); - end; - when Iir_Predefined_Time_To_String_Unit => - return Translate_To_String - (Ghdl_Time_To_String_Unit, Res_Type, Loc, - Left_Tree, Right_Tree, - New_Lit (Rtis.New_Rti_Address - (Get_Info (Left_Type).Type_Rti))); - when Iir_Predefined_Bit_Vector_To_Ostring => - return Translate_Bv_To_String - (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Loc); - when Iir_Predefined_Bit_Vector_To_Hstring => - return Translate_Bv_To_String - (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Loc); - when Iir_Predefined_Array_Char_To_String => - declare - El_Type : constant Iir := Get_Element_Subtype (Left_Type); - Subprg : O_Dnode; - Arg : Mnode; - begin - Arg := Stabilize - (E2M (Left_Tree, Get_Info (Left_Type), Mode_Value)); - case Get_Info (El_Type).Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Array_Char_To_String_B1; - when Type_Mode_E8 => - Subprg := Ghdl_Array_Char_To_String_E8; - when Type_Mode_E32 => - Subprg := Ghdl_Array_Char_To_String_E32; - when others => - raise Internal_Error; - end case; - return Translate_To_String - (Subprg, Res_Type, Loc, - New_Convert_Ov (M2E (Chap3.Get_Array_Base (Arg)), - Ghdl_Ptr_Type), - Chap3.Get_Array_Length (Arg, Left_Type), - New_Lit (Rtis.New_Rti_Address - (Get_Info (El_Type).Type_Rti))); - end; - - when others => - Ada.Text_IO.Put_Line - ("translate_predefined_operator(2): cannot handle " - & Iir_Predefined_Functions'Image (Kind)); - raise Internal_Error; - return O_Enode_Null; - end case; - end Translate_Predefined_Operator; - - -- Assign EXPR to TARGET. - procedure Translate_Assign - (Target : Mnode; - Val : O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir) - is - T_Info : constant Type_Info_Acc := Get_Info (Target_Type); - begin - case T_Info.Type_Mode is - when Type_Mode_Scalar => - New_Assign_Stmt - (M2Lv (Target), - Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type)); - when Type_Mode_Acc - | Type_Mode_File => - New_Assign_Stmt (M2Lv (Target), Val); - when Type_Mode_Fat_Acc => - Chap3.Translate_Object_Copy (Target, Val, Target_Type); - when Type_Mode_Fat_Array => - declare - T : Mnode; - E : O_Dnode; - begin - T := Stabilize (Target); - E := Create_Temp_Init - (T_Info.Ortho_Ptr_Type (Mode_Value), Val); - Chap3.Check_Array_Match - (Target_Type, T, - Get_Type (Expr), Dp2M (E, T_Info, Mode_Value), Loc); - Chap3.Translate_Object_Copy - (T, New_Obj_Value (E), Target_Type); - end; - when Type_Mode_Array => - -- Source is of type TARGET_TYPE, so no length check is - -- necessary. - Chap3.Translate_Object_Copy (Target, Val, Target_Type); - when Type_Mode_Record => - Chap3.Translate_Object_Copy (Target, Val, Target_Type); - when Type_Mode_Unknown - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Translate_Assign; - - procedure Translate_Assign - (Target : Mnode; Expr : Iir; Target_Type : Iir) - is - Val : O_Enode; - begin - if Get_Kind (Expr) = Iir_Kind_Aggregate then - -- FIXME: handle overlap between TARGET and EXPR. - Translate_Aggregate (Target, Target_Type, Expr); - else - Open_Temp; - Val := Chap7.Translate_Expression (Expr, Target_Type); - Translate_Assign (Target, Val, Expr, Target_Type, Expr); - Close_Temp; - end if; - end Translate_Assign; - - -- If AGGR is of the form (others => (others => EXPR)) (where the - -- number of (others => ) sub-aggregate is at least 1, return EXPR - -- otherwise return NULL_IIR. - function Is_Aggregate_Others (Aggr : Iir_Aggregate) return Iir - is - Chain : Iir; - Aggr1 : Iir; - --Type_Info : Type_Info_Acc; - begin - Aggr1 := Aggr; - -- Do not use translate_aggregate_others for a complex type. - --Type_Info := Get_Info (Get_Type (Aggr)); - --if Type_Info.C /= null and then Type_Info.C.Builder_Need_Func then - -- return Null_Iir; - --end if; - loop - Chain := Get_Association_Choices_Chain (Aggr1); - if not Is_Chain_Length_One (Chain) then - return Null_Iir; - end if; - if Get_Kind (Chain) /= Iir_Kind_Choice_By_Others then - return Null_Iir; - end if; - Aggr1 := Get_Associated_Expr (Chain); - case Get_Kind (Aggr1) is - when Iir_Kind_Aggregate => - if Get_Type (Aggr1) /= Null_Iir then - -- Stop when a sub-aggregate is in fact an aggregate. - return Aggr1; - end if; - when Iir_Kind_String_Literal - | Iir_Kind_Bit_String_Literal => - return Null_Iir; - --Error_Kind ("is_aggregate_others", Aggr1); - when others => - return Aggr1; - end case; - end loop; - end Is_Aggregate_Others; - - -- Generate code for (others => EL). - procedure Translate_Aggregate_Others - (Target : Mnode; Target_Type : Iir; El : Iir) - is - Base_Ptr : Mnode; - Info : Type_Info_Acc; - It : O_Dnode; - Len : O_Dnode; - Len_Val : O_Enode; - Label : O_Snode; - Arr_Var : Mnode; - El_Node : Mnode; - begin - Open_Temp; - - Info := Get_Info (Target_Type); - case Info.Type_Mode is - when Type_Mode_Fat_Array => - Arr_Var := Stabilize (Target); - Base_Ptr := Stabilize (Chap3.Get_Array_Base (Arr_Var)); - Len_Val := Chap3.Get_Array_Length (Arr_Var, Target_Type); - when Type_Mode_Array => - Base_Ptr := Stabilize (Chap3.Get_Array_Base (Target)); - Len_Val := Chap3.Get_Array_Type_Length (Target_Type); - when others => - raise Internal_Error; - end case; - -- FIXME: use this (since this use one variable instead of two): - -- I := length; - -- loop - -- exit when I = 0; - -- I := I - 1; - -- A[I] := xxx; - -- end loop; - Len := Create_Temp_Init (Ghdl_Index_Type, Len_Val); - if True then - It := Create_Temp (Ghdl_Index_Type); - else - New_Var_Decl (It, Wki_I, O_Storage_Local, Ghdl_Index_Type); - end if; - Init_Var (It); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, New_Compare_Op (ON_Eq, - New_Obj_Value (It), New_Obj_Value (Len), - Ghdl_Bool_Type)); - El_Node := Chap3.Index_Base (Base_Ptr, Target_Type, - New_Obj_Value (It)); - --New_Assign_Stmt (El_Node, Chap7.Translate_Expression (El)); - Translate_Assign (El_Node, El, Get_Element_Subtype (Target_Type)); - Inc_Var (It); - Finish_Loop_Stmt (Label); - - Close_Temp; - end Translate_Aggregate_Others; - - procedure Translate_Array_Aggregate_Gen - (Base_Ptr : Mnode; - Bounds_Ptr : Mnode; - Aggr : Iir; - Aggr_Type : Iir; - Dim : Natural; - Var_Index : O_Dnode) - is - Index_List : Iir_List; - Expr_Type : Iir; - Final : Boolean; - - procedure Do_Assign (Expr : Iir) - is - begin - if Final then - Translate_Assign (Chap3.Index_Base (Base_Ptr, Aggr_Type, - New_Obj_Value (Var_Index)), - Expr, Expr_Type); - Inc_Var (Var_Index); - else - Translate_Array_Aggregate_Gen - (Base_Ptr, Bounds_Ptr, Expr, Aggr_Type, Dim + 1, Var_Index); - end if; - end Do_Assign; - - P : Natural; - El : Iir; - begin - case Get_Kind (Aggr) is - when Iir_Kind_Aggregate => - -- Continue below. - null; - when Iir_Kind_String_Literal - | Iir_Kind_Bit_String_Literal => - declare - Len : constant Nat32 := Get_String_Length (Aggr); - - -- Type of the unconstrained array type. - Arr_Type : O_Tnode; - - -- Type of the constrained array type. - Str_Type : O_Tnode; - - Cst : Var_Type; - Var_I : O_Dnode; - Label : O_Snode; - begin - Expr_Type := Get_Element_Subtype (Aggr_Type); - - -- Create a constant for the string. - -- First, create its type, because the literal has no - -- type (subaggregate). - Arr_Type := New_Array_Type - (Get_Ortho_Type (Expr_Type, Mode_Value), - Ghdl_Index_Type); - New_Type_Decl (Create_Uniq_Identifier, Arr_Type); - Str_Type := New_Constrained_Array_Type - (Arr_Type, New_Index_Lit (Unsigned_64 (Len))); - Cst := Create_String_Literal_Var_Inner - (Aggr, Expr_Type, Str_Type); - - -- Copy it. - Open_Temp; - Var_I := Create_Temp (Ghdl_Index_Type); - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_I), - New_Lit (New_Index_Lit (Nat32'Pos (Len))), - Ghdl_Bool_Type)); - New_Assign_Stmt - (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, - New_Obj_Value (Var_Index))), - New_Value (New_Indexed_Element (Get_Var (Cst), - New_Obj_Value (Var_I)))); - Inc_Var (Var_I); - Inc_Var (Var_Index); - Finish_Loop_Stmt (Label); - Close_Temp; - end; - return; - when others => - raise Internal_Error; - end case; - - Index_List := Get_Index_Subtype_List (Aggr_Type); - - -- FINAL is true if the elements of the aggregate are elements of - -- the array. - if Get_Nbr_Elements (Index_List) = Dim then - Expr_Type := Get_Element_Subtype (Aggr_Type); - Final:= True; - else - Final := False; - end if; - - El := Get_Association_Choices_Chain (Aggr); - - -- First, assign positionnal association. - -- FIXME: count the number of positionnal association and generate - -- an error if there is more positionnal association than elements - -- in the array. - P := 0; - loop - if El = Null_Iir then - -- There is only positionnal associations. - return; - end if; - exit when Get_Kind (El) /= Iir_Kind_Choice_By_None; - Do_Assign (Get_Associated_Expr (El)); - P := P + 1; - El := Get_Chain (El); - end loop; - - -- Then, assign named or others association. - if Get_Chain (El) = Null_Iir then - -- There is only one choice - case Get_Kind (El) is - when Iir_Kind_Choice_By_Others => - -- falltrough... - null; - when Iir_Kind_Choice_By_Expression => - Do_Assign (Get_Associated_Expr (El)); - return; - when Iir_Kind_Choice_By_Range => - declare - Var_Length : O_Dnode; - Var_I : O_Dnode; - Label : O_Snode; - begin - Open_Temp; - Var_Length := Create_Temp_Init - (Ghdl_Index_Type, - Chap7.Translate_Range_Length (Get_Choice_Range (El))); - Var_I := Create_Temp (Ghdl_Index_Type); - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_I), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - Do_Assign (Get_Associated_Expr (El)); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Close_Temp; - end; - return; - when others => - Error_Kind ("translate_array_aggregate_gen", El); - end case; - end if; - - -- Several choices.. - declare - Range_Type : Iir; - Var_Pos : O_Dnode; - Var_Len : O_Dnode; - Range_Ptr : Mnode; - Rtinfo : Type_Info_Acc; - If_Blk : O_If_Block; - Case_Blk : O_Case_Block; - Label : O_Snode; - El_Assoc : Iir; - Len_Tmp : O_Enode; - begin - Open_Temp; - -- Create a loop from left +- number of positionnals associations - -- to/downto right. - Range_Type := - Get_Base_Type (Get_Nth_Element (Index_List, Dim - 1)); - Rtinfo := Get_Info (Range_Type); - Var_Pos := Create_Temp (Rtinfo.Ortho_Type (Mode_Value)); - Range_Ptr := Stabilize - (Chap3.Bounds_To_Range (Bounds_Ptr, Aggr_Type, Dim)); - New_Assign_Stmt (New_Obj (Var_Pos), - M2E (Chap3.Range_To_Left (Range_Ptr))); - Var_Len := Create_Temp (Ghdl_Index_Type); - if P /= 0 then - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - M2E (Chap3.Range_To_Dir (Range_Ptr)), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (P), - Range_Type); - New_Else_Stmt (If_Blk); - Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (P), - Range_Type); - Finish_If_Stmt (If_Blk); - end if; - - Len_Tmp := M2E (Chap3.Range_To_Length (Range_Ptr)); - if P /= 0 then - Len_Tmp := New_Dyadic_Op - (ON_Sub_Ov, - Len_Tmp, - New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (P)))); - end if; - New_Assign_Stmt (New_Obj (Var_Len), Len_Tmp); - - -- Start loop. - Start_Loop_Stmt (Label); - -- Check if end of loop. - Gen_Exit_When - (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Len), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - - -- convert aggr into a case statement. - Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Pos)); - El_Assoc := Null_Iir; - while El /= Null_Iir loop - Start_Choice (Case_Blk); - Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk); - if Get_Associated_Expr (El) /= Null_Iir then - El_Assoc := Get_Associated_Expr (El); - end if; - Finish_Choice (Case_Blk); - Do_Assign (El_Assoc); - P := P + 1; - El := Get_Chain (El); - end loop; - Finish_Case_Stmt (Case_Blk); - -- Update var_pos - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - M2E (Chap3.Range_To_Dir (Range_Ptr)), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (1), - Range_Type); - New_Else_Stmt (If_Blk); - Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (1), - Range_Type); - Finish_If_Stmt (If_Blk); - New_Assign_Stmt - (New_Obj (Var_Len), - New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Var_Len), - New_Lit (Ghdl_Index_1))); - Finish_Loop_Stmt (Label); - Close_Temp; - end; - end Translate_Array_Aggregate_Gen; - - procedure Translate_Record_Aggregate (Target : Mnode; Aggr : Iir) - is - Targ : Mnode; - Aggr_Type : constant Iir := Get_Type (Aggr); - Aggr_Base_Type : constant Iir_Record_Type_Definition := - Get_Base_Type (Aggr_Type); - El_List : constant Iir_List := - Get_Elements_Declaration_List (Aggr_Base_Type); - El_Index : Natural; - Nbr_El : constant Natural := Get_Nbr_Elements (El_List); - - -- Record which elements of the record have been set. The 'others' - -- clause applies to all elements not already set. - type Bool_Array_Type is array (0 .. Nbr_El - 1) of Boolean; - pragma Pack (Bool_Array_Type); - Set_Array : Bool_Array_Type := (others => False); - - -- The expression associated. - El_Expr : Iir; - - -- Set an elements. - procedure Set_El (El : Iir_Element_Declaration) is - begin - Translate_Assign (Chap6.Translate_Selected_Element (Targ, El), - El_Expr, Get_Type (El)); - Set_Array (Natural (Get_Element_Position (El))) := True; - end Set_El; - - Assoc : Iir; - N_El_Expr : Iir; - begin - Open_Temp; - Targ := Stabilize (Target); - El_Index := 0; - Assoc := Get_Association_Choices_Chain (Aggr); - while Assoc /= Null_Iir loop - N_El_Expr := Get_Associated_Expr (Assoc); - if N_El_Expr /= Null_Iir then - El_Expr := N_El_Expr; - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - Set_El (Get_Nth_Element (El_List, El_Index)); - El_Index := El_Index + 1; - when Iir_Kind_Choice_By_Name => - Set_El (Get_Choice_Name (Assoc)); - El_Index := Natural'Last; - when Iir_Kind_Choice_By_Others => - for J in Set_Array'Range loop - if not Set_Array (J) then - Set_El (Get_Nth_Element (El_List, J)); - end if; - end loop; - when others => - Error_Kind ("translate_record_aggregate", Assoc); - end case; - Assoc := Get_Chain (Assoc); - end loop; - Close_Temp; - end Translate_Record_Aggregate; - - procedure Translate_Array_Aggregate - (Target : Mnode; Target_Type : Iir; Aggr : Iir) - is - Aggr_Type : constant Iir := Get_Type (Aggr); - Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); - Targ_Index_List : constant Iir_List := - Get_Index_Subtype_List (Target_Type); - - Aggr_Info : Iir_Aggregate_Info; - Base : Mnode; - Bounds : Mnode; - Var_Index : O_Dnode; - Targ : Mnode; - - Rinfo : Type_Info_Acc; - Bt : Iir; - - -- Generate code for: (LVAL lop RNG.left) or (RVAL rop RNG.right) - function Check_Value (Lval : Iir; - Lop : ON_Op_Kind; - Rval : Iir; - Rop : ON_Op_Kind; - Rng : Mnode) - return O_Enode - is - L, R : O_Enode; - begin - L := New_Compare_Op - (Lop, - New_Lit (Translate_Static_Expression (Lval, Bt)), - M2E (Chap3.Range_To_Left (Rng)), - Ghdl_Bool_Type); - R := New_Compare_Op - (Rop, - New_Lit (Translate_Static_Expression (Rval, Bt)), - M2E (Chap3.Range_To_Right (Rng)), - Ghdl_Bool_Type); - return New_Dyadic_Op (ON_Or, L, R); - end Check_Value; - - Range_Ptr : Mnode; - Subtarg_Type : Iir; - Subaggr_Type : Iir; - L, H : Iir; - Min : Iir_Int32; - Has_Others : Boolean; - - Var_Err : O_Dnode; - E : O_Enode; - If_Blk : O_If_Block; - Op : ON_Op_Kind; - begin - Open_Temp; - Targ := Stabilize (Target); - Base := Stabilize (Chap3.Get_Array_Base (Targ)); - Bounds := Stabilize (Chap3.Get_Array_Bounds (Targ)); - Aggr_Info := Get_Aggregate_Info (Aggr); - - -- Check type - for I in Natural loop - Subaggr_Type := Get_Index_Type (Index_List, I); - exit when Subaggr_Type = Null_Iir; - Subtarg_Type := Get_Index_Type (Targ_Index_List, I); - - Bt := Get_Base_Type (Subaggr_Type); - Rinfo := Get_Info (Bt); - - if Get_Aggr_Dynamic_Flag (Aggr_Info) then - -- Dynamic range, must evaluate it. - Open_Temp; - declare - A_Range : O_Dnode; - Rng_Ptr : O_Dnode; - begin - -- Evaluate the range. - Chap3.Translate_Anonymous_Type_Definition - (Subaggr_Type, True); - - A_Range := Create_Temp (Rinfo.T.Range_Type); - Rng_Ptr := Create_Temp_Ptr - (Rinfo.T.Range_Ptr_Type, New_Obj (A_Range)); - Chap7.Translate_Range_Ptr - (Rng_Ptr, - Get_Range_Constraint (Subaggr_Type), - Subaggr_Type); - - -- Check range length VS target length. - Chap6.Check_Bound_Error - (New_Compare_Op - (ON_Neq, - M2E (Chap3.Range_To_Length - (Dv2M (A_Range, - Rinfo, - Mode_Value, - Rinfo.T.Range_Type, - Rinfo.T.Range_Ptr_Type))), - M2E (Chap3.Range_To_Length - (Chap3.Bounds_To_Range - (Bounds, Target_Type, I + 1))), - Ghdl_Bool_Type), - Aggr, I); - end; - Close_Temp; - elsif Get_Type_Staticness (Subaggr_Type) /= Locally - or else Subaggr_Type /= Subtarg_Type - then - -- Note: if the aggregate has no others, then the bounds - -- must be the same, otherwise, aggregate bounds must be - -- inside type bounds. - Has_Others := Get_Aggr_Others_Flag (Aggr_Info); - Min := Get_Aggr_Min_Length (Aggr_Info); - L := Get_Aggr_Low_Limit (Aggr_Info); - - if Min > 0 or L /= Null_Iir then - Open_Temp; - - -- Pointer to the range. - Range_Ptr := Stabilize - (Chap3.Bounds_To_Range (Bounds, Target_Type, I + 1)); - Var_Err := Create_Temp (Ghdl_Bool_Type); - H := Get_Aggr_High_Limit (Aggr_Info); - - if L /= Null_Iir then - -- Check the index range of the aggregrate is equal - -- (or within in presence of 'others') the index range - -- of the target. - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - M2E (Chap3.Range_To_Dir (Range_Ptr)), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - if Has_Others then - E := Check_Value (L, ON_Lt, H, ON_Gt, Range_Ptr); - else - E := Check_Value (L, ON_Neq, H, ON_Neq, Range_Ptr); - end if; - New_Assign_Stmt (New_Obj (Var_Err), E); - New_Else_Stmt (If_Blk); - if Has_Others then - E := Check_Value (H, ON_Gt, L, ON_Lt, Range_Ptr); - else - E := Check_Value (H, ON_Neq, L, ON_Neq, Range_Ptr); - end if; - New_Assign_Stmt (New_Obj (Var_Err), E); - Finish_If_Stmt (If_Blk); - -- If L and H are greather than the minimum length, - -- then there is no need to check with min. - if Iir_Int32 (Eval_Pos (H) - Eval_Pos (L) + 1) >= Min then - Min := 0; - end if; - end if; - - if Min > 0 then - -- Check the number of elements is equal (or less in - -- presence of 'others') than the length of the index - -- range of the target. - if Has_Others then - Op := ON_Lt; - else - Op := ON_Neq; - end if; - E := New_Compare_Op - (Op, - M2E (Chap3.Range_To_Length (Range_Ptr)), - New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Min))), - Ghdl_Bool_Type); - if L /= Null_Iir then - E := New_Dyadic_Op (ON_Or, E, New_Obj_Value (Var_Err)); - end if; - New_Assign_Stmt (New_Obj (Var_Err), E); - end if; - Chap6.Check_Bound_Error (New_Obj_Value (Var_Err), Aggr, I); - Close_Temp; - end if; - end if; - - -- Next dimension. - Aggr_Info := Get_Sub_Aggregate_Info (Aggr_Info); - end loop; - - Var_Index := Create_Temp_Init - (Ghdl_Index_Type, New_Lit (Ghdl_Index_0)); - Translate_Array_Aggregate_Gen - (Base, Bounds, Aggr, Aggr_Type, 1, Var_Index); - Close_Temp; - - -- FIXME: creating aggregate subtype is expensive and rarely used. - -- (one of the current use - only ? - is check_array_match). - Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False); - end Translate_Array_Aggregate; - - procedure Translate_Aggregate - (Target : Mnode; Target_Type : Iir; Aggr : Iir) - is - Aggr_Type : constant Iir := Get_Type (Aggr); - El : Iir; - begin - case Get_Kind (Aggr_Type) is - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - El := Is_Aggregate_Others (Aggr); - if El /= Null_Iir then - Translate_Aggregate_Others (Target, Target_Type, El); - else - Translate_Array_Aggregate (Target, Target_Type, Aggr); - end if; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - Translate_Record_Aggregate (Target, Aggr); - when others => - Error_Kind ("translate_aggregate", Aggr_Type); - end case; - end Translate_Aggregate; - - function Translate_Allocator_By_Expression (Expr : Iir) - return O_Enode - is - Val : O_Enode; - Val_M : Mnode; - A_Type : constant Iir := Get_Type (Expr); - A_Info : constant Type_Info_Acc := Get_Info (A_Type); - D_Type : constant Iir := Get_Designated_Type (A_Type); - D_Info : constant Type_Info_Acc := Get_Info (D_Type); - R : Mnode; - Rtype : O_Tnode; - begin - -- Compute the expression. - Val := Translate_Expression (Get_Expression (Expr), D_Type); - -- Allocate memory for the object. - case A_Info.Type_Mode is - when Type_Mode_Fat_Acc => - R := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), - D_Info, Mode_Value); - Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); - Chap3.Translate_Object_Allocation - (R, Alloc_Heap, D_Type, - Chap3.Get_Array_Bounds (Val_M)); - Val := M2E (Val_M); - Rtype := A_Info.Ortho_Ptr_Type (Mode_Value); - when Type_Mode_Acc => - R := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), - D_Info, Mode_Value); - Chap3.Translate_Object_Allocation - (R, Alloc_Heap, D_Type, Mnode_Null); - Rtype := A_Info.Ortho_Type (Mode_Value); - when others => - raise Internal_Error; - end case; - Chap3.Translate_Object_Copy (R, Val, D_Type); - return New_Convert_Ov (M2Addr (R), Rtype); - end Translate_Allocator_By_Expression; - - function Translate_Allocator_By_Subtype (Expr : Iir) - return O_Enode - is - P_Type : constant Iir := Get_Type (Expr); - P_Info : constant Type_Info_Acc := Get_Info (P_Type); - D_Type : constant Iir := Get_Designated_Type (P_Type); - D_Info : constant Type_Info_Acc := Get_Info (D_Type); - Sub_Type : Iir; - Bounds : Mnode; - Res : Mnode; - Rtype : O_Tnode; - begin - case P_Info.Type_Mode is - when Type_Mode_Fat_Acc => - Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), - D_Info, Mode_Value); - -- FIXME: should allocate bounds, and directly set bounds - -- from the range. - Sub_Type := Get_Subtype_Indication (Expr); - Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); - Chap3.Create_Array_Subtype (Sub_Type, True); - Bounds := Chap3.Get_Array_Type_Bounds (Sub_Type); - Rtype := P_Info.Ortho_Ptr_Type (Mode_Value); - when Type_Mode_Acc => - Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), - D_Info, Mode_Value); - Bounds := Mnode_Null; - Rtype := P_Info.Ortho_Type (Mode_Value); - when others => - raise Internal_Error; - end case; - Chap3.Translate_Object_Allocation (Res, Alloc_Heap, D_Type, Bounds); - Chap4.Init_Object (Res, D_Type); - return New_Convert_Ov (M2Addr (Res), Rtype); - end Translate_Allocator_By_Subtype; - - function Translate_Fat_Array_Type_Conversion - (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) - return O_Enode; - - function Translate_Array_Subtype_Conversion - (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) - return O_Enode - is - Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); - Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); - E : Mnode; - begin - E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); - case Res_Info.Type_Mode is - when Type_Mode_Array => - Chap3.Check_Array_Match - (Res_Type, T2M (Res_Type, Mode_Value), - Expr_Type, E, - Loc); - return New_Convert_Ov - (M2Addr (Chap3.Get_Array_Base (E)), - Res_Info.Ortho_Ptr_Type (Mode_Value)); - when Type_Mode_Fat_Array => - declare - Res : Mnode; - begin - Res := Create_Temp (Res_Info); - Copy_Fat_Pointer (Res, E); - Chap3.Check_Array_Match (Res_Type, Res, Expr_Type, E, Loc); - return M2Addr (Res); - end; - when others => - Error_Kind ("translate_array_subtype_conversion", Res_Type); - end case; - end Translate_Array_Subtype_Conversion; - - function Translate_Type_Conversion - (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) - return O_Enode - is - Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); - Res : O_Enode; - begin - case Get_Kind (Res_Type) is - when Iir_Kinds_Scalar_Type_Definition => - Res := New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); - if Chap3.Need_Range_Check (Null_Iir, Res_Type) then - Res := Chap3.Insert_Scalar_Check - (Res, Null_Iir, Res_Type, Loc); - end if; - return Res; - when Iir_Kinds_Array_Type_Definition => - if Get_Constraint_State (Res_Type) = Fully_Constrained then - return Translate_Array_Subtype_Conversion - (Expr, Expr_Type, Res_Type, Loc); - else - return Translate_Fat_Array_Type_Conversion - (Expr, Expr_Type, Res_Type, Loc); - end if; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - return Expr; - when others => - Error_Kind ("translate_type_conversion", Res_Type); - end case; - end Translate_Type_Conversion; - - function Translate_Fat_Array_Type_Conversion - (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) - return O_Enode - is - Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); - Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); - Res_Indexes : constant Iir_List := - Get_Index_Subtype_List (Res_Type); - Expr_Indexes : constant Iir_List := - Get_Index_Subtype_List (Expr_Type); - - Res_Base_Type : constant Iir := Get_Base_Type (Res_Type); - Expr_Base_Type : constant Iir := Get_Base_Type (Expr_Type); - Res_Base_Indexes : constant Iir_List := - Get_Index_Subtype_List (Res_Base_Type); - Expr_Base_Indexes : constant Iir_List := - Get_Index_Subtype_List (Expr_Base_Type); - Res : Mnode; - E : Mnode; - Bounds : O_Dnode; - R_El : Iir; - E_El : Iir; - begin - Res := Create_Temp (Res_Info, Mode_Value); - Bounds := Create_Temp (Res_Info.T.Bounds_Type); - E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); - Open_Temp; - -- Set base. - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Base (Res)), - New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (E)), - Res_Info.T.Base_Ptr_Type (Mode_Value))); - -- Set bounds. - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Res)), - New_Address (New_Obj (Bounds), Res_Info.T.Bounds_Ptr_Type)); - - -- Convert bounds. - for I in Natural loop - R_El := Get_Index_Type (Res_Indexes, I); - E_El := Get_Index_Type (Expr_Indexes, I); - exit when R_El = Null_Iir; - declare - Rb_Ptr : Mnode; - Eb_Ptr : Mnode; - Ee : O_Enode; - Same_Index_Type : constant Boolean := - (Get_Index_Type (Res_Base_Indexes, I) - = Get_Index_Type (Expr_Base_Indexes, I)); - begin - Open_Temp; - Rb_Ptr := Stabilize - (Chap3.Get_Array_Range (Res, Res_Type, I + 1)); - Eb_Ptr := Stabilize - (Chap3.Get_Array_Range (E, Expr_Type, I + 1)); - -- Convert left and right (unless they have the same type - - -- this is an optimization but also this deals with null - -- array in common cases). - Ee := M2E (Chap3.Range_To_Left (Eb_Ptr)); - if not Same_Index_Type then - Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); - end if; - New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Rb_Ptr)), Ee); - Ee := M2E (Chap3.Range_To_Right (Eb_Ptr)); - if not Same_Index_Type then - Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); - end if; - New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Rb_Ptr)), Ee); - -- Copy Dir and Length. - New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Rb_Ptr)), - M2E (Chap3.Range_To_Dir (Eb_Ptr))); - New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Rb_Ptr)), - M2E (Chap3.Range_To_Length (Eb_Ptr))); - Close_Temp; - end; - end loop; - Close_Temp; - return M2E (Res); - end Translate_Fat_Array_Type_Conversion; - - function Sig2val_Prepare_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Mnode) - return Mnode - is - pragma Unreferenced (Targ, Targ_Type); - begin - if Get_Type_Info (Data).Type_Mode = Type_Mode_Fat_Array then - return Stabilize (Chap3.Get_Array_Base (Data)); - else - return Stabilize (Data); - end if; - end Sig2val_Prepare_Composite; - - function Sig2val_Update_Data_Array - (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) return Mnode - is - begin - return Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index)); - end Sig2val_Update_Data_Array; - - function Sig2val_Update_Data_Record - (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) - return Mnode - is - pragma Unreferenced (Targ_Type); - begin - return Chap6.Translate_Selected_Element (Val, El); - end Sig2val_Update_Data_Record; - - procedure Sig2val_Finish_Data_Composite (Data : in out Mnode) - is - pragma Unreferenced (Data); - begin - null; - end Sig2val_Finish_Data_Composite; - - procedure Translate_Signal_Assign_Effective_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Mnode) - is - pragma Unreferenced (Targ_Type); - begin - New_Assign_Stmt (New_Access_Element (M2E (Targ)), M2E (Data)); - end Translate_Signal_Assign_Effective_Non_Composite; - - procedure Translate_Signal_Assign_Effective is new Foreach_Non_Composite - (Data_Type => Mnode, - Composite_Data_Type => Mnode, - Do_Non_Composite => Translate_Signal_Assign_Effective_Non_Composite, - Prepare_Data_Array => Sig2val_Prepare_Composite, - Update_Data_Array => Sig2val_Update_Data_Array, - Finish_Data_Array => Sig2val_Finish_Data_Composite, - Prepare_Data_Record => Sig2val_Prepare_Composite, - Update_Data_Record => Sig2val_Update_Data_Record, - Finish_Data_Record => Sig2val_Finish_Data_Composite); - - procedure Translate_Signal_Assign_Driving_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Data: Mnode) - is - begin - New_Assign_Stmt - (Chap14.Get_Signal_Value_Field (M2E (Targ), Targ_Type, - Ghdl_Signal_Driving_Value_Field), - M2E (Data)); - end Translate_Signal_Assign_Driving_Non_Composite; - - procedure Translate_Signal_Assign_Driving is new Foreach_Non_Composite - (Data_Type => Mnode, - Composite_Data_Type => Mnode, - Do_Non_Composite => Translate_Signal_Assign_Driving_Non_Composite, - Prepare_Data_Array => Sig2val_Prepare_Composite, - Update_Data_Array => Sig2val_Update_Data_Array, - Finish_Data_Array => Sig2val_Finish_Data_Composite, - Prepare_Data_Record => Sig2val_Prepare_Composite, - Update_Data_Record => Sig2val_Update_Data_Record, - Finish_Data_Record => Sig2val_Finish_Data_Composite); - - function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode - is - procedure Translate_Signal_Non_Composite - (Targ : Mnode; - Targ_Type : Iir; - Data : Mnode) - is - begin - New_Assign_Stmt (M2Lv (Targ), - Read_Value (M2E (Data), Targ_Type)); - end Translate_Signal_Non_Composite; - - procedure Translate_Signal_Target is new Foreach_Non_Composite - (Data_Type => Mnode, - Composite_Data_Type => Mnode, - Do_Non_Composite => Translate_Signal_Non_Composite, - Prepare_Data_Array => Sig2val_Prepare_Composite, - Update_Data_Array => Sig2val_Update_Data_Array, - Finish_Data_Array => Sig2val_Finish_Data_Composite, - Prepare_Data_Record => Sig2val_Prepare_Composite, - Update_Data_Record => Sig2val_Update_Data_Record, - Finish_Data_Record => Sig2val_Finish_Data_Composite); - - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Info (Sig_Type); - if Tinfo.Type_Mode in Type_Mode_Scalar then - return Read_Value (Sig, Sig_Type); - else - declare - Res : Mnode; - Var_Val : Mnode; - begin - -- allocate result array - if Tinfo.Type_Mode = Type_Mode_Fat_Array then - Res := Create_Temp (Tinfo); - - Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); - - -- Copy bounds. - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Res)), - M2Addr (Chap3.Get_Array_Bounds (Var_Val))); - - -- Allocate base. - Chap3.Allocate_Fat_Array_Base (Alloc_Stack, Res, Sig_Type); - elsif Is_Complex_Type (Tinfo) then - Res := Create_Temp (Tinfo); - Chap4.Allocate_Complex_Object (Sig_Type, Alloc_Stack, Res); - else - Res := Create_Temp (Tinfo); - end if; - - Open_Temp; - - if Tinfo.Type_Mode /= Type_Mode_Fat_Array then - Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); - end if; - - Translate_Signal_Target (Res, Sig_Type, Var_Val); - Close_Temp; - return M2Addr (Res); - end; - end if; - end Translate_Signal_Value; - - -- Get the effective value of a simple signal SIG. - function Read_Signal_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode - is - pragma Unreferenced (Sig_Type); - begin - return New_Value (New_Access_Element (Sig)); - end Read_Signal_Value; - - -- Get the value of signal SIG. - function Translate_Signal is new Translate_Signal_Value - (Read_Value => Read_Signal_Value); - - function Translate_Signal_Effective_Value - (Sig : O_Enode; Sig_Type : Iir) return O_Enode - renames Translate_Signal; - - function Read_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode is - begin - return New_Value (Chap14.Get_Signal_Value_Field - (Sig, Sig_Type, Ghdl_Signal_Driving_Value_Field)); - end Read_Signal_Driving_Value; - - function Translate_Signal_Driving_Value_1 is new Translate_Signal_Value - (Read_Value => Read_Signal_Driving_Value); - - function Translate_Signal_Driving_Value - (Sig : O_Enode; Sig_Type : Iir) return O_Enode - renames Translate_Signal_Driving_Value_1; - - procedure Set_Effective_Value - (Sig : Mnode; Sig_Type : Iir; Val : Mnode) - renames Translate_Signal_Assign_Effective; - procedure Set_Driving_Value - (Sig : Mnode; Sig_Type : Iir; Val : Mnode) - renames Translate_Signal_Assign_Driving; - - function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) - return O_Enode - is - Imp : Iir; - Expr_Type : Iir; - Res_Type : Iir; - Res : O_Enode; - begin - Expr_Type := Get_Type (Expr); - if Rtype = Null_Iir then - Res_Type := Expr_Type; - else - Res_Type := Rtype; - end if; - case Get_Kind (Expr) is - when Iir_Kind_Integer_Literal - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Floating_Point_Literal => - return New_Lit (Translate_Static_Expression (Expr, Rtype)); - - when Iir_Kind_Physical_Int_Literal => - declare - Unit : Iir; - Unit_Info : Object_Info_Acc; - begin - Unit := Get_Unit_Name (Expr); - Unit_Info := Get_Info (Unit); - if Unit_Info = null then - return New_Lit - (Translate_Static_Expression (Expr, Rtype)); - else - -- Time units might be not locally static. - return New_Dyadic_Op - (ON_Mul_Ov, - New_Lit (New_Signed_Literal - (Get_Ortho_Type (Expr_Type, Mode_Value), - Integer_64 (Get_Value (Expr)))), - New_Value (Get_Var (Unit_Info.Object_Var))); - end if; - end; - - when Iir_Kind_Physical_Fp_Literal => - declare - Unit : Iir; - Unit_Info : Object_Info_Acc; - L, R : O_Enode; - begin - Unit := Get_Unit_Name (Expr); - Unit_Info := Get_Info (Unit); - if Unit_Info = null then - return New_Lit - (Translate_Static_Expression (Expr, Rtype)); - else - -- Time units might be not locally static. - L := New_Lit - (New_Float_Literal - (Ghdl_Real_Type, IEEE_Float_64 (Get_Fp_Value (Expr)))); - R := New_Convert_Ov - (New_Value (Get_Var (Unit_Info.Object_Var)), - Ghdl_Real_Type); - return New_Convert_Ov - (New_Dyadic_Op (ON_Mul_Ov, L, R), - Get_Ortho_Type (Expr_Type, Mode_Value)); - end if; - end; - - when Iir_Kind_Unit_Declaration => - declare - Unit_Info : Object_Info_Acc; - begin - Unit_Info := Get_Info (Expr); - if Unit_Info = null then - return New_Lit - (Translate_Static_Expression (Expr, Rtype)); - else - -- Time units might be not locally static. - return New_Value (Get_Var (Unit_Info.Object_Var)); - end if; - end; - - when Iir_Kind_String_Literal - | Iir_Kind_Bit_String_Literal - | Iir_Kind_Simple_Aggregate - | Iir_Kind_Simple_Name_Attribute => - Res := Translate_String_Literal (Expr); - - when Iir_Kind_Aggregate => - declare - Aggr_Type : Iir; - Tinfo : Type_Info_Acc; - Mres : Mnode; - begin - -- Extract the type of the aggregate. Use the type of the - -- context if it is fully constrained. - pragma Assert (Rtype /= Null_Iir); - if Is_Fully_Constrained_Type (Rtype) then - Aggr_Type := Rtype; - else - Aggr_Type := Expr_Type; - end if; - if Get_Kind (Aggr_Type) = Iir_Kind_Array_Subtype_Definition - then - Chap3.Create_Array_Subtype (Aggr_Type, True); - end if; - - -- FIXME: this may be not necessary - Tinfo := Get_Info (Aggr_Type); - - -- The result area has to be created - if Is_Complex_Type (Tinfo) then - Mres := Create_Temp (Tinfo); - Chap4.Allocate_Complex_Object - (Aggr_Type, Alloc_Stack, Mres); - else - -- if thin array/record: - -- create result - Mres := Create_Temp (Tinfo); - end if; - - Translate_Aggregate (Mres, Aggr_Type, Expr); - Res := M2E (Mres); - - if Aggr_Type /= Rtype then - Res := Translate_Implicit_Conv - (Res, Aggr_Type, Rtype, Mode_Value, Expr); - end if; - return Res; - end; - - when Iir_Kind_Null_Literal => - declare - Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); - Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); - L : O_Dnode; - B : Type_Info_Acc; - begin - if Tinfo.Type_Mode = Type_Mode_Fat_Acc then - -- Create a fat null pointer. - -- FIXME: should be optimized!! - L := Create_Temp (Otype); - B := Get_Info (Get_Designated_Type (Expr_Type)); - New_Assign_Stmt - (New_Selected_Element (New_Obj (L), - B.T.Base_Field (Mode_Value)), - New_Lit - (New_Null_Access (B.T.Base_Ptr_Type (Mode_Value)))); - New_Assign_Stmt - (New_Selected_Element - (New_Obj (L), B.T.Bounds_Field (Mode_Value)), - New_Lit (New_Null_Access (B.T.Bounds_Ptr_Type))); - return New_Address (New_Obj (L), - Tinfo.Ortho_Ptr_Type (Mode_Value)); - else - return New_Lit (New_Null_Access (Otype)); - end if; - end; - - when Iir_Kind_Overflow_Literal => - declare - Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); - Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); - L : O_Dnode; - begin - -- Generate the error message - Chap6.Gen_Bound_Error (Expr); - - -- Create a dummy value - L := Create_Temp (Otype); - if Tinfo.Type_Mode = Type_Mode_Fat_Acc then - return New_Address (New_Obj (L), - Tinfo.Ortho_Ptr_Type (Mode_Value)); - else - return New_Obj_Value (L); - end if; - end; - - when Iir_Kind_Parenthesis_Expression => - return Translate_Expression (Get_Expression (Expr), Rtype); - - when Iir_Kind_Allocator_By_Expression => - return Translate_Allocator_By_Expression (Expr); - when Iir_Kind_Allocator_By_Subtype => - return Translate_Allocator_By_Subtype (Expr); - - when Iir_Kind_Qualified_Expression => - -- FIXME: check type. - Res := Translate_Expression (Get_Expression (Expr), Expr_Type); - - when Iir_Kind_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Attribute_Value - | Iir_Kind_Attribute_Name => - declare - L : Mnode; - begin - L := Chap6.Translate_Name (Expr); - - Res := M2E (L); - if Get_Object_Kind (L) = Mode_Signal then - Res := Translate_Signal (Res, Expr_Type); - end if; - end; - - when Iir_Kind_Iterator_Declaration => - declare - Expr_Info : Ortho_Info_Acc; - begin - Expr_Info := Get_Info (Expr); - Res := New_Value (Get_Var (Expr_Info.Iterator_Var)); - if Rtype /= Null_Iir then - Res := New_Convert_Ov - (Res, Get_Ortho_Type (Rtype, Mode_Value)); - end if; - return Res; - end; - - when Iir_Kinds_Dyadic_Operator => - Imp := Get_Implementation (Expr); - if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then - return Translate_Predefined_Operator - (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type, Expr); - else - return Translate_Operator_Function_Call - (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type); - end if; - when Iir_Kinds_Monadic_Operator => - Imp := Get_Implementation (Expr); - if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then - return Translate_Predefined_Operator - (Imp, Get_Operand (Expr), Null_Iir, Res_Type, Expr); - else - return Translate_Operator_Function_Call - (Imp, Get_Operand (Expr), Null_Iir, Res_Type); - end if; - when Iir_Kind_Function_Call => - Imp := Get_Implementation (Expr); - declare - Assoc_Chain : Iir; - begin - if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration - then - declare - Left, Right : Iir; - begin - Assoc_Chain := Get_Parameter_Association_Chain (Expr); - if Assoc_Chain = Null_Iir then - Left := Null_Iir; - Right := Null_Iir; - else - Left := Get_Actual (Assoc_Chain); - Assoc_Chain := Get_Chain (Assoc_Chain); - if Assoc_Chain = Null_Iir then - Right := Null_Iir; - else - Right := Get_Actual (Assoc_Chain); - end if; - end if; - return Translate_Predefined_Operator - (Imp, Left, Right, Res_Type, Expr); - end; - else - Canon.Canon_Subprogram_Call (Expr); - Assoc_Chain := Get_Parameter_Association_Chain (Expr); - Res := Translate_Function_Call - (Imp, Assoc_Chain, Get_Method_Object (Expr)); - Expr_Type := Get_Return_Type (Imp); - end if; - end; - - when Iir_Kind_Type_Conversion => - declare - Conv_Expr : Iir; - begin - Conv_Expr := Get_Expression (Expr); - Res := Translate_Type_Conversion - (Translate_Expression (Conv_Expr), Get_Type (Conv_Expr), - Expr_Type, Expr); - end; - - when Iir_Kind_Length_Array_Attribute => - return Chap14.Translate_Length_Array_Attribute - (Expr, Res_Type); - when Iir_Kind_Low_Array_Attribute => - return Chap14.Translate_Low_Array_Attribute (Expr); - when Iir_Kind_High_Array_Attribute => - return Chap14.Translate_High_Array_Attribute (Expr); - when Iir_Kind_Left_Array_Attribute => - return Chap14.Translate_Left_Array_Attribute (Expr); - when Iir_Kind_Right_Array_Attribute => - return Chap14.Translate_Right_Array_Attribute (Expr); - when Iir_Kind_Ascending_Array_Attribute => - return Chap14.Translate_Ascending_Array_Attribute (Expr); - - when Iir_Kind_Val_Attribute => - return Chap14.Translate_Val_Attribute (Expr); - when Iir_Kind_Pos_Attribute => - return Chap14.Translate_Pos_Attribute (Expr, Res_Type); - - when Iir_Kind_Succ_Attribute - | Iir_Kind_Pred_Attribute => - return Chap14.Translate_Succ_Pred_Attribute (Expr); - - when Iir_Kind_Image_Attribute => - Res := Chap14.Translate_Image_Attribute (Expr); - - when Iir_Kind_Value_Attribute => - return Chap14.Translate_Value_Attribute (Expr); - - when Iir_Kind_Event_Attribute => - return Chap14.Translate_Event_Attribute (Expr); - when Iir_Kind_Active_Attribute => - return Chap14.Translate_Active_Attribute (Expr); - when Iir_Kind_Last_Value_Attribute => - Res := Chap14.Translate_Last_Value_Attribute (Expr); - - when Iir_Kind_High_Type_Attribute => - return Chap14.Translate_High_Low_Type_Attribute - (Get_Type (Expr), True); - when Iir_Kind_Low_Type_Attribute => - return Chap14.Translate_High_Low_Type_Attribute - (Get_Type (Expr), False); - when Iir_Kind_Left_Type_Attribute => - return M2E - (Chap3.Range_To_Left - (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), - Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); - when Iir_Kind_Right_Type_Attribute => - return M2E - (Chap3.Range_To_Right - (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), - Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); - - when Iir_Kind_Last_Event_Attribute => - return Chap14.Translate_Last_Time_Attribute - (Get_Prefix (Expr), Ghdl_Signal_Last_Event_Field); - when Iir_Kind_Last_Active_Attribute => - return Chap14.Translate_Last_Time_Attribute - (Get_Prefix (Expr), Ghdl_Signal_Last_Active_Field); - - when Iir_Kind_Driving_Value_Attribute => - Res := Chap14.Translate_Driving_Value_Attribute (Expr); - when Iir_Kind_Driving_Attribute => - Res := Chap14.Translate_Driving_Attribute (Expr); - - when Iir_Kind_Path_Name_Attribute - | Iir_Kind_Instance_Name_Attribute => - Res := Chap14.Translate_Path_Instance_Name_Attribute (Expr); - - when Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Selected_Name => - return Translate_Expression (Get_Named_Entity (Expr), Rtype); - - when others => - Error_Kind ("translate_expression", Expr); - end case; - - -- Quick test to avoid useless calls. - if Expr_Type /= Res_Type then - Res := Translate_Implicit_Conv - (Res, Expr_Type, Res_Type, Mode_Value, Expr); - end if; - - return Res; - end Translate_Expression; - - -- Check if RNG is of the form: - -- 1 to T'length - -- or T'Length downto 1 - -- or 0 to T'length - 1 - -- or T'Length - 1 downto 0 - -- In either of these cases, return T'Length - function Is_Length_Range_Expression (Rng : Iir_Range_Expression) - return Iir - is - -- Pattern of a bound. - type Length_Pattern is - ( - Pat_Unknown, - Pat_Length, - Pat_Length_1, -- Length - 1 - Pat_1, - Pat_0 - ); - Length_Attr : Iir := Null_Iir; - - -- Classify the bound. - -- Set LENGTH_ATTR is the pattern is Pat_Length. - function Get_Length_Pattern (Expr : Iir; Recurse : Boolean) - return Length_Pattern - is - begin - case Get_Kind (Expr) is - when Iir_Kind_Length_Array_Attribute => - Length_Attr := Expr; - return Pat_Length; - when Iir_Kind_Integer_Literal => - case Get_Value (Expr) is - when 0 => - return Pat_0; - when 1 => - return Pat_1; - when others => - return Pat_Unknown; - end case; - when Iir_Kind_Substraction_Operator => - if not Recurse then - return Pat_Unknown; - end if; - if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length - and then - Get_Length_Pattern (Get_Right (Expr), False) = Pat_1 - then - return Pat_Length_1; - else - return Pat_Unknown; - end if; - when others => - return Pat_Unknown; - end case; - end Get_Length_Pattern; - Left_Pat, Right_Pat : Length_Pattern; - begin - Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True); - if Left_Pat = Pat_Unknown then - return Null_Iir; - end if; - Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True); - if Right_Pat = Pat_Unknown then - return Null_Iir; - end if; - case Get_Direction (Rng) is - when Iir_To => - if (Left_Pat = Pat_1 and Right_Pat = Pat_Length) - or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1) - then - return Length_Attr; - end if; - when Iir_Downto => - if (Left_Pat = Pat_Length and Right_Pat = Pat_1) - or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0) - then - return Length_Attr; - end if; - end case; - return Null_Iir; - end Is_Length_Range_Expression; - - procedure Translate_Range_Expression_Ptr - (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir) - is - T_Info : Type_Info_Acc; - Length_Attr : Iir; - begin - T_Info := Get_Info (Range_Type); - Open_Temp; - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Left), - Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Right), - Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Dir), - New_Lit (Chap7.Translate_Static_Range_Dir (Expr))); - if T_Info.T.Range_Length /= O_Fnode_Null then - if Get_Expr_Staticness (Expr) = Locally then - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Length), - New_Lit (Translate_Static_Range_Length (Expr))); - else - Length_Attr := Is_Length_Range_Expression (Expr); - if Length_Attr = Null_Iir then - Open_Temp; - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Length), - Compute_Range_Length - (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Left), - New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Right), - Get_Direction (Expr))); - Close_Temp; - else - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), - T_Info.T.Range_Length), - Chap14.Translate_Length_Array_Attribute - (Length_Attr, Null_Iir)); - end if; - end if; - end if; - Close_Temp; - end Translate_Range_Expression_Ptr; - - -- Reverse range ARANGE. - procedure Translate_Reverse_Range_Ptr - (Res_Ptr : O_Dnode; Arange : O_Lnode; Range_Type : Iir) - is - Rinfo : Type_Info_Acc; - Ptr : O_Dnode; - If_Blk : O_If_Block; - begin - Rinfo := Get_Info (Get_Base_Type (Range_Type)); - Open_Temp; - Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, Arange); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Left), - New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Right)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Right), - New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Left)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Length), - New_Value_Selected_Acc_Value (New_Obj (Ptr), - Rinfo.T.Range_Length)); - Start_If_Stmt - (If_Blk, - New_Compare_Op - (ON_Eq, - New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Dir), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), - New_Lit (Ghdl_Dir_Downto_Node)); - New_Else_Stmt (If_Blk); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), - New_Lit (Ghdl_Dir_To_Node)); - Finish_If_Stmt (If_Blk); - Close_Temp; - end Translate_Reverse_Range_Ptr; - - procedure Copy_Range (Dest_Ptr : O_Dnode; - Src_Ptr : O_Dnode; - Info : Type_Info_Acc) - is - begin - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Left), - New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), - Info.T.Range_Left)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Right), - New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), - Info.T.Range_Right)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Dir), - New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), - Info.T.Range_Dir)); - if Info.T.Range_Length /= O_Fnode_Null then - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Dest_Ptr), - Info.T.Range_Length), - New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), - Info.T.Range_Length)); - end if; - end Copy_Range; - - procedure Translate_Range_Ptr - (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir) - is - begin - case Get_Kind (Arange) is - when Iir_Kind_Range_Array_Attribute => - declare - Ptr : O_Dnode; - Rinfo : Type_Info_Acc; - begin - Rinfo := Get_Info (Get_Base_Type (Range_Type)); - Open_Temp; - Ptr := Create_Temp_Ptr - (Rinfo.T.Range_Ptr_Type, - Chap14.Translate_Range_Array_Attribute (Arange)); - Copy_Range (Res_Ptr, Ptr, Rinfo); - Close_Temp; - end; - when Iir_Kind_Reverse_Range_Array_Attribute => - Translate_Reverse_Range_Ptr - (Res_Ptr, - Chap14.Translate_Range_Array_Attribute (Arange), - Range_Type); - when Iir_Kind_Range_Expression => - Translate_Range_Expression_Ptr (Res_Ptr, Arange, Range_Type); - when others => - Error_Kind ("translate_range_ptr", Arange); - end case; - end Translate_Range_Ptr; - - procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir) - is - begin - case Get_Kind (Arange) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - if not Is_Anonymous_Type_Definition (Arange) then - declare - Ptr : O_Dnode; - Rinfo : Type_Info_Acc; - begin - Rinfo := Get_Info (Arange); - Open_Temp; - Ptr := Create_Temp_Ptr - (Rinfo.T.Range_Ptr_Type, Get_Var (Rinfo.T.Range_Var)); - Copy_Range (Res_Ptr, Ptr, Rinfo); - Close_Temp; - end; - else - Translate_Range_Ptr (Res_Ptr, - Get_Range_Constraint (Arange), - Get_Base_Type (Arange)); - end if; - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute - | Iir_Kind_Range_Expression => - Translate_Range_Ptr (Res_Ptr, Arange, Get_Type (Arange)); - when others => - Error_Kind ("translate_discrete_range_ptr", Arange); - end case; - end Translate_Discrete_Range_Ptr; - - function Translate_Range (Arange : Iir; Range_Type : Iir) - return O_Lnode is - begin - case Get_Kind (Arange) is - when Iir_Kinds_Denoting_Name => - return Translate_Range (Get_Named_Entity (Arange), Range_Type); - when Iir_Kind_Subtype_Declaration => - -- Must be a scalar subtype. Range of types is static. - return Get_Var (Get_Info (Get_Type (Arange)).T.Range_Var); - when Iir_Kind_Range_Array_Attribute => - return Chap14.Translate_Range_Array_Attribute (Arange); - when Iir_Kind_Reverse_Range_Array_Attribute => - declare - Res : O_Dnode; - Res_Ptr : O_Dnode; - Rinfo : Type_Info_Acc; - begin - Rinfo := Get_Info (Range_Type); - Res := Create_Temp (Rinfo.T.Range_Type); - Open_Temp; - Res_Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, - New_Obj (Res)); - Translate_Reverse_Range_Ptr - (Res_Ptr, - Chap14.Translate_Range_Array_Attribute (Arange), - Range_Type); - Close_Temp; - return New_Obj (Res); - end; - when Iir_Kind_Range_Expression => - declare - Res : O_Dnode; - Ptr : O_Dnode; - T_Info : Type_Info_Acc; - begin - T_Info := Get_Info (Range_Type); - Res := Create_Temp (T_Info.T.Range_Type); - Open_Temp; - Ptr := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, - New_Obj (Res)); - Translate_Range_Expression_Ptr (Ptr, Arange, Range_Type); - Close_Temp; - return New_Obj (Res); - end; - when others => - Error_Kind ("translate_range", Arange); - end case; - return O_Lnode_Null; - end Translate_Range; - - function Translate_Static_Range (Arange : Iir; Range_Type : Iir) - return O_Cnode - is - Constr : O_Record_Aggr_List; - Res : O_Cnode; - T_Info : Type_Info_Acc; - begin - T_Info := Get_Info (Range_Type); - Start_Record_Aggr (Constr, T_Info.T.Range_Type); - New_Record_Aggr_El - (Constr, Chap7.Translate_Static_Range_Left (Arange, Range_Type)); - New_Record_Aggr_El - (Constr, Chap7.Translate_Static_Range_Right (Arange, Range_Type)); - New_Record_Aggr_El - (Constr, Chap7.Translate_Static_Range_Dir (Arange)); - if T_Info.T.Range_Length /= O_Fnode_Null then - New_Record_Aggr_El - (Constr, Chap7.Translate_Static_Range_Length (Arange)); - end if; - Finish_Record_Aggr (Constr, Res); - return Res; - end Translate_Static_Range; - - procedure Translate_Predefined_Array_Compare (Subprg : Iir) - is - procedure Gen_Compare (L, R : O_Dnode) - is - If_Blk1, If_Blk2 : O_If_Block; - begin - Start_If_Stmt - (If_Blk1, - New_Compare_Op (ON_Neq, New_Obj_Value (L), New_Obj_Value (R), - Ghdl_Bool_Type)); - Start_If_Stmt - (If_Blk2, - New_Compare_Op (ON_Gt, New_Obj_Value (L), New_Obj_Value (R), - Ghdl_Bool_Type)); - New_Return_Stmt (New_Lit (Ghdl_Compare_Gt)); - New_Else_Stmt (If_Blk2); - New_Return_Stmt (New_Lit (Ghdl_Compare_Lt)); - Finish_If_Stmt (If_Blk2); - Finish_If_Stmt (If_Blk1); - end Gen_Compare; - - Arr_Type : constant Iir_Array_Type_Definition := - Get_Type (Get_Interface_Declaration_Chain (Subprg)); - Info : constant Type_Info_Acc := Get_Info (Arr_Type); - Id : constant Name_Id := - Get_Identifier (Get_Type_Declarator (Arr_Type)); - Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); - - F_Info : Subprg_Info_Acc; - L, R : O_Dnode; - Interface_List : O_Inter_List; - If_Blk : O_If_Block; - Var_L_Len, Var_R_Len : O_Dnode; - Var_L_El, Var_R_El : O_Dnode; - Var_I, Var_Len : O_Dnode; - Label : O_Snode; - El_Otype : O_Tnode; - begin - F_Info := Add_Info (Subprg, Kind_Subprg); - --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); - - -- Create function. - Start_Function_Decl (Interface_List, Create_Identifier (Id, "_CMP"), - Global_Storage, Ghdl_Compare_Type); - New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); - New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); - Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); - - if Global_Storage = O_Storage_External then - return; - end if; - - El_Otype := Get_Ortho_Type - (Get_Element_Subtype (Arr_Type), Mode_Value); - Start_Subprogram_Body (F_Info.Ortho_Func); - -- Compute length of L and R. - New_Var_Decl (Var_L_Len, Wki_L_Len, - O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_R_Len, Wki_R_Len, - O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - New_Assign_Stmt (New_Obj (Var_L_Len), - Chap6.Get_Array_Bound_Length - (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); - New_Assign_Stmt (New_Obj (Var_R_Len), - Chap6.Get_Array_Bound_Length - (Dp2M (R, Info, Mode_Value), Arr_Type, 1)); - -- Find the minimum length. - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Ge, - New_Obj_Value (Var_L_Len), - New_Obj_Value (Var_R_Len), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_R_Len)); - New_Else_Stmt (If_Blk); - New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_L_Len)); - Finish_If_Stmt (If_Blk); - - -- for each element, compare elements; if not equal return the - -- comparaison result. - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - New_Obj_Value (Var_Len), - Ghdl_Bool_Type)); - -- Compare the length and return the result. - Gen_Compare (Var_L_Len, Var_R_Len); - New_Return_Stmt (New_Lit (Ghdl_Compare_Eq)); - Finish_If_Stmt (If_Blk); - Start_Declare_Stmt; - New_Var_Decl (Var_L_El, Get_Identifier ("l_el"), O_Storage_Local, - El_Otype); - New_Var_Decl (Var_R_El, Get_Identifier ("r_el"), O_Storage_Local, - El_Otype); - New_Assign_Stmt - (New_Obj (Var_L_El), - M2E (Chap3.Index_Base - (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)), - Arr_Type, - New_Obj_Value (Var_I)))); - New_Assign_Stmt - (New_Obj (Var_R_El), - M2E (Chap3.Index_Base - (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)), - Arr_Type, - New_Obj_Value (Var_I)))); - Gen_Compare (Var_L_El, Var_R_El); - Finish_Declare_Stmt; - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Subprogram_Body; - end Translate_Predefined_Array_Compare; - - -- Find the declaration of the predefined function IMP in type - -- definition BASE_TYPE. - function Find_Predefined_Function - (Base_Type : Iir; Imp : Iir_Predefined_Functions) - return Iir - is - El : Iir; - begin - El := Get_Chain (Get_Type_Declarator (Base_Type)); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration => - if Get_Implicit_Definition (El) = Imp then - return El; - else - El := Get_Chain (El); - end if; - when others => - raise Internal_Error; - end case; - end loop; - raise Internal_Error; - end Find_Predefined_Function; - - function Translate_Equality (L, R : Mnode; Etype : Iir) - return O_Enode - is - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Type_Info (L); - case Tinfo.Type_Mode is - when Type_Mode_Scalar - | Type_Mode_Acc => - return New_Compare_Op (ON_Eq, M2E (L), M2E (R), - Ghdl_Bool_Type); - when Type_Mode_Fat_Acc => - -- a fat pointer. - declare - B : Type_Info_Acc; - Ln, Rn : Mnode; - V1, V2 : O_Enode; - begin - B := Get_Info (Get_Designated_Type (Etype)); - Ln := Stabilize (L); - Rn := Stabilize (R); - V1 := New_Compare_Op - (ON_Eq, - New_Value (New_Selected_Element - (M2Lv (Ln), B.T.Base_Field (Mode_Value))), - New_Value (New_Selected_Element - (M2Lv (Rn), B.T.Base_Field (Mode_Value))), - Std_Boolean_Type_Node); - V2 := New_Compare_Op - (ON_Eq, - New_Value (New_Selected_Element - (M2Lv (Ln), B.T.Bounds_Field (Mode_Value))), - New_Value (New_Selected_Element - (M2Lv (Rn), B.T.Bounds_Field (Mode_Value))), - Std_Boolean_Type_Node); - return New_Dyadic_Op (ON_And, V1, V2); - end; - - when Type_Mode_Array => - declare - Lc, Rc : O_Enode; - Base_Type : Iir_Array_Type_Definition; - Func : Iir; - begin - Base_Type := Get_Base_Type (Etype); - Lc := Translate_Implicit_Conv - (M2E (L), Etype, Base_Type, Mode_Value, Null_Iir); - Rc := Translate_Implicit_Conv - (M2E (R), Etype, Base_Type, Mode_Value, Null_Iir); - Func := Find_Predefined_Function - (Base_Type, Iir_Predefined_Array_Equality); - return Translate_Predefined_Lib_Operator (Lc, Rc, Func); - end; - - when Type_Mode_Record => - declare - Func : Iir; - begin - Func := Find_Predefined_Function - (Get_Base_Type (Etype), Iir_Predefined_Record_Equality); - return Translate_Predefined_Lib_Operator - (M2E (L), M2E (R), Func); - end; - - when Type_Mode_Unknown - | Type_Mode_File - | Type_Mode_Fat_Array - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Translate_Equality; - - procedure Translate_Predefined_Array_Equality (Subprg : Iir) - is - F_Info : Subprg_Info_Acc; - Arr_Type : Iir_Array_Type_Definition; - Arr_Ptr_Type : O_Tnode; - Info : Type_Info_Acc; - Id : Name_Id; - Var_L, Var_R : O_Dnode; - L, R : Mnode; - Interface_List : O_Inter_List; - Indexes : Iir_List; - Nbr_Indexes : Natural; - If_Blk : O_If_Block; - Var_I : O_Dnode; - Var_Len : O_Dnode; - Label : O_Snode; - Le, Re : Mnode; - El_Type : Iir; - begin - Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); - El_Type := Get_Element_Subtype (Arr_Type); - Info := Get_Info (Arr_Type); - Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); - Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); - - F_Info := Add_Info (Subprg, Kind_Subprg); - - -- Create function. - Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), - Global_Storage, Std_Boolean_Type_Node); - Subprgs.Create_Subprg_Instance (Interface_List, Subprg); - New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); - New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); - Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); - - if Global_Storage = O_Storage_External then - return; - end if; - - L := Dp2M (Var_L, Info, Mode_Value); - R := Dp2M (Var_R, Info, Mode_Value); - - Indexes := Get_Index_Subtype_List (Arr_Type); - Nbr_Indexes := Get_Nbr_Elements (Indexes); - - Start_Subprogram_Body (F_Info.Ortho_Func); - Subprgs.Start_Subprg_Instance_Use (Subprg); - -- for each dimension: if length mismatch: return false - for I in 1 .. Nbr_Indexes loop - Start_If_Stmt - (If_Blk, - New_Compare_Op - (ON_Neq, - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (L, Arr_Type, I))), - M2E (Chap3.Range_To_Length - (Chap3.Get_Array_Range (R, Arr_Type, I))), - Std_Boolean_Type_Node)); - New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); - Finish_If_Stmt (If_Blk); - end loop; - - -- for each element: if element is not equal, return false - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); - Open_Temp; - New_Assign_Stmt (New_Obj (Var_Len), - Chap3.Get_Array_Length (L, Arr_Type)); - Close_Temp; - Init_Var (Var_I); - Start_Loop_Stmt (Label); - -- If the end of the array is reached, return TRUE. - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - New_Obj_Value (Var_Len), - Ghdl_Bool_Type)); - New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); - Finish_If_Stmt (If_Blk); - Open_Temp; - Le := Chap3.Index_Base (Chap3.Get_Array_Base (L), Arr_Type, - New_Obj_Value (Var_I)); - Re := Chap3.Index_Base (Chap3.Get_Array_Base (R), Arr_Type, - New_Obj_Value (Var_I)); - Start_If_Stmt - (If_Blk, - New_Monadic_Op (ON_Not, Translate_Equality (Le, Re, El_Type))); - New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); - Finish_If_Stmt (If_Blk); - Close_Temp; - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Subprgs.Finish_Subprg_Instance_Use (Subprg); - Finish_Subprogram_Body; - end Translate_Predefined_Array_Equality; - - procedure Translate_Predefined_Record_Equality (Subprg : Iir) - is - F_Info : Subprg_Info_Acc; - Rec_Type : Iir_Record_Type_Definition; - Rec_Ptr_Type : O_Tnode; - Info : Type_Info_Acc; - Id : Name_Id; - Var_L, Var_R : O_Dnode; - L, R : Mnode; - Interface_List : O_Inter_List; - If_Blk : O_If_Block; - Le, Re : Mnode; - - El_List : Iir_List; - El : Iir_Element_Declaration; - begin - Rec_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); - Info := Get_Info (Rec_Type); - Id := Get_Identifier (Get_Type_Declarator (Rec_Type)); - Rec_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); - - F_Info := Add_Info (Subprg, Kind_Subprg); - --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); - - -- Create function. - Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), - Global_Storage, Std_Boolean_Type_Node); - Subprgs.Create_Subprg_Instance (Interface_List, Subprg); - New_Interface_Decl (Interface_List, Var_L, Wki_Left, Rec_Ptr_Type); - New_Interface_Decl (Interface_List, Var_R, Wki_Right, Rec_Ptr_Type); - Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); - - if Global_Storage = O_Storage_External then - return; - end if; - - Start_Subprogram_Body (F_Info.Ortho_Func); - Subprgs.Start_Subprg_Instance_Use (Subprg); - - L := Dp2M (Var_L, Info, Mode_Value); - R := Dp2M (Var_R, Info, Mode_Value); - - -- Compare each element. - El_List := Get_Elements_Declaration_List (Rec_Type); - for I in Natural loop - El := Get_Nth_Element (El_List, I); - exit when El = Null_Iir; - Le := Chap6.Translate_Selected_Element (L, El); - Re := Chap6.Translate_Selected_Element (R, El); - - Open_Temp; - Start_If_Stmt - (If_Blk, - New_Monadic_Op (ON_Not, - Translate_Equality (Le, Re, Get_Type (El)))); - New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); - Finish_If_Stmt (If_Blk); - Close_Temp; - end loop; - New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); - Subprgs.Finish_Subprg_Instance_Use (Subprg); - Finish_Subprogram_Body; - end Translate_Predefined_Record_Equality; - - procedure Translate_Predefined_Array_Array_Concat (Subprg : Iir) - is - F_Info : Subprg_Info_Acc; - Arr_Type : Iir_Array_Type_Definition; - Arr_Ptr_Type : O_Tnode; - - -- Info for the array type. - Info : Type_Info_Acc; - - -- Info for the index type. - Iinfo : Type_Info_Acc; - Index_Type : Iir; - - Index_Otype : O_Tnode; - Id : Name_Id; - Interface_List : O_Inter_List; - Var_Res, Var_L, Var_R : O_Dnode; - Res, L, R : Mnode; - Var_Length, Var_L_Len, Var_R_Len : O_Dnode; - Var_Bounds, Var_Right : O_Dnode; - V_Bounds : Mnode; - If_Blk : O_If_Block; - begin - Arr_Type := Get_Return_Type (Subprg); - Info := Get_Info (Arr_Type); - Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); - Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); - - F_Info := Add_Info (Subprg, Kind_Subprg); - F_Info.Use_Stack2 := True; - - -- Create function. - Start_Procedure_Decl - (Interface_List, Create_Identifier (Id, "_CONCAT"), Global_Storage); - -- Note: contrary to user function which returns composite value - -- via a result record, a concatenation returns its value without - -- the use of the record. - Subprgs.Create_Subprg_Instance (Interface_List, Subprg); - New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); - New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); - New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); - Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); - - if Global_Storage = O_Storage_External then - return; - end if; - - Index_Type := Get_Index_Type (Arr_Type, 0); - Iinfo := Get_Info (Index_Type); - Index_Otype := Iinfo.Ortho_Type (Mode_Value); - - Start_Subprogram_Body (F_Info.Ortho_Func); - Subprgs.Start_Subprg_Instance_Use (Subprg); - New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, - Ghdl_Index_Type); - New_Var_Decl (Var_L_Len, Wki_L_Len, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_R_Len, Wki_R_Len, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_Bounds, Get_Identifier ("bounds"), O_Storage_Local, - Info.T.Bounds_Ptr_Type); - - L := Dp2M (Var_L, Info, Mode_Value); - R := Dp2M (Var_R, Info, Mode_Value); - Res := Dp2M (Var_Res, Info, Mode_Value); - V_Bounds := Dp2M (Var_Bounds, Info, Mode_Value, - Info.T.Bounds_Type, Info.T.Bounds_Ptr_Type); - - -- Compute length. - New_Assign_Stmt - (New_Obj (Var_L_Len), Chap3.Get_Array_Length (L, Arr_Type)); - New_Assign_Stmt - (New_Obj (Var_R_Len), Chap3.Get_Array_Length (R, Arr_Type)); - New_Assign_Stmt - (New_Obj (Var_Length), New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_L_Len), - New_Obj_Value (Var_R_Len))); - - -- Check case where the result is the right operand. - declare - Len : O_Enode; - begin - if Flags.Vhdl_Std = Vhdl_87 then - -- LRM87 7.2.4 - -- [...], unless the left operand is a null array, in which - -- case the result of the concatenation is the right operand. - Len := New_Obj_Value (Var_L_Len); - - else - -- LRM93 7.2.4 - -- If both operands are null arrays, then the result of the - -- concatenation is the right operand. - -- GHDL: since the length type is unsigned, then both operands - -- are null arrays iff the result is a null array. - Len := New_Obj_Value (Var_Length); - end if; - - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - Len, - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); - Copy_Fat_Pointer (Res, R); - New_Return_Stmt; - Finish_If_Stmt (If_Blk); - end; - - -- Allocate bounds. - New_Assign_Stmt - (New_Obj (Var_Bounds), - Gen_Alloc (Alloc_Return, - New_Lit (New_Sizeof (Info.T.Bounds_Type, - Ghdl_Index_Type)), - Info.T.Bounds_Ptr_Type)); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Res)), New_Obj_Value (Var_Bounds)); - - -- Set bound. - if Flags.Vhdl_Std = Vhdl_87 then - -- Set length. - New_Assign_Stmt - (M2Lv (Chap3.Range_To_Length - (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), - New_Obj_Value (Var_Length)); - - -- Set direction, left bound and right bound. - -- LRM87 7.2.4 - -- The left bound of this result is the left bound of the left - -- operand, unless the left operand is a null array, in which - -- case the result of the concatenation is the right operand. - -- The direction of the result is the direction of the left - -- operand, unless the left operand is a null array, in which - -- case the direction of the result is that of the right operand. - declare - Var_Dir, Var_Left : O_Dnode; - Var_Length1 : O_Dnode; - begin - Start_Declare_Stmt; - New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), - O_Storage_Local, Index_Otype); - New_Var_Decl (Var_Dir, Wki_Dir, O_Storage_Local, - Ghdl_Dir_Type_Node); - New_Var_Decl (Var_Left, Get_Identifier ("left_bound"), - O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); - New_Var_Decl (Var_Length1, Get_Identifier ("length_1"), - O_Storage_Local, Ghdl_Index_Type); - New_Assign_Stmt - (New_Obj (Var_Dir), - M2E (Chap3.Range_To_Dir - (Chap3.Get_Array_Range (L, Arr_Type, 1)))); - New_Assign_Stmt - (M2Lv (Chap3.Range_To_Dir - (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), - New_Obj_Value (Var_Dir)); - New_Assign_Stmt - (New_Obj (Var_Left), - M2E (Chap3.Range_To_Left - (Chap3.Get_Array_Range (L, Arr_Type, 1)))); - -- Note this substraction cannot overflow, since LENGTH >= 1. - New_Assign_Stmt - (New_Obj (Var_Length1), - New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Var_Length), - New_Lit (Ghdl_Index_1))); - New_Assign_Stmt - (M2Lv (Chap3.Range_To_Left - (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), - New_Obj_Value (Var_Left)); - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, New_Obj_Value (Var_Dir), - New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Obj (Var_Right), - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_Left), - New_Convert_Ov (New_Obj_Value (Var_Length1), - Index_Otype))); - New_Else_Stmt (If_Blk); - New_Assign_Stmt - (New_Obj (Var_Right), - New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Var_Left), - New_Convert_Ov (New_Obj_Value (Var_Length1), - Index_Otype))); - Finish_If_Stmt (If_Blk); - -- Check the right bounds is inside the bounds of the - -- index type. - Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Subprg); - New_Assign_Stmt - (M2Lv (Chap3.Range_To_Right - (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), - New_Obj_Value (Var_Right)); - Finish_Declare_Stmt; - end; - else - -- LRM93 7.2.4 - -- [...], the direction and bounds of the result are determined - -- as follows: Let S be the index subtype of the base type of the - -- result. The direction of the result of the concatenation is - -- the direction of S, and the left bound of the result is - -- S'LEFT. - declare - Var_Range_Ptr : O_Dnode; - begin - Start_Declare_Stmt; - New_Var_Decl (Var_Range_Ptr, Get_Identifier ("range_ptr"), - O_Storage_Local, Iinfo.T.Range_Ptr_Type); - New_Assign_Stmt - (New_Obj (Var_Range_Ptr), - M2Addr (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))); - Chap3.Create_Range_From_Length - (Index_Type, Var_Length, Var_Range_Ptr, Subprg); - Finish_Declare_Stmt; - end; - end if; - - -- Allocate array base. - Chap3.Allocate_Fat_Array_Base (Alloc_Return, Res, Arr_Type); - - -- Copy left. - declare - V_Arr : O_Dnode; - Var_Arr : Mnode; - begin - Open_Temp; - V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); - Var_Arr := Dv2M (V_Arr, Info, Mode_Value); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), - M2Addr (Chap3.Get_Array_Bounds (L))); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Base (Var_Arr)), - M2Addr (Chap3.Get_Array_Base (Res))); - Chap3.Translate_Object_Copy - (Var_Arr, New_Obj_Value (Var_L), Arr_Type); - Close_Temp; - end; - - -- Copy right. - declare - V_Arr : O_Dnode; - Var_Arr : Mnode; - begin - Open_Temp; - V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); - Var_Arr := Dv2M (V_Arr, Info, Mode_Value); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), - M2Addr (Chap3.Get_Array_Bounds (R))); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Base (Var_Arr)), - M2Addr (Chap3.Slice_Base (Chap3.Get_Array_Base (Res), - Arr_Type, - New_Obj_Value (Var_L_Len)))); - Chap3.Translate_Object_Copy - (Var_Arr, New_Obj_Value (Var_R), Arr_Type); - Close_Temp; - end; - Subprgs.Finish_Subprg_Instance_Use (Subprg); - Finish_Subprogram_Body; - end Translate_Predefined_Array_Array_Concat; - - procedure Translate_Predefined_Array_Logical (Subprg : Iir) - is - Arr_Type : constant Iir_Array_Type_Definition := - Get_Type (Get_Interface_Declaration_Chain (Subprg)); - -- Info for the array type. - Info : constant Type_Info_Acc := Get_Info (Arr_Type); - -- Identifier of the type. - Id : constant Name_Id := - Get_Identifier (Get_Type_Declarator (Arr_Type)); - Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); - F_Info : Subprg_Info_Acc; - Interface_List : O_Inter_List; - Var_Res : O_Dnode; - Res : Mnode; - L, R : O_Dnode; - Var_Length, Var_I : O_Dnode; - Var_Base, Var_L_Base, Var_R_Base : O_Dnode; - If_Blk : O_If_Block; - Label : O_Snode; - Name : O_Ident; - Is_Monadic : Boolean; - El, L_El : O_Enode; - Op : ON_Op_Kind; - Do_Invert : Boolean; - begin - F_Info := Add_Info (Subprg, Kind_Subprg); - --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); - F_Info.Use_Stack2 := True; - - Is_Monadic := False; - case Get_Implicit_Definition (Subprg) is - when Iir_Predefined_TF_Array_And => - Name := Create_Identifier (Id, "_AND"); - Op := ON_And; - Do_Invert := False; - when Iir_Predefined_TF_Array_Or => - Name := Create_Identifier (Id, "_OR"); - Op := ON_Or; - Do_Invert := False; - when Iir_Predefined_TF_Array_Nand => - Name := Create_Identifier (Id, "_NAND"); - Op := ON_And; - Do_Invert := True; - when Iir_Predefined_TF_Array_Nor => - Name := Create_Identifier (Id, "_NOR"); - Op := ON_Or; - Do_Invert := True; - when Iir_Predefined_TF_Array_Xor => - Name := Create_Identifier (Id, "_XOR"); - Op := ON_Xor; - Do_Invert := False; - when Iir_Predefined_TF_Array_Xnor => - Name := Create_Identifier (Id, "_XNOR"); - Op := ON_Xor; - Do_Invert := True; - when Iir_Predefined_TF_Array_Not => - Name := Create_Identifier (Id, "_NOT"); - Is_Monadic := True; - Op := ON_Not; - Do_Invert := False; - when others => - raise Internal_Error; - end case; - - -- Create function. - Start_Procedure_Decl (Interface_List, Name, Global_Storage); - -- Note: contrary to user function which returns composite value - -- via a result record, a concatenation returns its value without - -- the use of the record. - New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); - New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); - if not Is_Monadic then - New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); - end if; - Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); - - if Global_Storage = O_Storage_External then - return; - end if; - - Start_Subprogram_Body (F_Info.Ortho_Func); - New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, - Ghdl_Index_Type); - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_Base, Get_Identifier ("base"), O_Storage_Local, - Info.T.Base_Ptr_Type (Mode_Value)); - New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), O_Storage_Local, - Info.T.Base_Ptr_Type (Mode_Value)); - if not Is_Monadic then - New_Var_Decl - (Var_R_Base, Get_Identifier ("r_base"), O_Storage_Local, - Info.T.Base_Ptr_Type (Mode_Value)); - end if; - Open_Temp; - -- Get length of LEFT. - New_Assign_Stmt (New_Obj (Var_Length), - Chap6.Get_Array_Bound_Length - (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); - -- If dyadic, check RIGHT has the same length. - if not Is_Monadic then - Chap6.Check_Bound_Error - (New_Compare_Op (ON_Neq, - New_Obj_Value (Var_Length), - Chap6.Get_Array_Bound_Length - (Dp2M (R, Info, Mode_Value), Arr_Type, 1), - Ghdl_Bool_Type), - Subprg, 0); - end if; - - -- Create the result from LEFT bound. - Res := Dp2M (Var_Res, Info, Mode_Value); - Chap3.Translate_Object_Allocation - (Res, Alloc_Return, Arr_Type, - Chap3.Get_Array_Bounds (Dp2M (L, Info, Mode_Value))); - New_Assign_Stmt - (New_Obj (Var_Base), M2Addr (Chap3.Get_Array_Base (Res))); - New_Assign_Stmt - (New_Obj (Var_L_Base), - M2Addr (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)))); - if not Is_Monadic then - New_Assign_Stmt - (New_Obj (Var_R_Base), - M2Addr (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)))); - end if; - - -- Do the logical operation on each element. - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - New_Return_Stmt; - Finish_If_Stmt (If_Blk); - L_El := New_Value (New_Indexed_Element - (New_Acc_Value (New_Obj (Var_L_Base)), - New_Obj_Value (Var_I))); - if Is_Monadic then - El := New_Monadic_Op (Op, L_El); - else - El := New_Dyadic_Op - (Op, L_El, - New_Value (New_Indexed_Element - (New_Acc_Value (New_Obj (Var_R_Base)), - New_Obj_Value (Var_I)))); - end if; - if Do_Invert then - El := New_Monadic_Op (ON_Not, El); - end if; - - New_Assign_Stmt (New_Indexed_Element - (New_Acc_Value (New_Obj (Var_Base)), - New_Obj_Value (Var_I)), - El); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Close_Temp; - Finish_Subprogram_Body; - end Translate_Predefined_Array_Logical; - - procedure Translate_Predefined_Array_Shift (Subprg : Iir) - is - F_Info : Subprg_Info_Acc; - Inter : Iir; - Arr_Type : Iir_Array_Type_Definition; - Arr_Ptr_Type : O_Tnode; - Int_Type : O_Tnode; - -- Info for the array type. - Info : Type_Info_Acc; - Id : Name_Id; - Interface_List : O_Inter_List; - Var_Res : O_Dnode; - Var_L, Var_R : O_Dnode; - Name : O_Ident; - - type Shift_Kind is (Sh_Logical, Sh_Arith, Rotation); - Shift : Shift_Kind; - - -- Body; - Var_Length, Var_I, Var_I1 : O_Dnode; - Var_Res_Base, Var_L_Base : O_Dnode; - Var_Rl : O_Dnode; - Var_E : O_Dnode; - L : Mnode; - If_Blk, If_Blk1 : O_If_Block; - Label : O_Snode; - Res : Mnode; - - procedure Do_Shift (To_Right : Boolean) - is - Tmp : O_Enode; - begin - -- LEFT: - -- * I := 0; - if not To_Right then - Init_Var (Var_I); - end if; - - -- * If R < LENGTH then - Start_If_Stmt (If_Blk1, - New_Compare_Op (ON_Lt, - New_Obj_Value (Var_Rl), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - -- Shift the elements (that remains in the result). - -- RIGHT: - -- * for I = R to LENGTH - 1 loop - -- * RES[I] := L[I - R] - -- LEFT: - -- * for I = 0 to LENGTH - R loop - -- * RES[I] := L[R + I] - if To_Right then - New_Assign_Stmt (New_Obj (Var_I), New_Obj_Value (Var_Rl)); - Init_Var (Var_I1); - else - New_Assign_Stmt (New_Obj (Var_I1), New_Obj_Value (Var_Rl)); - end if; - Start_Loop_Stmt (Label); - if To_Right then - Tmp := New_Obj_Value (Var_I); - else - Tmp := New_Obj_Value (Var_I1); - end if; - Gen_Exit_When (Label, New_Compare_Op (ON_Ge, - Tmp, - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), - New_Obj_Value (Var_I)), - New_Value - (New_Indexed_Acc_Value (New_Obj (Var_L_Base), - New_Obj_Value (Var_I1)))); - Inc_Var (Var_I); - Inc_Var (Var_I1); - Finish_Loop_Stmt (Label); - -- RIGHT: - -- * else - -- * R := LENGTH; - if To_Right then - New_Else_Stmt (If_Blk1); - New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); - end if; - Finish_If_Stmt (If_Blk1); - - -- Pad the result. - -- RIGHT: - -- * For I = 0 to R - 1 - -- * RES[I] := 0/L[0/LENGTH-1] - -- LEFT: - -- * For I = LENGTH - R to LENGTH - 1 - -- * RES[I] := 0/L[0/LENGTH-1] - if To_Right then - Init_Var (Var_I); - else - -- I is yet correctly set. - null; - end if; - if Shift = Sh_Arith then - if To_Right then - Tmp := New_Lit (Ghdl_Index_0); - else - Tmp := New_Dyadic_Op - (ON_Sub_Ov, - New_Obj_Value (Var_Length), - New_Lit (Ghdl_Index_1)); - end if; - New_Assign_Stmt - (New_Obj (Var_E), - New_Value (New_Indexed_Acc_Value (New_Obj (Var_L_Base), - Tmp))); - end if; - Start_Loop_Stmt (Label); - if To_Right then - Tmp := New_Obj_Value (Var_Rl); - else - Tmp := New_Obj_Value (Var_Length); - end if; - Gen_Exit_When (Label, New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - Tmp, - Ghdl_Bool_Type)); - case Shift is - when Sh_Logical => - declare - Enum_List : Iir_List; - begin - Enum_List := Get_Enumeration_Literal_List - (Get_Base_Type (Get_Element_Subtype (Arr_Type))); - Tmp := New_Lit - (Get_Ortho_Expr (Get_First_Element (Enum_List))); - end; - when Sh_Arith => - Tmp := New_Obj_Value (Var_E); - when Rotation => - raise Internal_Error; - end case; - - New_Assign_Stmt - (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), - New_Obj_Value (Var_I)), Tmp); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - end Do_Shift; - begin - Inter := Get_Interface_Declaration_Chain (Subprg); - - Info := Get_Info (Get_Type (Get_Chain (Inter))); - Int_Type := Info.Ortho_Type (Mode_Value); - - Arr_Type := Get_Type (Inter); - Info := Get_Info (Arr_Type); - Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); - Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); - - F_Info := Add_Info (Subprg, Kind_Subprg); - --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); - F_Info.Use_Stack2 := True; - - case Get_Implicit_Definition (Subprg) is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl => - -- Shift logical. - Name := Create_Identifier (Id, "_SHL"); - Shift := Sh_Logical; - when Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra => - -- Shift arithmetic. - Name := Create_Identifier (Id, "_SHA"); - Shift := Sh_Arith; - when Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - -- Rotation - Name := Create_Identifier (Id, "_ROT"); - Shift := Rotation; - when others => - raise Internal_Error; - end case; - - -- Create function. - Start_Procedure_Decl (Interface_List, Name, Global_Storage); - -- Note: contrary to user function which returns composite value - -- via a result record, a shift returns its value without - -- the use of the record. - New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); - New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); - New_Interface_Decl (Interface_List, Var_R, Wki_Right, Int_Type); - Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); - - if Global_Storage = O_Storage_External then - return; - end if; - - -- Body - Start_Subprogram_Body (F_Info.Ortho_Func); - New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, - Ghdl_Index_Type); - if Shift /= Rotation then - New_Var_Decl (Var_Rl, Get_Identifier ("rl"), O_Storage_Local, - Ghdl_Index_Type); - end if; - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_I1, Get_Identifier ("I1"), O_Storage_Local, - Ghdl_Index_Type); - New_Var_Decl (Var_Res_Base, Get_Identifier ("res_base"), - O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); - New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), - O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); - if Shift = Sh_Arith then - New_Var_Decl (Var_E, Get_Identifier ("E"), O_Storage_Local, - Get_Info (Get_Element_Subtype (Arr_Type)). - Ortho_Type (Mode_Value)); - end if; - Res := Dp2M (Var_Res, Info, Mode_Value); - L := Dp2M (Var_L, Info, Mode_Value); - - -- LRM93 7.2.3 - -- The index subtypes of the return values of all shift operators is - -- the same as the index subtype of their left arguments. - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Bounds (Res)), - M2Addr (Chap3.Get_Array_Bounds (L))); - - -- Get length of LEFT. - New_Assign_Stmt (New_Obj (Var_Length), - Chap3.Get_Array_Length (L, Arr_Type)); - - -- LRM93 7.2.3 [6 times] - -- That is, if R is 0 or L is a null array, the return value is L. - Start_If_Stmt - (If_Blk, - New_Dyadic_Op - (ON_Or, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_R), - New_Lit (New_Signed_Literal (Int_Type, 0)), - Ghdl_Bool_Type), - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Length), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type))); - New_Assign_Stmt - (M2Lp (Chap3.Get_Array_Base (Res)), - M2Addr (Chap3.Get_Array_Base (L))); - New_Return_Stmt; - Finish_If_Stmt (If_Blk); - - -- Allocate base. - New_Assign_Stmt - (New_Obj (Var_Res_Base), - Gen_Alloc (Alloc_Return, New_Obj_Value (Var_Length), - Info.T.Base_Ptr_Type (Mode_Value))); - New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), - New_Obj_Value (Var_Res_Base)); - - New_Assign_Stmt (New_Obj (Var_L_Base), - M2Addr (Chap3.Get_Array_Base (L))); - - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Gt, - New_Obj_Value (Var_R), - New_Lit (New_Signed_Literal (Int_Type, - 0)), - Ghdl_Bool_Type)); - -- R > 0. - -- Ie, to the right - case Shift is - when Rotation => - -- * I1 := LENGTH - (R mod LENGTH) - New_Assign_Stmt - (New_Obj (Var_I1), - New_Dyadic_Op - (ON_Sub_Ov, - New_Obj_Value (Var_Length), - New_Dyadic_Op (ON_Mod_Ov, - New_Convert_Ov (New_Obj_Value (Var_R), - Ghdl_Index_Type), - New_Obj_Value (Var_Length)))); - - when Sh_Logical - | Sh_Arith => - -- Real SRL or SRA. - New_Assign_Stmt - (New_Obj (Var_Rl), - New_Convert_Ov (New_Obj_Value (Var_R), Ghdl_Index_Type)); - - Do_Shift (True); - end case; - - New_Else_Stmt (If_Blk); - - -- R < 0, to the left. - case Shift is - when Rotation => - -- * I1 := (-R) mod LENGTH - New_Assign_Stmt - (New_Obj (Var_I1), - New_Dyadic_Op (ON_Mod_Ov, - New_Convert_Ov - (New_Monadic_Op (ON_Neg_Ov, - New_Obj_Value (Var_R)), - Ghdl_Index_Type), - New_Obj_Value (Var_Length))); - when Sh_Logical - | Sh_Arith => - -- Real SLL or SLA. - New_Assign_Stmt - (New_Obj (Var_Rl), - New_Convert_Ov (New_Monadic_Op (ON_Neg_Ov, - New_Obj_Value (Var_R)), - Ghdl_Index_Type)); - - Do_Shift (False); - end case; - Finish_If_Stmt (If_Blk); - - if Shift = Rotation then - -- * If I1 = LENGTH then - -- * I1 := 0 - Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I1), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - Init_Var (Var_I1); - Finish_If_Stmt (If_Blk); - - -- * for I = 0 to LENGTH - 1 loop - -- * RES[I] := L[I1]; - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When (Label, New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), - New_Obj_Value (Var_I)), - New_Value - (New_Indexed_Acc_Value (New_Obj (Var_L_Base), - New_Obj_Value (Var_I1)))); - Inc_Var (Var_I); - -- * I1 := I1 + 1 - Inc_Var (Var_I1); - -- * If I1 = LENGTH then - -- * I1 := 0 - Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I1), - New_Obj_Value (Var_Length), - Ghdl_Bool_Type)); - Init_Var (Var_I1); - Finish_If_Stmt (If_Blk); - Finish_Loop_Stmt (Label); - end if; - Finish_Subprogram_Body; - end Translate_Predefined_Array_Shift; - - procedure Translate_File_Subprogram (Subprg : Iir; File_Type : Iir) - is - Etype : Iir; - Tinfo : Type_Info_Acc; - Kind : Iir_Predefined_Functions; - F_Info : Subprg_Info_Acc; - Name : O_Ident; - Inter_List : O_Inter_List; - Id : Name_Id; - Var_File : O_Dnode; - Var_Val : O_Dnode; - - procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode); - - procedure Translate_Rw_Array - (Val : Mnode; Val_Type : Iir; Var_Max : O_Dnode; Proc : O_Dnode) - is - Var_It : O_Dnode; - Label : O_Snode; - begin - Var_It := Create_Temp (Ghdl_Index_Type); - Init_Var (Var_It); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_It), - New_Obj_Value (Var_Max), - Ghdl_Bool_Type)); - Translate_Rw - (Chap3.Index_Base (Val, Val_Type, New_Obj_Value (Var_It)), - Get_Element_Subtype (Val_Type), Proc); - Inc_Var (Var_It); - Finish_Loop_Stmt (Label); - end Translate_Rw_Array; - - procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode) - is - Val_Info : Type_Info_Acc; - Assocs : O_Assoc_List; - begin - Val_Info := Get_Type_Info (Val); - case Val_Info.Type_Mode is - when Type_Mode_Scalar => - Start_Association (Assocs, Proc); - -- compute file parameter (get an index) - New_Association (Assocs, New_Obj_Value (Var_File)); - -- compute the value. - New_Association - (Assocs, New_Convert_Ov (M2Addr (Val), Ghdl_Ptr_Type)); - -- length. - New_Association - (Assocs, - New_Lit (New_Sizeof (Val_Info.Ortho_Type (Mode_Value), - Ghdl_Index_Type))); - -- call a predefined procedure - New_Procedure_Call (Assocs); - when Type_Mode_Record => - declare - El_List : Iir_List; - El : Iir; - Val1 : Mnode; - begin - Open_Temp; - Val1 := Stabilize (Val); - El_List := Get_Elements_Declaration_List - (Get_Base_Type (Val_Type)); - for I in Natural loop - El := Get_Nth_Element (El_List, I); - exit when El = Null_Iir; - Translate_Rw - (Chap6.Translate_Selected_Element (Val1, El), - Get_Type (El), Proc); - end loop; - Close_Temp; - end; - when Type_Mode_Array => - declare - Var_Max : O_Dnode; - begin - Open_Temp; - Var_Max := Create_Temp (Ghdl_Index_Type); - New_Assign_Stmt - (New_Obj (Var_Max), - Chap3.Get_Array_Type_Length (Val_Type)); - Translate_Rw_Array (Val, Val_Type, Var_Max, Proc); - Close_Temp; - end; - when Type_Mode_Unknown - | Type_Mode_File - | Type_Mode_Acc - | Type_Mode_Fat_Acc - | Type_Mode_Fat_Array - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Translate_Rw; - - procedure Translate_Rw_Length (Var_Length : O_Dnode; Proc : O_Dnode) - is - Assocs : O_Assoc_List; - begin - Start_Association (Assocs, Proc); - New_Association (Assocs, New_Obj_Value (Var_File)); - New_Association - (Assocs, New_Unchecked_Address (New_Obj (Var_Length), - Ghdl_Ptr_Type)); - New_Association - (Assocs, - New_Lit (New_Sizeof (Ghdl_Index_Type, Ghdl_Index_Type))); - New_Procedure_Call (Assocs); - end Translate_Rw_Length; - - Var : Mnode; - begin - Etype := Get_Type (Get_File_Type_Mark (File_Type)); - Tinfo := Get_Info (Etype); - if Tinfo.Type_Mode in Type_Mode_Scalar then - -- Intrinsic. - return; - end if; - - F_Info := Add_Info (Subprg, Kind_Subprg); - --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); - F_Info.Use_Stack2 := False; - - Id := Get_Identifier (Get_Type_Declarator (File_Type)); - Kind := Get_Implicit_Definition (Subprg); - case Kind is - when Iir_Predefined_Write => - Name := Create_Identifier (Id, "_WRITE"); - when Iir_Predefined_Read - | Iir_Predefined_Read_Length => - Name := Create_Identifier (Id, "_READ"); - when others => - raise Internal_Error; - end case; - - -- Create function. - if Kind = Iir_Predefined_Read_Length then - Start_Function_Decl - (Inter_List, Name, Global_Storage, Std_Integer_Otype); - else - Start_Procedure_Decl (Inter_List, Name, Global_Storage); - end if; - Subprgs.Create_Subprg_Instance (Inter_List, Subprg); - - New_Interface_Decl - (Inter_List, Var_File, Get_Identifier ("FILE"), - Ghdl_File_Index_Type); - New_Interface_Decl - (Inter_List, Var_Val, Wki_Val, - Tinfo.Ortho_Ptr_Type (Mode_Value)); - Finish_Subprogram_Decl (Inter_List, F_Info.Ortho_Func); - - if Global_Storage = O_Storage_External then - return; - end if; - - Start_Subprogram_Body (F_Info.Ortho_Func); - Subprgs.Start_Subprg_Instance_Use (Subprg); - Push_Local_Factory; - - Var := Dp2M (Var_Val, Tinfo, Mode_Value); - - case Kind is - when Iir_Predefined_Write => - if Tinfo.Type_Mode = Type_Mode_Fat_Array then - declare - Var_Max : O_Dnode; - begin - Open_Temp; - Var_Max := Create_Temp_Init - (Ghdl_Index_Type, - Chap3.Get_Array_Length (Var, Etype)); - Translate_Rw_Length (Var_Max, Ghdl_Write_Scalar); - Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, - Var_Max, Ghdl_Write_Scalar); - Close_Temp; - end; - else - Translate_Rw (Var, Etype, Ghdl_Write_Scalar); - end if; - when Iir_Predefined_Read => - Translate_Rw (Var, Etype, Ghdl_Read_Scalar); - - when Iir_Predefined_Read_Length => - declare - Var_Len : O_Dnode; - begin - Open_Temp; - Var_Len := Create_Temp (Ghdl_Index_Type); - Translate_Rw_Length (Var_Len, Ghdl_Read_Scalar); - - Chap6.Check_Bound_Error - (New_Compare_Op (ON_Gt, - New_Obj_Value (Var_Len), - Chap3.Get_Array_Length (Var, Etype), - Ghdl_Bool_Type), - Subprg, 1); - Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, - Var_Len, Ghdl_Read_Scalar); - New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_Len), - Std_Integer_Otype)); - Close_Temp; - end; - when others => - raise Internal_Error; - end case; - Subprgs.Finish_Subprg_Instance_Use (Subprg); - Pop_Local_Factory; - Finish_Subprogram_Body; - end Translate_File_Subprogram; - - procedure Init_Implicit_Subprogram_Infos - (Infos : out Implicit_Subprogram_Infos) is - begin - -- Be independant of declaration order since the same subprogram - -- may be used for several implicit operators (eg. array comparaison) - Infos.Arr_Eq_Info := null; - Infos.Arr_Cmp_Info := null; - Infos.Arr_Concat_Info := null; - Infos.Rec_Eq_Info := null; - Infos.Arr_Shl_Info := null; - Infos.Arr_Sha_Info := null; - Infos.Arr_Rot_Info := null; - end Init_Implicit_Subprogram_Infos; - - procedure Translate_Implicit_Subprogram - (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos) - is - Kind : constant Iir_Predefined_Functions := - Get_Implicit_Definition (Subprg); - begin - if Predefined_To_Onop (Kind) /= ON_Nil then - -- Intrinsic. - return; - end if; - - case Kind is - when Iir_Predefined_Error => - raise Internal_Error; - when Iir_Predefined_Boolean_And - | Iir_Predefined_Boolean_Or - | Iir_Predefined_Boolean_Xor - | Iir_Predefined_Boolean_Not - | Iir_Predefined_Enum_Equality - | Iir_Predefined_Enum_Inequality - | Iir_Predefined_Enum_Less - | Iir_Predefined_Enum_Less_Equal - | Iir_Predefined_Enum_Greater - | Iir_Predefined_Enum_Greater_Equal - | Iir_Predefined_Bit_And - | Iir_Predefined_Bit_Or - | Iir_Predefined_Bit_Xor - | Iir_Predefined_Bit_Not - | Iir_Predefined_Integer_Equality - | Iir_Predefined_Integer_Inequality - | Iir_Predefined_Integer_Less - | Iir_Predefined_Integer_Less_Equal - | Iir_Predefined_Integer_Greater - | Iir_Predefined_Integer_Greater_Equal - | Iir_Predefined_Integer_Negation - | Iir_Predefined_Integer_Absolute - | Iir_Predefined_Integer_Plus - | Iir_Predefined_Integer_Minus - | Iir_Predefined_Integer_Mul - | Iir_Predefined_Integer_Div - | Iir_Predefined_Integer_Mod - | Iir_Predefined_Integer_Rem - | Iir_Predefined_Floating_Equality - | Iir_Predefined_Floating_Inequality - | Iir_Predefined_Floating_Less - | Iir_Predefined_Floating_Less_Equal - | Iir_Predefined_Floating_Greater - | Iir_Predefined_Floating_Greater_Equal - | Iir_Predefined_Floating_Negation - | Iir_Predefined_Floating_Absolute - | Iir_Predefined_Floating_Plus - | Iir_Predefined_Floating_Minus - | Iir_Predefined_Floating_Mul - | Iir_Predefined_Floating_Div - | Iir_Predefined_Physical_Equality - | Iir_Predefined_Physical_Inequality - | Iir_Predefined_Physical_Less - | Iir_Predefined_Physical_Less_Equal - | Iir_Predefined_Physical_Greater - | Iir_Predefined_Physical_Greater_Equal - | Iir_Predefined_Physical_Negation - | Iir_Predefined_Physical_Absolute - | Iir_Predefined_Physical_Plus - | Iir_Predefined_Physical_Minus => - pragma Assert (Predefined_To_Onop (Kind) /= ON_Nil); - return; - - when Iir_Predefined_Boolean_Nand - | Iir_Predefined_Boolean_Nor - | Iir_Predefined_Boolean_Xnor - | Iir_Predefined_Bit_Nand - | Iir_Predefined_Bit_Nor - | Iir_Predefined_Bit_Xnor - | Iir_Predefined_Bit_Match_Equality - | Iir_Predefined_Bit_Match_Inequality - | Iir_Predefined_Bit_Match_Less - | Iir_Predefined_Bit_Match_Less_Equal - | Iir_Predefined_Bit_Match_Greater - | Iir_Predefined_Bit_Match_Greater_Equal - | Iir_Predefined_Bit_Condition - | Iir_Predefined_Boolean_Rising_Edge - | Iir_Predefined_Boolean_Falling_Edge - | Iir_Predefined_Bit_Rising_Edge - | Iir_Predefined_Bit_Falling_Edge => - -- Intrinsic. - null; - - when Iir_Predefined_Enum_Minimum - | Iir_Predefined_Enum_Maximum - | Iir_Predefined_Enum_To_String => - -- Intrinsic. - null; - - when Iir_Predefined_Integer_Identity - | Iir_Predefined_Integer_Exp - | Iir_Predefined_Integer_Minimum - | Iir_Predefined_Integer_Maximum - | Iir_Predefined_Integer_To_String => - -- Intrinsic. - null; - when Iir_Predefined_Universal_R_I_Mul - | Iir_Predefined_Universal_I_R_Mul - | Iir_Predefined_Universal_R_I_Div => - -- Intrinsic - null; - - when Iir_Predefined_Physical_Identity - | Iir_Predefined_Physical_Minimum - | Iir_Predefined_Physical_Maximum - | Iir_Predefined_Physical_To_String - | Iir_Predefined_Time_To_String_Unit => - null; - - when Iir_Predefined_Physical_Integer_Mul - | Iir_Predefined_Physical_Integer_Div - | Iir_Predefined_Integer_Physical_Mul - | Iir_Predefined_Physical_Real_Mul - | Iir_Predefined_Physical_Real_Div - | Iir_Predefined_Real_Physical_Mul - | Iir_Predefined_Physical_Physical_Div => - null; - - when Iir_Predefined_Floating_Exp - | Iir_Predefined_Floating_Identity - | Iir_Predefined_Floating_Minimum - | Iir_Predefined_Floating_Maximum - | Iir_Predefined_Floating_To_String - | Iir_Predefined_Real_To_String_Digits - | Iir_Predefined_Real_To_String_Format => - null; - - when Iir_Predefined_Record_Equality - | Iir_Predefined_Record_Inequality => - if Infos.Rec_Eq_Info = null then - Translate_Predefined_Record_Equality (Subprg); - Infos.Rec_Eq_Info := Get_Info (Subprg); - else - Set_Info (Subprg, Infos.Rec_Eq_Info); - end if; - - when Iir_Predefined_Array_Equality - | Iir_Predefined_Array_Inequality - | Iir_Predefined_Bit_Array_Match_Equality - | Iir_Predefined_Bit_Array_Match_Inequality => - if Infos.Arr_Eq_Info = null then - Translate_Predefined_Array_Equality (Subprg); - Infos.Arr_Eq_Info := Get_Info (Subprg); - else - Set_Info (Subprg, Infos.Arr_Eq_Info); - end if; - - when Iir_Predefined_Array_Greater - | Iir_Predefined_Array_Greater_Equal - | Iir_Predefined_Array_Less - | Iir_Predefined_Array_Less_Equal - | Iir_Predefined_Array_Minimum - | Iir_Predefined_Array_Maximum => - if Infos.Arr_Cmp_Info = null then - Translate_Predefined_Array_Compare (Subprg); - Infos.Arr_Cmp_Info := Get_Info (Subprg); - else - Set_Info (Subprg, Infos.Arr_Cmp_Info); - end if; - - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Element_Element_Concat => - if Infos.Arr_Concat_Info = null then - Translate_Predefined_Array_Array_Concat (Subprg); - Infos.Arr_Concat_Info := Get_Info (Subprg); - else - Set_Info (Subprg, Infos.Arr_Concat_Info); - end if; - - when Iir_Predefined_Vector_Minimum - | Iir_Predefined_Vector_Maximum => - null; - - when Iir_Predefined_TF_Array_And - | Iir_Predefined_TF_Array_Or - | Iir_Predefined_TF_Array_Nand - | Iir_Predefined_TF_Array_Nor - | Iir_Predefined_TF_Array_Xor - | Iir_Predefined_TF_Array_Xnor - | Iir_Predefined_TF_Array_Not => - Translate_Predefined_Array_Logical (Subprg); - - when Iir_Predefined_TF_Reduction_And - | Iir_Predefined_TF_Reduction_Or - | Iir_Predefined_TF_Reduction_Nand - | Iir_Predefined_TF_Reduction_Nor - | Iir_Predefined_TF_Reduction_Xor - | Iir_Predefined_TF_Reduction_Xnor - | Iir_Predefined_TF_Reduction_Not - | Iir_Predefined_TF_Array_Element_And - | Iir_Predefined_TF_Element_Array_And - | Iir_Predefined_TF_Array_Element_Or - | Iir_Predefined_TF_Element_Array_Or - | Iir_Predefined_TF_Array_Element_Nand - | Iir_Predefined_TF_Element_Array_Nand - | Iir_Predefined_TF_Array_Element_Nor - | Iir_Predefined_TF_Element_Array_Nor - | Iir_Predefined_TF_Array_Element_Xor - | Iir_Predefined_TF_Element_Array_Xor - | Iir_Predefined_TF_Array_Element_Xnor - | Iir_Predefined_TF_Element_Array_Xnor => - null; - - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl => - if Infos.Arr_Shl_Info = null then - Translate_Predefined_Array_Shift (Subprg); - Infos.Arr_Shl_Info := Get_Info (Subprg); - else - Set_Info (Subprg, Infos.Arr_Shl_Info); - end if; - - when Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra => - if Infos.Arr_Sha_Info = null then - Translate_Predefined_Array_Shift (Subprg); - Infos.Arr_Sha_Info := Get_Info (Subprg); - else - Set_Info (Subprg, Infos.Arr_Sha_Info); - end if; - - when Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - if Infos.Arr_Rot_Info = null then - Translate_Predefined_Array_Shift (Subprg); - Infos.Arr_Rot_Info := Get_Info (Subprg); - else - Set_Info (Subprg, Infos.Arr_Rot_Info); - end if; - - when Iir_Predefined_Access_Equality - | Iir_Predefined_Access_Inequality => - -- Intrinsic. - null; - when Iir_Predefined_Deallocate => - -- Intrinsic. - null; - - when Iir_Predefined_File_Open - | Iir_Predefined_File_Open_Status - | Iir_Predefined_File_Close - | Iir_Predefined_Flush - | Iir_Predefined_Endfile => - -- All of them have predefined definitions. - null; - - when Iir_Predefined_Write - | Iir_Predefined_Read_Length - | Iir_Predefined_Read => - declare - Param : Iir; - File_Type : Iir; - begin - Param := Get_Interface_Declaration_Chain (Subprg); - File_Type := Get_Type (Param); - if not Get_Text_File_Flag (File_Type) then - Translate_File_Subprogram (Subprg, File_Type); - end if; - end; - - when Iir_Predefined_Attribute_Image - | Iir_Predefined_Attribute_Value - | Iir_Predefined_Attribute_Pos - | Iir_Predefined_Attribute_Val - | Iir_Predefined_Attribute_Succ - | Iir_Predefined_Attribute_Pred - | Iir_Predefined_Attribute_Leftof - | Iir_Predefined_Attribute_Rightof - | Iir_Predefined_Attribute_Left - | Iir_Predefined_Attribute_Right - | Iir_Predefined_Attribute_Event - | Iir_Predefined_Attribute_Active - | Iir_Predefined_Attribute_Last_Event - | Iir_Predefined_Attribute_Last_Active - | Iir_Predefined_Attribute_Last_Value - | Iir_Predefined_Attribute_Driving - | Iir_Predefined_Attribute_Driving_Value => - raise Internal_Error; - - when Iir_Predefined_Array_Char_To_String - | Iir_Predefined_Bit_Vector_To_Ostring - | Iir_Predefined_Bit_Vector_To_Hstring - | Iir_Predefined_Std_Ulogic_Match_Equality - | Iir_Predefined_Std_Ulogic_Match_Inequality - | Iir_Predefined_Std_Ulogic_Match_Less - | Iir_Predefined_Std_Ulogic_Match_Less_Equal - | Iir_Predefined_Std_Ulogic_Match_Greater - | Iir_Predefined_Std_Ulogic_Match_Greater_Equal - | Iir_Predefined_Std_Ulogic_Array_Match_Equality - | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => - null; - - when Iir_Predefined_Now_Function => - null; - - -- when others => - -- Error_Kind ("translate_implicit_subprogram (" - -- & Iir_Predefined_Functions'Image (Kind) & ")", - -- Subprg); - end case; - end Translate_Implicit_Subprogram; - end Chap7; - - package body Chap8 is - procedure Translate_Return_Statement (Stmt : Iir_Return_Statement) - is - Subprg_Info : constant Ortho_Info_Acc := - Get_Info (Chap2.Current_Subprogram); - Expr : constant Iir := Get_Expression (Stmt); - Ret_Type : Iir; - Ret_Info : Type_Info_Acc; - - procedure Gen_Return is - begin - if Subprg_Info.Subprg_Exit /= O_Snode_Null then - New_Exit_Stmt (Subprg_Info.Subprg_Exit); - else - New_Return_Stmt; - end if; - end Gen_Return; - - procedure Gen_Return_Value (Val : O_Enode) is - begin - if Subprg_Info.Subprg_Exit /= O_Snode_Null then - New_Assign_Stmt (New_Obj (Subprg_Info.Subprg_Result), Val); - New_Exit_Stmt (Subprg_Info.Subprg_Exit); - else - New_Return_Stmt (Val); - end if; - end Gen_Return_Value; - begin - if Expr = Null_Iir then - -- Return in a procedure. - Gen_Return; - return; - end if; - - -- Return in a function. - Ret_Type := Get_Return_Type (Chap2.Current_Subprogram); - Ret_Info := Get_Info (Ret_Type); - case Ret_Info.Type_Mode is - when Type_Mode_Scalar => - -- * if the return type is scalar, simply returns. - declare - V : O_Dnode; - R : O_Enode; - begin - -- Always uses a temporary in case of the return expression - -- uses secondary stack. - -- FIXME: don't use the temp if not required. - R := Chap7.Translate_Expression (Expr, Ret_Type); - if Has_Stack2_Mark - or else Chap3.Need_Range_Check (Expr, Ret_Type) - then - V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); - New_Assign_Stmt (New_Obj (V), R); - Stack2_Release; - Chap3.Check_Range (V, Expr, Ret_Type, Expr); - Gen_Return_Value (New_Obj_Value (V)); - else - Gen_Return_Value (R); - end if; - end; - when Type_Mode_Acc => - -- * access: thin and no range. - declare - Res : O_Enode; - begin - Res := Chap7.Translate_Expression (Expr, Ret_Type); - Gen_Return_Value (Res); - end; - when Type_Mode_Fat_Array => - -- * if the return type is unconstrained: allocate an area from - -- the secondary stack, copy it to the area, and fill the fat - -- pointer. - -- Evaluate the result. - declare - Val : Mnode; - Area : Mnode; - begin - Area := Dp2M (Subprg_Info.Res_Interface, - Ret_Info, Mode_Value); - Val := Stabilize - (E2M (Chap7.Translate_Expression (Expr, Ret_Type), - Ret_Info, Mode_Value)); - Chap3.Translate_Object_Allocation - (Area, Alloc_Return, Ret_Type, - Chap3.Get_Array_Bounds (Val)); - Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type); - Gen_Return; - end; - when Type_Mode_Record - | Type_Mode_Array - | Type_Mode_Fat_Acc => - -- * if the return type is a constrained composite type, copy - -- it to the result area. - -- Create a temporary area so that if the expression use - -- stack2, it will be freed before the return (otherwise, - -- the stack area will be lost). - declare - V : Mnode; - begin - Open_Temp; - V := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); - Chap3.Translate_Object_Copy - (V, Chap7.Translate_Expression (Expr, Ret_Type), Ret_Type); - Close_Temp; - Gen_Return; - end; - when Type_Mode_File => - -- FIXME: Is it possible ? - Error_Kind ("translate_return_statement", Ret_Type); - when Type_Mode_Unknown - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Translate_Return_Statement; - - procedure Translate_If_Statement (Stmt : Iir) - is - Blk : O_If_Block; - Else_Clause : Iir; - begin - Start_If_Stmt - (Blk, Chap7.Translate_Expression (Get_Condition (Stmt))); - - Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); - - Else_Clause := Get_Else_Clause (Stmt); - if Else_Clause /= Null_Iir then - New_Else_Stmt (Blk); - if Get_Condition (Else_Clause) = Null_Iir then - Translate_Statements_Chain - (Get_Sequential_Statement_Chain (Else_Clause)); - else - Open_Temp; - Translate_If_Statement (Else_Clause); - Close_Temp; - end if; - end if; - Finish_If_Stmt (Blk); - end Translate_If_Statement; - - function Get_Range_Ptr_Field_Value (O_Range : O_Lnode; Field : O_Fnode) - return O_Enode - is - begin - return New_Value (New_Selected_Element - (New_Access_Element (New_Value (O_Range)), Field)); - end Get_Range_Ptr_Field_Value; - - -- Inc or dec ITERATOR according to DIR. - procedure Gen_Update_Iterator (Iterator : O_Dnode; - Dir : Iir_Direction; - Val : Unsigned_64; - Itype : Iir) - is - Op : ON_Op_Kind; - Base_Type : Iir; - V : O_Enode; - begin - case Dir is - when Iir_To => - Op := ON_Add_Ov; - when Iir_Downto => - Op := ON_Sub_Ov; - end case; - Base_Type := Get_Base_Type (Itype); - case Get_Kind (Base_Type) is - when Iir_Kind_Integer_Type_Definition => - V := New_Lit - (New_Signed_Literal - (Get_Ortho_Type (Base_Type, Mode_Value), Integer_64 (Val))); - when Iir_Kind_Enumeration_Type_Definition => - declare - List : Iir_List; - begin - List := Get_Enumeration_Literal_List (Base_Type); - -- FIXME: what about type E is ('T') ?? - if Natural (Val) > Get_Nbr_Elements (List) then - raise Internal_Error; - end if; - V := New_Lit - (Get_Ortho_Expr (Get_Nth_Element (List, Natural (Val)))); - end; - - when others => - Error_Kind ("gen_update_iterator", Base_Type); - end case; - New_Assign_Stmt (New_Obj (Iterator), - New_Dyadic_Op (Op, New_Obj_Value (Iterator), V)); - end Gen_Update_Iterator; - - type For_Loop_Data is record - Iterator : Iir_Iterator_Declaration; - Stmt : Iir_For_Loop_Statement; - -- If around the loop, to check if the loop must be executed. - If_Blk : O_If_Block; - Label_Next, Label_Exit : O_Snode; - -- Right bound of the iterator, used only if the iterator is a - -- range expression. - O_Right : O_Dnode; - -- Range variable of the iterator, used only if the iterator is not - -- a range expression. - O_Range : O_Dnode; - end record; - - procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration; - Stmt : Iir_For_Loop_Statement; - Data : out For_Loop_Data) - is - Iter_Type : Iir; - Iter_Base_Type : Iir; - Var_Iter : Var_Type; - Constraint : Iir; - Cond : O_Enode; - Dir : Iir_Direction; - Iter_Type_Info : Ortho_Info_Acc; - Op : ON_Op_Kind; - begin - -- Initialize DATA. - Data.Iterator := Iterator; - Data.Stmt := Stmt; - - Iter_Type := Get_Type (Iterator); - Iter_Base_Type := Get_Base_Type (Iter_Type); - Iter_Type_Info := Get_Info (Iter_Base_Type); - Var_Iter := Get_Info (Iterator).Iterator_Var; - - Open_Temp; - - Constraint := Get_Range_Constraint (Iter_Type); - if Get_Kind (Constraint) = Iir_Kind_Range_Expression then - New_Assign_Stmt - (Get_Var (Var_Iter), Chap7.Translate_Range_Expression_Left - (Constraint, Iter_Base_Type)); - Dir := Get_Direction (Constraint); - Data.O_Right := Create_Temp - (Iter_Type_Info.Ortho_Type (Mode_Value)); - New_Assign_Stmt - (New_Obj (Data.O_Right), Chap7.Translate_Range_Expression_Right - (Constraint, Iter_Base_Type)); - case Dir is - when Iir_To => - Op := ON_Le; - when Iir_Downto => - Op := ON_Ge; - end case; - -- Check for at least one iteration. - Cond := New_Compare_Op - (Op, New_Value (Get_Var (Var_Iter)), - New_Obj_Value (Data.O_Right), - Ghdl_Bool_Type); - else - Data.O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type); - New_Assign_Stmt (New_Obj (Data.O_Range), - New_Address (Chap7.Translate_Range - (Constraint, Iter_Base_Type), - Iter_Type_Info.T.Range_Ptr_Type)); - New_Assign_Stmt - (Get_Var (Var_Iter), Get_Range_Ptr_Field_Value - (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Left)); - -- Before starting the loop, check wether there will be at least - -- one iteration. - Cond := New_Compare_Op - (ON_Gt, - Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), - Iter_Type_Info.T.Range_Length), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type); - end if; - - Start_If_Stmt (Data.If_Blk, Cond); - - -- Start loop. - -- There are two blocks: one for the exit, one for the next. - Start_Loop_Stmt (Data.Label_Exit); - Start_Loop_Stmt (Data.Label_Next); - - if Stmt /= Null_Iir then - declare - Loop_Info : Loop_Info_Acc; - begin - Loop_Info := Add_Info (Stmt, Kind_Loop); - Loop_Info.Label_Exit := Data.Label_Exit; - Loop_Info.Label_Next := Data.Label_Next; - end; - end if; - end Start_For_Loop; - - procedure Finish_For_Loop (Data : in out For_Loop_Data) - is - Cond : O_Enode; - If_Blk1 : O_If_Block; - Iter_Type : Iir; - Iter_Base_Type : Iir; - Iter_Type_Info : Type_Info_Acc; - Var_Iter : Var_Type; - Constraint : Iir; - Deep_Rng : Iir; - Deep_Reverse : Boolean; - begin - New_Exit_Stmt (Data.Label_Next); - Finish_Loop_Stmt (Data.Label_Next); - - -- Check end of loop. - -- Equality is necessary and enough. - Iter_Type := Get_Type (Data.Iterator); - Iter_Base_Type := Get_Base_Type (Iter_Type); - Iter_Type_Info := Get_Info (Iter_Base_Type); - Var_Iter := Get_Info (Data.Iterator).Iterator_Var; - - Constraint := Get_Range_Constraint (Iter_Type); - - if Get_Kind (Constraint) = Iir_Kind_Range_Expression then - Cond := New_Obj_Value (Data.O_Right); - else - Cond := Get_Range_Ptr_Field_Value - (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Right); - end if; - Gen_Exit_When (Data.Label_Exit, - New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)), - Cond, Ghdl_Bool_Type)); - - -- Update the iterator. - Chap6.Get_Deep_Range_Expression (Iter_Type, Deep_Rng, Deep_Reverse); - if Deep_Rng /= Null_Iir then - if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); - else - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); - end if; - else - Start_If_Stmt - (If_Blk1, New_Compare_Op - (ON_Eq, - Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), - Iter_Type_Info.T.Range_Dir), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); - New_Else_Stmt (If_Blk1); - Gen_Update_Iterator - (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); - Finish_If_Stmt (If_Blk1); - end if; - - Finish_Loop_Stmt (Data.Label_Exit); - Finish_If_Stmt (Data.If_Blk); - Close_Temp; - - if Data.Stmt /= Null_Iir then - Free_Info (Data.Stmt); - end if; - end Finish_For_Loop; - - Current_Loop : Iir := Null_Iir; - - procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) - is - Iterator : constant Iir := Get_Parameter_Specification (Stmt); - Iter_Type : constant Iir := Get_Type (Iterator); - Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); - Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); - Data : For_Loop_Data; - It_Info : Ortho_Info_Acc; - Var_Iter : Var_Type; - Prev_Loop : Iir; - begin - Prev_Loop := Current_Loop; - Current_Loop := Stmt; - Start_Declare_Stmt; - - Chap3.Translate_Object_Subtype (Iterator, False); - - -- Create info for the iterator. - It_Info := Add_Info (Iterator, Kind_Iterator); - Var_Iter := Create_Var - (Create_Var_Identifier (Iterator), - Iter_Type_Info.Ortho_Type (Mode_Value), - O_Storage_Local); - It_Info.Iterator_Var := Var_Iter; - - Start_For_Loop (Iterator, Stmt, Data); - - Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); - - Finish_For_Loop (Data); - - Finish_Declare_Stmt; - - Free_Info (Iterator); - Current_Loop := Prev_Loop; - end Translate_For_Loop_Statement; - - procedure Translate_While_Loop_Statement - (Stmt : Iir_While_Loop_Statement) - is - Info : Loop_Info_Acc; - Cond : Iir; - Prev_Loop : Iir; - begin - Prev_Loop := Current_Loop; - Current_Loop := Stmt; - - Info := Add_Info (Stmt, Kind_Loop); - - Start_Loop_Stmt (Info.Label_Exit); - Info.Label_Next := O_Snode_Null; - - Open_Temp; - Cond := Get_Condition (Stmt); - if Cond /= Null_Iir then - Gen_Exit_When - (Info.Label_Exit, - New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond))); - end if; - Close_Temp; - - Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); - - Finish_Loop_Stmt (Info.Label_Exit); - Free_Info (Stmt); - Current_Loop := Prev_Loop; - end Translate_While_Loop_Statement; - - procedure Translate_Exit_Next_Statement (Stmt : Iir) - is - Cond : constant Iir := Get_Condition (Stmt); - If_Blk : O_If_Block; - Info : Loop_Info_Acc; - Loop_Label : Iir; - Loop_Stmt : Iir; - begin - if Cond /= Null_Iir then - Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); - end if; - - Loop_Label := Get_Loop_Label (Stmt); - if Loop_Label = Null_Iir then - Loop_Stmt := Current_Loop; - else - Loop_Stmt := Get_Named_Entity (Loop_Label); - end if; - - Info := Get_Info (Loop_Stmt); - case Get_Kind (Stmt) is - when Iir_Kind_Exit_Statement => - New_Exit_Stmt (Info.Label_Exit); - when Iir_Kind_Next_Statement => - if Info.Label_Next /= O_Snode_Null then - -- For-loop. - New_Exit_Stmt (Info.Label_Next); - else - -- While-loop. - New_Next_Stmt (Info.Label_Exit); - end if; - when others => - raise Internal_Error; - end case; - if Cond /= Null_Iir then - Finish_If_Stmt (If_Blk); - end if; - end Translate_Exit_Next_Statement; - - procedure Translate_Variable_Aggregate_Assignment - (Targ : Iir; Targ_Type : Iir; Val : Mnode); - - procedure Translate_Variable_Array_Aggr - (Targ : Iir_Aggregate; - Targ_Type : Iir; - Val : Mnode; - Index : in out Unsigned_64; - Dim : Natural) - is - El : Iir; - Final : Boolean; - El_Type : Iir; - begin - Final := Dim = Get_Nbr_Elements (Get_Index_Subtype_List (Targ_Type)); - if Final then - El_Type := Get_Element_Subtype (Targ_Type); - end if; - El := Get_Association_Choices_Chain (Targ); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Choice_By_None => - if Final then - Translate_Variable_Aggregate_Assignment - (Get_Associated_Expr (El), El_Type, - Chap3.Index_Base - (Val, Targ_Type, - New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, Index)))); - Index := Index + 1; - else - Translate_Variable_Array_Aggr - (Get_Associated_Expr (El), - Targ_Type, Val, Index, Dim + 1); - end if; - when others => - Error_Kind ("translate_variable_array_aggr", El); - end case; - El := Get_Chain (El); - end loop; - end Translate_Variable_Array_Aggr; - - procedure Translate_Variable_Rec_Aggr - (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode) - is - Aggr_El : Iir; - El_List : Iir_List; - El_Index : Natural; - Elem : Iir; - begin - El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); - El_Index := 0; - Aggr_El := Get_Association_Choices_Chain (Targ); - while Aggr_El /= Null_Iir loop - case Get_Kind (Aggr_El) is - when Iir_Kind_Choice_By_None => - Elem := Get_Nth_Element (El_List, El_Index); - El_Index := El_Index + 1; - when Iir_Kind_Choice_By_Name => - Elem := Get_Choice_Name (Aggr_El); - when others => - Error_Kind ("translate_variable_rec_aggr", Aggr_El); - end case; - Translate_Variable_Aggregate_Assignment - (Get_Associated_Expr (Aggr_El), Get_Type (Elem), - Chap6.Translate_Selected_Element (Val, Elem)); - Aggr_El := Get_Chain (Aggr_El); - end loop; - end Translate_Variable_Rec_Aggr; - - procedure Translate_Variable_Aggregate_Assignment - (Targ : Iir; Targ_Type : Iir; Val : Mnode) - is - Index : Unsigned_64; - begin - if Get_Kind (Targ) = Iir_Kind_Aggregate then - case Get_Kind (Targ_Type) is - when Iir_Kinds_Array_Type_Definition => - Index := 0; - Translate_Variable_Array_Aggr - (Targ, Targ_Type, Val, Index, 1); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - Translate_Variable_Rec_Aggr (Targ, Targ_Type, Val); - when others => - Error_Kind - ("translate_variable_aggregate_assignment", Targ_Type); - end case; - else - declare - Targ_Node : Mnode; - begin - Targ_Node := Chap6.Translate_Name (Targ); - Chap3.Translate_Object_Copy (Targ_Node, M2E (Val), Targ_Type); - end; - end if; - end Translate_Variable_Aggregate_Assignment; - - procedure Translate_Variable_Assignment_Statement - (Stmt : Iir_Variable_Assignment_Statement) - is - Target : constant Iir := Get_Target (Stmt); - Targ_Type : constant Iir := Get_Type (Target); - Expr : constant Iir := Get_Expression (Stmt); - Targ_Node : Mnode; - begin - if Get_Kind (Target) = Iir_Kind_Aggregate then - declare - E : O_Enode; - Temp : Mnode; - begin - Chap3.Translate_Anonymous_Type_Definition (Targ_Type, True); - - -- Use a temporary variable, to avoid overlap. - Temp := Create_Temp (Get_Info (Targ_Type)); - Chap4.Allocate_Complex_Object (Targ_Type, Alloc_Stack, Temp); - - E := Chap7.Translate_Expression (Expr, Targ_Type); - Chap3.Translate_Object_Copy (Temp, E, Targ_Type); - Translate_Variable_Aggregate_Assignment - (Target, Targ_Type, Temp); - return; - end; - else - Targ_Node := Chap6.Translate_Name (Target); - if Get_Kind (Expr) = Iir_Kind_Aggregate then - declare - E : O_Enode; - begin - E := Chap7.Translate_Expression (Expr, Targ_Type); - Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type); - end; - else - Chap7.Translate_Assign (Targ_Node, Expr, Targ_Type); - end if; - end if; - end Translate_Variable_Assignment_Statement; - - procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir) - is - Expr : Iir; - Msg : O_Enode; - Severity : O_Enode; - Assocs : O_Assoc_List; - Loc : O_Dnode; - begin - Loc := Chap4.Get_Location (Stmt); - Expr := Get_Report_Expression (Stmt); - if Expr = Null_Iir then - Msg := New_Lit (New_Null_Access (Std_String_Ptr_Node)); - else - Msg := Chap7.Translate_Expression (Expr, String_Type_Definition); - end if; - Expr := Get_Severity_Expression (Stmt); - if Expr = Null_Iir then - Severity := New_Lit (Get_Ortho_Expr (Level)); - else - Severity := Chap7.Translate_Expression (Expr); - end if; - -- Do call. - Start_Association (Assocs, Subprg); - New_Association (Assocs, Msg); - New_Association (Assocs, Severity); - New_Association (Assocs, New_Address (New_Obj (Loc), - Ghdl_Location_Ptr_Node)); - New_Procedure_Call (Assocs); - end Translate_Report; - - -- Return True if the current library unit is part of library IEEE. - function Is_Within_Ieee_Library return Boolean - is - Design_File : Iir; - Library : Iir; - begin - -- Guard. - if Current_Library_Unit = Null_Iir then - return False; - end if; - Design_File := - Get_Design_File (Get_Design_Unit (Current_Library_Unit)); - Library := Get_Library (Design_File); - return Get_Identifier (Library) = Std_Names.Name_Ieee; - end Is_Within_Ieee_Library; - - procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) - is - Expr : Iir; - If_Blk : O_If_Block; - Subprg : O_Dnode; - begin - -- Select the procedure to call in case of assertion (so that - -- assertions within the IEEE library could be ignored). - if Is_Within_Ieee_Library then - Subprg := Ghdl_Ieee_Assert_Failed; - else - Subprg := Ghdl_Assert_Failed; - end if; - - Expr := Get_Assertion_Condition (Stmt); - if Get_Expr_Staticness (Expr) = Locally then - if Eval_Pos (Expr) = 1 then - -- Assert TRUE is a noop. - -- FIXME: generate a noop ? - return; - end if; - Translate_Report (Stmt, Subprg, Severity_Level_Error); - else - -- An assertion is reported if the condition is false! - Start_If_Stmt (If_Blk, - New_Monadic_Op (ON_Not, - Chap7.Translate_Expression (Expr))); - -- Note: it is necessary to create a declare block, to avoid bad - -- order with the if block. - Open_Temp; - Translate_Report (Stmt, Subprg, Severity_Level_Error); - Close_Temp; - Finish_If_Stmt (If_Blk); - end if; - end Translate_Assertion_Statement; - - procedure Translate_Report_Statement (Stmt : Iir_Report_Statement) is - begin - Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note); - end Translate_Report_Statement; - - -- Helper to compare a string choice with the selector. - function Translate_Simple_String_Choice - (Expr : O_Dnode; - Val : O_Enode; - Val_Node : O_Dnode; - Tinfo : Type_Info_Acc; - Func : Iir) - return O_Enode - is - Assoc : O_Assoc_List; - Func_Info : Subprg_Info_Acc; - begin - New_Assign_Stmt - (New_Selected_Element (New_Obj (Val_Node), - Tinfo.T.Base_Field (Mode_Value)), - Val); - Func_Info := Get_Info (Func); - Start_Association (Assoc, Func_Info.Ortho_Func); - Subprgs.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); - New_Association (Assoc, New_Obj_Value (Expr)); - New_Association - (Assoc, New_Address (New_Obj (Val_Node), - Tinfo.Ortho_Ptr_Type (Mode_Value))); - return New_Function_Call (Assoc); - end Translate_Simple_String_Choice; - - -- Helper to evaluate the selector and preparing a choice variable. - procedure Translate_String_Case_Statement_Common - (Stmt : Iir_Case_Statement; - Expr_Type : out Iir; - Tinfo : out Type_Info_Acc; - Expr_Node : out O_Dnode; - C_Node : out O_Dnode) - is - Expr : Iir; - Base_Type : Iir; - begin - -- Translate into if/elsif statements. - -- FIXME: if the number of literals ** length of the array < 256, - -- use a case statement. - Expr := Get_Expression (Stmt); - Expr_Type := Get_Type (Expr); - Base_Type := Get_Base_Type (Expr_Type); - Tinfo := Get_Info (Base_Type); - - -- Translate selector. - Expr_Node := Create_Temp_Init - (Tinfo.Ortho_Ptr_Type (Mode_Value), - Chap7.Translate_Expression (Expr, Base_Type)); - - -- Copy the bounds for the choices. - C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); - New_Assign_Stmt - (New_Selected_Element (New_Obj (C_Node), - Tinfo.T.Bounds_Field (Mode_Value)), - New_Value_Selected_Acc_Value - (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); - end Translate_String_Case_Statement_Common; - - -- Translate a string case statement using a dichotomy. - procedure Translate_String_Case_Statement_Dichotomy - (Stmt : Iir_Case_Statement) - is - -- Selector. - Expr_Type : Iir; - Tinfo : Type_Info_Acc; - Expr_Node : O_Dnode; - C_Node : O_Dnode; - - Choices_Chain : Iir; - Choice : Iir; - Has_Others : Boolean; - Func : Iir; - - -- Number of non-others choices. - Nbr_Choices : Natural; - -- Number of associations. - Nbr_Assocs : Natural; - - Info : Ortho_Info_Acc; - First, Last : Ortho_Info_Acc; - Sel_Length : Iir_Int64; - - -- Dichotomy table (table of choices). - String_Type : O_Tnode; - Table_Base_Type : O_Tnode; - Table_Type : O_Tnode; - Table : O_Dnode; - List : O_Array_Aggr_List; - Table_Cst : O_Cnode; - - -- Association table. - -- Indexed by the choice, returns an index to the associated - -- statement list. - -- Could be replaced by jump table. - Assoc_Table_Base_Type : O_Tnode; - Assoc_Table_Type : O_Tnode; - Assoc_Table : O_Dnode; - begin - Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); - - -- Count number of choices and number of associations. - Nbr_Choices := 0; - Nbr_Assocs := 0; - Choice := Choices_Chain; - First := null; - Last := null; - Has_Others := False; - while Choice /= Null_Iir loop - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Others => - Has_Others := True; - exit; - when Iir_Kind_Choice_By_Expression => - null; - when others => - raise Internal_Error; - end case; - if not Get_Same_Alternative_Flag (Choice) then - Nbr_Assocs := Nbr_Assocs + 1; - end if; - Info := Add_Info (Choice, Kind_Str_Choice); - if First = null then - First := Info; - else - Last.Choice_Chain := Info; - end if; - Last := Info; - Info.Choice_Chain := null; - Info.Choice_Assoc := Nbr_Assocs - 1; - Info.Choice_Parent := Choice; - Info.Choice_Expr := Get_Choice_Expression (Choice); - - Nbr_Choices := Nbr_Choices + 1; - Choice := Get_Chain (Choice); - end loop; - - -- Sort choices. - declare - procedure Merge_Sort (Head : Ortho_Info_Acc; - Nbr : Natural; - Res : out Ortho_Info_Acc; - Next : out Ortho_Info_Acc) - is - L, R, L_End, R_End : Ortho_Info_Acc; - E, Last : Ortho_Info_Acc; - Half : constant Natural := Nbr / 2; - begin - -- Sorting less than 2 elements is easy! - if Nbr < 2 then - Res := Head; - if Nbr = 0 then - Next := Head; - else - Next := Head.Choice_Chain; - end if; - return; - end if; - - Merge_Sort (Head, Half, L, L_End); - Merge_Sort (L_End, Nbr - Half, R, R_End); - Next := R_End; - - -- Merge - Last := null; - loop - if L /= L_End - and then - (R = R_End - or else - Compare_String_Literals (L.Choice_Expr, R.Choice_Expr) - = Compare_Lt) - then - E := L; - L := L.Choice_Chain; - elsif R /= R_End then - E := R; - R := R.Choice_Chain; - else - exit; - end if; - if Last = null then - Res := E; - else - Last.Choice_Chain := E; - end if; - Last := E; - end loop; - Last.Choice_Chain := R_End; - end Merge_Sort; - Next : Ortho_Info_Acc; - begin - Merge_Sort (First, Nbr_Choices, First, Next); - if Next /= null then - raise Internal_Error; - end if; - end; - - Translate_String_Case_Statement_Common - (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node); - - -- Generate choices table. - Sel_Length := Eval_Discrete_Type_Length - (Get_String_Type_Bound_Type (Expr_Type)); - String_Type := New_Constrained_Array_Type - (Tinfo.T.Base_Type (Mode_Value), - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length))); - Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type); - New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type); - Table_Type := New_Constrained_Array_Type - (Table_Base_Type, - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); - New_Type_Decl (Create_Uniq_Identifier, Table_Type); - New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private, - Table_Type); - Start_Const_Value (Table); - Start_Array_Aggr (List, Table_Type); - Info := First; - while Info /= null loop - New_Array_Aggr_El (List, Chap7.Translate_Static_Expression - (Info.Choice_Expr, Expr_Type)); - Info := Info.Choice_Chain; - end loop; - Finish_Array_Aggr (List, Table_Cst); - Finish_Const_Value (Table, Table_Cst); - - -- Generate assoc table. - Assoc_Table_Base_Type := - New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type); - New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type); - Assoc_Table_Type := New_Constrained_Array_Type - (Assoc_Table_Base_Type, - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); - New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type); - New_Const_Decl (Assoc_Table, Create_Uniq_Identifier, - O_Storage_Private, Assoc_Table_Type); - Start_Const_Value (Assoc_Table); - Start_Array_Aggr (List, Assoc_Table_Type); - Info := First; - while Info /= null loop - New_Array_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Info.Choice_Assoc))); - Info := Info.Choice_Chain; - end loop; - Finish_Array_Aggr (List, Table_Cst); - Finish_Const_Value (Assoc_Table, Table_Cst); - - -- Generate dichotomy code. - declare - Var_Lo, Var_Hi, Var_Mid : O_Dnode; - Var_Cmp : O_Dnode; - Var_Idx : O_Dnode; - Label : O_Snode; - Others_Lit : O_Cnode; - If_Blk1, If_Blk2 : O_If_Block; - Case_Blk : O_Case_Block; - begin - Var_Idx := Create_Temp (Ghdl_Index_Type); - - Start_Declare_Stmt; - - New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_Cmp, Wki_Cmp, - O_Storage_Local, Ghdl_Compare_Type); - - New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0)); - New_Assign_Stmt - (New_Obj (Var_Hi), - New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Nbr_Choices)))); - - Func := Chap7.Find_Predefined_Function - (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater); - - if Has_Others then - Others_Lit := New_Unsigned_Literal - (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs)); - end if; - - Start_Loop_Stmt (Label); - New_Assign_Stmt - (New_Obj (Var_Mid), - New_Dyadic_Op (ON_Div_Ov, - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_Lo), - New_Obj_Value (Var_Hi)), - New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, 2)))); - New_Assign_Stmt - (New_Obj (Var_Cmp), - Translate_Simple_String_Choice - (Expr_Node, - New_Address (New_Indexed_Element (New_Obj (Table), - New_Obj_Value (Var_Mid)), - Tinfo.T.Base_Ptr_Type (Mode_Value)), - C_Node, Tinfo, Func)); - Start_If_Stmt - (If_Blk1, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Cmp), - New_Lit (Ghdl_Compare_Eq), - Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Obj (Var_Idx), - New_Value (New_Indexed_Element (New_Obj (Assoc_Table), - New_Obj_Value (Var_Mid)))); - New_Exit_Stmt (Label); - Finish_If_Stmt (If_Blk1); - - Start_If_Stmt - (If_Blk1, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_Cmp), - New_Lit (Ghdl_Compare_Lt), - Ghdl_Bool_Type)); - Start_If_Stmt - (If_Blk2, - New_Compare_Op (ON_Le, - New_Obj_Value (Var_Mid), - New_Obj_Value (Var_Lo), - Ghdl_Bool_Type)); - if not Has_Others then - Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice); - else - New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); - New_Exit_Stmt (Label); - end if; - New_Else_Stmt (If_Blk2); - New_Assign_Stmt (New_Obj (Var_Hi), - New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Var_Mid), - New_Lit (Ghdl_Index_1))); - Finish_If_Stmt (If_Blk2); - - New_Else_Stmt (If_Blk1); - - Start_If_Stmt - (If_Blk2, - New_Compare_Op (ON_Ge, - New_Obj_Value (Var_Mid), - New_Obj_Value (Var_Hi), - Ghdl_Bool_Type)); - if not Has_Others then - Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); - else - New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); - New_Exit_Stmt (Label); - end if; - New_Else_Stmt (If_Blk2); - New_Assign_Stmt (New_Obj (Var_Lo), - New_Dyadic_Op (ON_Add_Ov, - New_Obj_Value (Var_Mid), - New_Lit (Ghdl_Index_1))); - Finish_If_Stmt (If_Blk2); - - Finish_If_Stmt (If_Blk1); - - Finish_Loop_Stmt (Label); - - Finish_Declare_Stmt; - - Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx)); - - Choice := Choices_Chain; - while Choice /= Null_Iir loop - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Others => - Start_Choice (Case_Blk); - New_Expr_Choice (Case_Blk, Others_Lit); - Finish_Choice (Case_Blk); - Translate_Statements_Chain - (Get_Associated_Chain (Choice)); - when Iir_Kind_Choice_By_Expression => - if not Get_Same_Alternative_Flag (Choice) then - Start_Choice (Case_Blk); - New_Expr_Choice - (Case_Blk, - New_Unsigned_Literal - (Ghdl_Index_Type, - Unsigned_64 (Get_Info (Choice).Choice_Assoc))); - Finish_Choice (Case_Blk); - Translate_Statements_Chain - (Get_Associated_Chain (Choice)); - end if; - Free_Info (Choice); - when others => - raise Internal_Error; - end case; - Choice := Get_Chain (Choice); - end loop; - - Start_Choice (Case_Blk); - New_Default_Choice (Case_Blk); - Finish_Choice (Case_Blk); - Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); - - Finish_Case_Stmt (Case_Blk); - end; - end Translate_String_Case_Statement_Dichotomy; - - -- Case statement whose expression is an unidim array. - -- Translate into if/elsif statements (linear search). - procedure Translate_String_Case_Statement_Linear - (Stmt : Iir_Case_Statement) - is - Expr_Type : Iir; - -- Node containing the address of the selector. - Expr_Node : O_Dnode; - -- Node containing the current choice. - Val_Node : O_Dnode; - Tinfo : Type_Info_Acc; - - Cond_Var : O_Dnode; - - Func : Iir; - - procedure Translate_String_Choice (Choice : Iir) - is - Cond : O_Enode; - If_Blk : O_If_Block; - Stmt_Chain : Iir; - First : Boolean; - Ch : Iir; - Ch_Expr : Iir; - begin - if Choice = Null_Iir then - return; - end if; - - First := True; - Stmt_Chain := Get_Associated_Chain (Choice); - Ch := Choice; - loop - case Get_Kind (Ch) is - when Iir_Kind_Choice_By_Expression => - Ch_Expr := Get_Choice_Expression (Ch); - Cond := Translate_Simple_String_Choice - (Expr_Node, - Chap7.Translate_Expression (Ch_Expr, - Get_Type (Ch_Expr)), - Val_Node, Tinfo, Func); - when Iir_Kind_Choice_By_Others => - Translate_Statements_Chain (Stmt_Chain); - return; - when others => - Error_Kind ("translate_string_choice", Ch); - end case; - if not First then - New_Assign_Stmt - (New_Obj (Cond_Var), - New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); - end if; - Ch := Get_Chain (Ch); - exit when Ch = Null_Iir; - exit when not Get_Same_Alternative_Flag (Ch); - exit when Get_Associated_Chain (Ch) /= Null_Iir; - if First then - New_Assign_Stmt (New_Obj (Cond_Var), Cond); - First := False; - end if; - end loop; - if not First then - Cond := New_Obj_Value (Cond_Var); - end if; - Start_If_Stmt (If_Blk, Cond); - Translate_Statements_Chain (Stmt_Chain); - New_Else_Stmt (If_Blk); - Translate_String_Choice (Ch); - Finish_If_Stmt (If_Blk); - end Translate_String_Choice; - begin - Translate_String_Case_Statement_Common - (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node); - - Func := Chap7.Find_Predefined_Function - (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); - - Cond_Var := Create_Temp (Std_Boolean_Type_Node); - - Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt)); - end Translate_String_Case_Statement_Linear; - - procedure Translate_Case_Choice - (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block) - is - Expr : Iir; - begin - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Others => - New_Default_Choice (Blk); - when Iir_Kind_Choice_By_Expression => - Expr := Get_Choice_Expression (Choice); - New_Expr_Choice - (Blk, Chap7.Translate_Static_Expression (Expr, Choice_Type)); - when Iir_Kind_Choice_By_Range => - declare - H, L : Iir; - begin - Expr := Get_Choice_Range (Choice); - Get_Low_High_Limit (Expr, L, H); - New_Range_Choice - (Blk, - Chap7.Translate_Static_Expression (L, Choice_Type), - Chap7.Translate_Static_Expression (H, Choice_Type)); - end; - when others => - Error_Kind ("translate_case_choice", Choice); - end case; - end Translate_Case_Choice; - - procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) - is - Expr : Iir; - Expr_Type : Iir; - Case_Blk : O_Case_Block; - Choice : Iir; - Stmt_Chain : Iir; - begin - Expr := Get_Expression (Stmt); - Expr_Type := Get_Type (Expr); - if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then - declare - Nbr_Choices : Natural := 0; - Choice : Iir; - begin - Choice := Get_Case_Statement_Alternative_Chain (Stmt); - while Choice /= Null_Iir loop - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Others => - exit; - when Iir_Kind_Choice_By_Expression => - null; - when others => - raise Internal_Error; - end case; - Nbr_Choices := Nbr_Choices + 1; - Choice := Get_Chain (Choice); - end loop; - - if Nbr_Choices < 3 then - Translate_String_Case_Statement_Linear (Stmt); - else - Translate_String_Case_Statement_Dichotomy (Stmt); - end if; - end; - return; - end if; - Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); - Choice := Get_Case_Statement_Alternative_Chain (Stmt); - while Choice /= Null_Iir loop - Start_Choice (Case_Blk); - Stmt_Chain := Get_Associated_Chain (Choice); - loop - Translate_Case_Choice (Choice, Expr_Type, Case_Blk); - Choice := Get_Chain (Choice); - exit when Choice = Null_Iir; - exit when not Get_Same_Alternative_Flag (Choice); - pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); - end loop; - Finish_Choice (Case_Blk); - Translate_Statements_Chain (Stmt_Chain); - end loop; - Finish_Case_Stmt (Case_Blk); - end Translate_Case_Statement; - - procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) - is - F_Assoc : Iir; - Value_Assoc : Iir; - Value : O_Dnode; - Formal_Type : Iir; - Tinfo : Type_Info_Acc; - Assocs : O_Assoc_List; - Subprg_Info : Subprg_Info_Acc; - begin - F_Assoc := Param_Chain; - Value_Assoc := Get_Chain (Param_Chain); - Formal_Type := Get_Type (Get_Formal (Value_Assoc)); - Tinfo := Get_Info (Formal_Type); - case Tinfo.Type_Mode is - when Type_Mode_Scalar => - Open_Temp; - Start_Association (Assocs, Ghdl_Write_Scalar); - -- compute file parameter (get an index) - New_Association - (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); - -- compute the value. - Value := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); - New_Assign_Stmt - (New_Obj (Value), - Chap7.Translate_Expression (Get_Actual (Value_Assoc), - Formal_Type)); - New_Association - (Assocs, - New_Unchecked_Address (New_Obj (Value), Ghdl_Ptr_Type)); - -- length. - New_Association - (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), - Ghdl_Index_Type))); - -- call a predefined procedure - New_Procedure_Call (Assocs); - Close_Temp; - when Type_Mode_Array - | Type_Mode_Record - | Type_Mode_Fat_Array => - Subprg_Info := Get_Info (Imp); - Start_Association (Assocs, Subprg_Info.Ortho_Func); - Subprgs.Add_Subprg_Instance_Assoc - (Assocs, Subprg_Info.Subprg_Instance); - New_Association - (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); - New_Association - (Assocs, - Chap7.Translate_Expression (Get_Actual (Value_Assoc), - Formal_Type)); - New_Procedure_Call (Assocs); - when Type_Mode_Unknown - | Type_Mode_File - | Type_Mode_Acc - | Type_Mode_Fat_Acc - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Translate_Write_Procedure_Call; - - procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) - is - F_Assoc : Iir; - Value_Assoc : Iir; - Value : Mnode; - Formal_Type : Iir; - Tinfo : Type_Info_Acc; - Assocs : O_Assoc_List; - Subprg_Info : Subprg_Info_Acc; - begin - F_Assoc := Param_Chain; - Value_Assoc := Get_Chain (Param_Chain); - Formal_Type := Get_Type (Get_Formal (Value_Assoc)); - Tinfo := Get_Info (Formal_Type); - case Tinfo.Type_Mode is - when Type_Mode_Scalar => - Open_Temp; - Start_Association (Assocs, Ghdl_Read_Scalar); - -- compute file parameter (get an index) - New_Association - (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); - -- value - Value := Chap6.Translate_Name (Get_Actual (Value_Assoc)); - New_Association - (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type)); - -- length. - New_Association - (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), - Ghdl_Index_Type))); - -- call a predefined procedure - New_Procedure_Call (Assocs); - Close_Temp; - when Type_Mode_Array - | Type_Mode_Record => - Subprg_Info := Get_Info (Imp); - Start_Association (Assocs, Subprg_Info.Ortho_Func); - Subprgs.Add_Subprg_Instance_Assoc - (Assocs, Subprg_Info.Subprg_Instance); - New_Association - (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); - New_Association - (Assocs, - Chap7.Translate_Expression (Get_Actual (Value_Assoc))); - New_Procedure_Call (Assocs); - when Type_Mode_Fat_Array => - declare - Length_Assoc : Iir; - Length : Mnode; - begin - Length_Assoc := Get_Chain (Value_Assoc); - Subprg_Info := Get_Info (Imp); - Start_Association (Assocs, Subprg_Info.Ortho_Func); - Subprgs.Add_Subprg_Instance_Assoc - (Assocs, Subprg_Info.Subprg_Instance); - New_Association - (Assocs, - Chap7.Translate_Expression (Get_Actual (F_Assoc))); - New_Association - (Assocs, - Chap7.Translate_Expression (Get_Actual (Value_Assoc), - Formal_Type)); - Length := Chap6.Translate_Name (Get_Actual (Length_Assoc)); - New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs)); - end; - when Type_Mode_Unknown - | Type_Mode_File - | Type_Mode_Acc - | Type_Mode_Fat_Acc - | Type_Mode_Protected => - raise Internal_Error; - end case; - end Translate_Read_Procedure_Call; - - procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) - is - Imp : constant Iir := Get_Implementation (Call); - Kind : constant Iir_Predefined_Functions := - Get_Implicit_Definition (Imp); - Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call); - begin - case Kind is - when Iir_Predefined_Write => - -- Check wether text or not. - declare - File_Param : Iir; - Assocs : O_Assoc_List; - begin - File_Param := Param_Chain; - -- FIXME: do the test. - if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) - then - -- If text: - Start_Association (Assocs, Ghdl_Text_Write); - -- compute file parameter (get an index) - New_Association - (Assocs, - Chap7.Translate_Expression (Get_Actual (File_Param))); - -- compute string parameter (get a fat array pointer) - New_Association - (Assocs, Chap7.Translate_Expression - (Get_Actual (Get_Chain (Param_Chain)), - String_Type_Definition)); - -- call a predefined procedure - New_Procedure_Call (Assocs); - else - Translate_Write_Procedure_Call (Imp, Param_Chain); - end if; - end; - - when Iir_Predefined_Read_Length => - -- FIXME: works only for text read length. - declare - File_Param : Iir; - N_Param : Iir; - Assocs : O_Assoc_List; - Str : O_Enode; - Res : Mnode; - begin - File_Param := Param_Chain; - if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) - then - N_Param := Get_Chain (File_Param); - Str := Chap7.Translate_Expression - (Get_Actual (N_Param), String_Type_Definition); - N_Param := Get_Chain (N_Param); - Res := Chap6.Translate_Name (Get_Actual (N_Param)); - Start_Association (Assocs, Ghdl_Text_Read_Length); - -- compute file parameter (get an index) - New_Association - (Assocs, - Chap7.Translate_Expression (Get_Actual (File_Param))); - -- compute string parameter (get a fat array pointer) - New_Association (Assocs, Str); - -- call a predefined procedure - New_Assign_Stmt - (M2Lv (Res), New_Function_Call (Assocs)); - else - Translate_Read_Procedure_Call (Imp, Param_Chain); - end if; - end; - - when Iir_Predefined_Read => - Translate_Read_Procedure_Call (Imp, Param_Chain); - - when Iir_Predefined_Deallocate => - Chap3.Translate_Object_Deallocation (Get_Actual (Param_Chain)); - - when Iir_Predefined_File_Open => - declare - N_Param : Iir; - File_Param : Iir; - Name_Param : Iir; - Kind_Param : Iir; - Constr : O_Assoc_List; - begin - File_Param := Get_Actual (Param_Chain); - N_Param := Get_Chain (Param_Chain); - Name_Param := Get_Actual (N_Param); - N_Param := Get_Chain (N_Param); - Kind_Param := Get_Actual (N_Param); - if Get_Text_File_Flag (Get_Type (File_Param)) then - Start_Association (Constr, Ghdl_Text_File_Open); - else - Start_Association (Constr, Ghdl_File_Open); - end if; - New_Association - (Constr, Chap7.Translate_Expression (File_Param)); - New_Association - (Constr, New_Convert_Ov - (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); - New_Association - (Constr, - Chap7.Translate_Expression (Name_Param, - String_Type_Definition)); - New_Procedure_Call (Constr); - end; - - when Iir_Predefined_File_Open_Status => - declare - Std_File_Open_Status_Otype : constant O_Tnode := - Get_Ortho_Type (File_Open_Status_Type_Definition, - Mode_Value); - N_Param : Iir; - Status_Param : constant Iir := Get_Actual (Param_Chain); - File_Param : Iir; - Name_Param : Iir; - Kind_Param : Iir; - Constr : O_Assoc_List; - Status : Mnode; - begin - Status := Chap6.Translate_Name (Status_Param); - N_Param := Get_Chain (Param_Chain); - File_Param := Get_Actual (N_Param); - N_Param := Get_Chain (N_Param); - Name_Param := Get_Actual (N_Param); - N_Param := Get_Chain (N_Param); - Kind_Param := Get_Actual (N_Param); - if Get_Text_File_Flag (Get_Type (File_Param)) then - Start_Association (Constr, Ghdl_Text_File_Open_Status); - else - Start_Association (Constr, Ghdl_File_Open_Status); - end if; - New_Association - (Constr, Chap7.Translate_Expression (File_Param)); - New_Association - (Constr, New_Convert_Ov - (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); - New_Association - (Constr, - Chap7.Translate_Expression (Name_Param, - String_Type_Definition)); - New_Assign_Stmt - (M2Lv (Status), - New_Convert_Ov (New_Function_Call (Constr), - Std_File_Open_Status_Otype)); - end; - - when Iir_Predefined_File_Close => - declare - File_Param : constant Iir := Get_Actual (Param_Chain); - Constr : O_Assoc_List; - begin - if Get_Text_File_Flag (Get_Type (File_Param)) then - Start_Association (Constr, Ghdl_Text_File_Close); - else - Start_Association (Constr, Ghdl_File_Close); - end if; - New_Association - (Constr, Chap7.Translate_Expression (File_Param)); - New_Procedure_Call (Constr); - end; - - when Iir_Predefined_Flush => - declare - File_Param : constant Iir := Get_Actual (Param_Chain); - Constr : O_Assoc_List; - begin - Start_Association (Constr, Ghdl_File_Flush); - New_Association - (Constr, Chap7.Translate_Expression (File_Param)); - New_Procedure_Call (Constr); - end; - - when others => - Ada.Text_IO.Put_Line - ("translate_implicit_procedure_call: cannot handle " - & Iir_Predefined_Functions'Image (Kind)); - raise Internal_Error; - end case; - end Translate_Implicit_Procedure_Call; - - function Do_Conversion (Conv : Iir; Expr : Iir; Src : Mnode) - return O_Enode - is - Constr : O_Assoc_List; - Conv_Info : Subprg_Info_Acc; - Res : O_Dnode; - Imp : Iir; - begin - if Conv = Null_Iir then - return M2E (Src); --- case Get_Type_Info (Dest).Type_Mode is --- when Type_Mode_Thin => --- New_Assign_Stmt (M2Lv (Dest), M2E (Src)); --- when Type_Mode_Fat_Acc => --- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src)); --- when others => --- raise Internal_Error; --- end case; - else - case Get_Kind (Conv) is - when Iir_Kind_Function_Call => - -- Call conversion function. - Imp := Get_Implementation (Conv); - Conv_Info := Get_Info (Imp); - Start_Association (Constr, Conv_Info.Ortho_Func); - - if Conv_Info.Res_Interface /= O_Dnode_Null then - Res := Create_Temp (Conv_Info.Res_Record_Type); - -- Composite result. - New_Association - (Constr, - New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr)); - end if; - - Subprgs.Add_Subprg_Instance_Assoc - (Constr, Conv_Info.Subprg_Instance); - - New_Association (Constr, M2E (Src)); - - if Conv_Info.Res_Interface /= O_Dnode_Null then - -- Composite result. - New_Procedure_Call (Constr); - return New_Address (New_Obj (Res), - Conv_Info.Res_Record_Ptr); - else - return New_Function_Call (Constr); - end if; - when Iir_Kind_Type_Conversion => - return Chap7.Translate_Type_Conversion - (M2E (Src), Get_Type (Expr), - Get_Type (Conv), Null_Iir); - when others => - Error_Kind ("do_conversion", Conv); - end case; - end if; - end Do_Conversion; - - procedure Translate_Procedure_Call (Stmt : Iir_Procedure_Call) - is - type Mnode_Array is array (Natural range <>) of Mnode; - type O_Enode_Array is array (Natural range <>) of O_Enode; - Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); - Nbr_Assoc : constant Natural := - Iir_Chains.Get_Chain_Length (Assoc_Chain); - Params : Mnode_Array (0 .. Nbr_Assoc - 1); - E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); - Imp : constant Iir := Get_Implementation (Stmt); - Info : constant Subprg_Info_Acc := Get_Info (Imp); - Res : O_Dnode; - El : Iir; - Pos : Natural; - Constr : O_Assoc_List; - Act : Iir; - Actual_Type : Iir; - Formal : Iir; - Base_Formal : Iir; - Formal_Type : Iir; - Ftype_Info : Type_Info_Acc; - Formal_Info : Ortho_Info_Acc; - Val : O_Enode; - Param : Mnode; - Last_Individual : Natural; - Ptr : O_Lnode; - In_Conv : Iir; - In_Expr : Iir; - Out_Conv : Iir; - Out_Expr : Iir; - Formal_Object_Kind : Object_Kind_Type; - Bounds : Mnode; - Obj : Iir; - begin - -- Create an in-out result record for in-out arguments passed by - -- value. - if Info.Res_Record_Type /= O_Tnode_Null then - Res := Create_Temp (Info.Res_Record_Type); - else - Res := O_Dnode_Null; - end if; - - -- Evaluate in-out parameters and parameters passed by ref, since - -- they can add declarations. - -- Non-composite in-out parameters address are saved in order to - -- be able to assignate the result. - El := Assoc_Chain; - Pos := 0; - while El /= Null_Iir loop - Params (Pos) := Mnode_Null; - E_Params (Pos) := O_Enode_Null; - - Formal := Get_Formal (El); - if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then - Formal := Get_Named_Entity (Formal); - end if; - Base_Formal := Get_Association_Interface (El); - Formal_Type := Get_Type (Formal); - Formal_Info := Get_Info (Base_Formal); - if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration - then - Formal_Object_Kind := Mode_Signal; - else - Formal_Object_Kind := Mode_Value; - end if; - Ftype_Info := Get_Info (Formal_Type); - - case Get_Kind (El) is - when Iir_Kind_Association_Element_Open => - Act := Get_Default_Value (Formal); - In_Conv := Null_Iir; - Out_Conv := Null_Iir; - when Iir_Kind_Association_Element_By_Expression => - Act := Get_Actual (El); - In_Conv := Get_In_Conversion (El); - Out_Conv := Get_Out_Conversion (El); - when Iir_Kind_Association_Element_By_Individual => - Actual_Type := Get_Actual_Type (El); - if Formal_Info.Interface_Field /= O_Fnode_Null then - -- A non-composite type cannot be associated by element. - raise Internal_Error; - end if; - if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then - Chap3.Create_Array_Subtype (Actual_Type, True); - Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); - Param := Create_Temp (Ftype_Info, Formal_Object_Kind); - Chap3.Translate_Object_Allocation - (Param, Alloc_Stack, Formal_Type, Bounds); - else - Param := Create_Temp (Ftype_Info, Formal_Object_Kind); - Chap4.Allocate_Complex_Object - (Formal_Type, Alloc_Stack, Param); - end if; - Last_Individual := Pos; - Params (Pos) := Param; - goto Continue; - when others => - Error_Kind ("translate_procedure_call", El); - end case; - Actual_Type := Get_Type (Act); - - if Formal_Info.Interface_Field /= O_Fnode_Null then - -- Copy-out argument. - -- This is not a composite type. - Param := Chap6.Translate_Name (Act); - if Get_Object_Kind (Param) /= Mode_Value then - raise Internal_Error; - end if; - Params (Pos) := Stabilize (Param); - if In_Conv /= Null_Iir - or else Get_Mode (Formal) = Iir_Inout_Mode - then - -- Arguments may be assigned if there is an in conversion. - Ptr := New_Selected_Element - (New_Obj (Res), Formal_Info.Interface_Field); - Param := Lv2M (Ptr, Ftype_Info, Mode_Value); - if In_Conv /= Null_Iir then - In_Expr := In_Conv; - else - In_Expr := Act; - end if; - Chap7.Translate_Assign - (Param, - Do_Conversion (In_Conv, Act, Params (Pos)), - In_Expr, - Formal_Type, El); - end if; - elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then - -- Passed by reference. - case Get_Kind (Base_Formal) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - -- No conversion here. - E_Params (Pos) := Chap7.Translate_Expression - (Act, Formal_Type); - when Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Signal_Declaration => - Param := Chap6.Translate_Name (Act); - -- Atype may not have been set (eg: slice). - if Base_Formal /= Formal then - Stabilize (Param); - Params (Pos) := Param; - end if; - E_Params (Pos) := M2E (Param); - if Formal_Type /= Actual_Type then - -- Implicit array conversion or subtype check. - E_Params (Pos) := Chap7.Translate_Implicit_Conv - (E_Params (Pos), Actual_Type, Formal_Type, - Get_Object_Kind (Param), Stmt); - end if; - when others => - Error_Kind ("translate_procedure_call(2)", Formal); - end case; - end if; - if Base_Formal /= Formal then - -- Individual association. - if Ftype_Info.Type_Mode not in Type_Mode_By_Value then - -- Not by-value actual already translated. - Val := E_Params (Pos); - else - -- By value association. - Act := Get_Actual (El); - if Get_Kind (Base_Formal) - = Iir_Kind_Interface_Constant_Declaration - then - Val := Chap7.Translate_Expression (Act, Formal_Type); - else - Params (Pos) := Chap6.Translate_Name (Act); - -- Since signals are passed by reference, they are not - -- copied back, so do not stabilize them (furthermore, - -- it is not possible to stabilize them). - if Formal_Object_Kind = Mode_Value then - Params (Pos) := Stabilize (Params (Pos)); - end if; - Val := M2E (Params (Pos)); - end if; - end if; - -- Assign formal. - -- Change the formal variable so that it is the local variable - -- that will be passed to the subprogram. - declare - Prev_Node : O_Dnode; - begin - Prev_Node := Formal_Info.Interface_Node; - -- We need a pointer since the interface is by reference. - Formal_Info.Interface_Node := - M2Dp (Params (Last_Individual)); - Param := Chap6.Translate_Name (Formal); - Formal_Info.Interface_Node := Prev_Node; - end; - Chap7.Translate_Assign (Param, Val, Act, Formal_Type, El); - end if; - << Continue >> null; - El := Get_Chain (El); - Pos := Pos + 1; - end loop; - - -- Second stage: really perform the call. - Start_Association (Constr, Info.Ortho_Func); - if Res /= O_Dnode_Null then - New_Association (Constr, - New_Address (New_Obj (Res), Info.Res_Record_Ptr)); - end if; - - Obj := Get_Method_Object (Stmt); - if Obj /= Null_Iir then - New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); - else - Subprgs.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); - end if; - - -- Parameters. - El := Assoc_Chain; - Pos := 0; - while El /= Null_Iir loop - Formal := Get_Formal (El); - if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then - Formal := Get_Named_Entity (Formal); - end if; - Base_Formal := Get_Association_Interface (El); - Formal_Info := Get_Info (Base_Formal); - Formal_Type := Get_Type (Formal); - Ftype_Info := Get_Info (Formal_Type); - - if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then - Last_Individual := Pos; - New_Association (Constr, M2E (Params (Pos))); - elsif Base_Formal /= Formal then - -- Individual association. - null; - elsif Formal_Info.Interface_Field = O_Fnode_Null then - if Ftype_Info.Type_Mode in Type_Mode_By_Value then - -- Parameter passed by value. - if E_Params (Pos) /= O_Enode_Null then - Val := E_Params (Pos); - raise Internal_Error; - else - case Get_Kind (El) is - when Iir_Kind_Association_Element_Open => - Act := Get_Default_Value (Formal); - In_Conv := Null_Iir; - when Iir_Kind_Association_Element_By_Expression => - Act := Get_Actual (El); - In_Conv := Get_In_Conversion (El); - when others => - Error_Kind ("translate_procedure_call(2)", El); - end case; - case Get_Kind (Formal) is - when Iir_Kind_Interface_Signal_Declaration => - Param := Chap6.Translate_Name (Act); - -- This is a scalar. - Val := M2E (Param); - when others => - if In_Conv = Null_Iir then - Val := Chap7.Translate_Expression - (Act, Formal_Type); - else - Actual_Type := Get_Type (Act); - Val := Do_Conversion - (In_Conv, - Act, - E2M (Chap7.Translate_Expression (Act, - Actual_Type), - Get_Info (Actual_Type), - Mode_Value)); - end if; - end case; - end if; - New_Association (Constr, Val); - else - -- Parameter passed by ref, which was already computed. - New_Association (Constr, E_Params (Pos)); - end if; - end if; - El := Get_Chain (El); - Pos := Pos + 1; - end loop; - - New_Procedure_Call (Constr); - - -- Copy-out non-composite parameters. - El := Assoc_Chain; - Pos := 0; - while El /= Null_Iir loop - Formal := Get_Formal (El); - Base_Formal := Get_Association_Interface (El); - Formal_Type := Get_Type (Formal); - Ftype_Info := Get_Info (Formal_Type); - Formal_Info := Get_Info (Base_Formal); - if Get_Kind (Base_Formal) = Iir_Kind_Interface_Variable_Declaration - and then Get_Mode (Base_Formal) in Iir_Out_Modes - and then Params (Pos) /= Mnode_Null - then - if Formal_Info.Interface_Field /= O_Fnode_Null then - -- OUT parameters. - Out_Conv := Get_Out_Conversion (El); - if Out_Conv = Null_Iir then - Out_Expr := Formal; - else - Out_Expr := Out_Conv; - end if; - Ptr := New_Selected_Element - (New_Obj (Res), Formal_Info.Interface_Field); - Param := Lv2M (Ptr, Ftype_Info, Mode_Value); - Chap7.Translate_Assign (Params (Pos), - Do_Conversion (Out_Conv, Formal, - Param), - Out_Expr, - Get_Type (Get_Actual (El)), El); - elsif Base_Formal /= Formal then - -- By individual. - -- Copy back. - Act := Get_Actual (El); - declare - Prev_Node : O_Dnode; - begin - Prev_Node := Formal_Info.Interface_Node; - -- We need a pointer since the interface is by reference. - Formal_Info.Interface_Node := - M2Dp (Params (Last_Individual)); - Val := Chap7.Translate_Expression - (Formal, Get_Type (Act)); - Formal_Info.Interface_Node := Prev_Node; - end; - Chap7.Translate_Assign - (Params (Pos), Val, Formal, Get_Type (Act), El); - end if; - end if; - El := Get_Chain (El); - Pos := Pos + 1; - end loop; - end Translate_Procedure_Call; - - procedure Translate_Wait_Statement (Stmt : Iir) - is - Sensitivity : Iir_List; - Cond : Iir; - Timeout : Iir; - Constr : O_Assoc_List; - begin - Sensitivity := Get_Sensitivity_List (Stmt); - Cond := Get_Condition_Clause (Stmt); - Timeout := Get_Timeout_Clause (Stmt); - - if Sensitivity = Null_Iir_List and Cond /= Null_Iir then - Sensitivity := Create_Iir_List; - Canon.Canon_Extract_Sensitivity (Cond, Sensitivity); - Set_Sensitivity_List (Stmt, Sensitivity); - end if; - - -- Check for simple cases. - if Sensitivity = Null_Iir_List - and then Cond = Null_Iir - then - if Timeout = Null_Iir then - -- Process exit. - Start_Association (Constr, Ghdl_Process_Wait_Exit); - New_Procedure_Call (Constr); - else - -- Wait for a timeout. - Start_Association (Constr, Ghdl_Process_Wait_Timeout); - New_Association (Constr, Chap7.Translate_Expression - (Timeout, Time_Type_Definition)); - New_Procedure_Call (Constr); - end if; - return; - end if; - - -- Evaluate the timeout (if any) and register it, - if Timeout /= Null_Iir then - Start_Association (Constr, Ghdl_Process_Wait_Set_Timeout); - New_Association (Constr, Chap7.Translate_Expression - (Timeout, Time_Type_Definition)); - New_Procedure_Call (Constr); - end if; - - -- Evaluate the sensitivity list and register it. - if Sensitivity /= Null_Iir_List then - Register_Signal_List - (Sensitivity, Ghdl_Process_Wait_Add_Sensitivity); - end if; - - if Cond = Null_Iir then - declare - V : O_Dnode; - begin - -- declare - -- v : __ghdl_bool_type_node; - -- begin - -- v := suspend (); - -- end; - Open_Temp; - V := Create_Temp (Ghdl_Bool_Type); - Start_Association (Constr, Ghdl_Process_Wait_Suspend); - New_Assign_Stmt (New_Obj (V), New_Function_Call (Constr)); - Close_Temp; - end; - else - declare - Label : O_Snode; - begin - -- start loop - Start_Loop_Stmt (Label); - - -- if suspend() then -- return true if timeout. - -- exit; - -- end if; - Start_Association (Constr, Ghdl_Process_Wait_Suspend); - Gen_Exit_When (Label, New_Function_Call (Constr)); - - -- if condition then - -- exit; - -- end if; - Open_Temp; - Gen_Exit_When - (Label, - Chap7.Translate_Expression (Cond, Boolean_Type_Definition)); - Close_Temp; - - -- end loop; - Finish_Loop_Stmt (Label); - end; - end if; - - -- wait_close; - Start_Association (Constr, Ghdl_Process_Wait_Close); - New_Procedure_Call (Constr); - end Translate_Wait_Statement; - - -- Signal assignment. - Signal_Assign_Line : Natural; - procedure Gen_Simple_Signal_Assign_Non_Composite (Targ : Mnode; - Targ_Type : Iir; - Val : O_Enode) - is - Type_Info : Type_Info_Acc; - Subprg : O_Dnode; - Conv : O_Tnode; - Assoc : O_Assoc_List; - begin - Type_Info := Get_Info (Targ_Type); - case Type_Info.Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Signal_Simple_Assign_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Subprg := Ghdl_Signal_Simple_Assign_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Subprg := Ghdl_Signal_Simple_Assign_E32; - Conv := Ghdl_I32_Type; - when Type_Mode_I32 - | Type_Mode_P32 => - Subprg := Ghdl_Signal_Simple_Assign_I32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 - | Type_Mode_I64 => - Subprg := Ghdl_Signal_Simple_Assign_I64; - Conv := Ghdl_I64_Type; - when Type_Mode_F64 => - Subprg := Ghdl_Signal_Simple_Assign_F64; - Conv := Ghdl_Real_Type; - when Type_Mode_Array => - raise Internal_Error; - when others => - Error_Kind ("gen_signal_assign_non_composite", Targ_Type); - end case; - if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then - declare - If_Blk : O_If_Block; - Val2 : O_Dnode; - Targ2 : O_Dnode; - begin - Open_Temp; - Val2 := Create_Temp_Init - (Type_Info.Ortho_Type (Mode_Value), Val); - Targ2 := Create_Temp_Init - (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), - Ghdl_Signal_Ptr)); - Start_If_Stmt (If_Blk, Chap3.Not_In_Range (Val2, Targ_Type)); - Start_Association (Assoc, Ghdl_Signal_Simple_Assign_Error); - New_Association (Assoc, New_Obj_Value (Targ2)); - Assoc_Filename_Line (Assoc, Signal_Assign_Line); - New_Procedure_Call (Assoc); - New_Else_Stmt (If_Blk); - Start_Association (Assoc, Subprg); - New_Association (Assoc, New_Obj_Value (Targ2)); - New_Association - (Assoc, New_Convert_Ov (New_Obj_Value (Val2), Conv)); - New_Procedure_Call (Assoc); - Finish_If_Stmt (If_Blk); - Close_Temp; - end; - else - Start_Association (Assoc, Subprg); - New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), - Ghdl_Signal_Ptr)); - New_Association (Assoc, New_Convert_Ov (Val, Conv)); - New_Procedure_Call (Assoc); - end if; - end Gen_Simple_Signal_Assign_Non_Composite; - - procedure Gen_Simple_Signal_Assign is new Foreach_Non_Composite - (Data_Type => O_Enode, - Composite_Data_Type => Mnode, - Do_Non_Composite => Gen_Simple_Signal_Assign_Non_Composite, - Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite, - Update_Data_Array => Gen_Oenode_Update_Data_Array, - Finish_Data_Array => Gen_Oenode_Finish_Data_Composite, - Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite, - Update_Data_Record => Gen_Oenode_Update_Data_Record, - Finish_Data_Record => Gen_Oenode_Finish_Data_Composite); - - type Signal_Assign_Data is record - Expr : Mnode; - Reject : O_Dnode; - After : O_Dnode; - end record; - - procedure Gen_Start_Signal_Assign_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) - is - Type_Info : Type_Info_Acc; - Subprg : O_Dnode; - Conv : O_Tnode; - Assoc : O_Assoc_List; - begin - if Data.Expr = Mnode_Null then - -- Null transaction. - Start_Association (Assoc, Ghdl_Signal_Start_Assign_Null); - New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), - Ghdl_Signal_Ptr)); - New_Association (Assoc, New_Obj_Value (Data.Reject)); - New_Association (Assoc, New_Obj_Value (Data.After)); - New_Procedure_Call (Assoc); - return; - end if; - - Type_Info := Get_Info (Targ_Type); - case Type_Info.Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Signal_Start_Assign_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Subprg := Ghdl_Signal_Start_Assign_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Subprg := Ghdl_Signal_Start_Assign_E32; - Conv := Ghdl_I32_Type; - when Type_Mode_I32 - | Type_Mode_P32 => - Subprg := Ghdl_Signal_Start_Assign_I32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 - | Type_Mode_I64 => - Subprg := Ghdl_Signal_Start_Assign_I64; - Conv := Ghdl_I64_Type; - when Type_Mode_F64 => - Subprg := Ghdl_Signal_Start_Assign_F64; - Conv := Ghdl_Real_Type; - when Type_Mode_Array => - raise Internal_Error; - when others => - Error_Kind ("gen_signal_assign_non_composite", Targ_Type); - end case; - -- Check range. - if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then - declare - If_Blk : O_If_Block; - V : Mnode; - Starg : O_Dnode; - begin - Open_Temp; - V := Stabilize_Value (Data.Expr); - Starg := Create_Temp_Init - (Ghdl_Signal_Ptr, - New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); - Start_If_Stmt - (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); - Start_Association (Assoc, Ghdl_Signal_Start_Assign_Error); - New_Association (Assoc, New_Obj_Value (Starg)); - New_Association (Assoc, New_Obj_Value (Data.Reject)); - New_Association (Assoc, New_Obj_Value (Data.After)); - Assoc_Filename_Line (Assoc, Signal_Assign_Line); - New_Procedure_Call (Assoc); - New_Else_Stmt (If_Blk); - Start_Association (Assoc, Subprg); - New_Association (Assoc, New_Obj_Value (Starg)); - New_Association (Assoc, New_Obj_Value (Data.Reject)); - New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); - New_Association (Assoc, New_Obj_Value (Data.After)); - New_Procedure_Call (Assoc); - Finish_If_Stmt (If_Blk); - Close_Temp; - end; - else - Start_Association (Assoc, Subprg); - New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), - Ghdl_Signal_Ptr)); - New_Association (Assoc, New_Obj_Value (Data.Reject)); - New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); - New_Association (Assoc, New_Obj_Value (Data.After)); - New_Procedure_Call (Assoc); - end if; - end Gen_Start_Signal_Assign_Non_Composite; - - function Gen_Signal_Prepare_Data_Composite - (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) - return Signal_Assign_Data - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Val; - end Gen_Signal_Prepare_Data_Composite; - - function Gen_Signal_Prepare_Data_Record - (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) - return Signal_Assign_Data - is - pragma Unreferenced (Targ, Targ_Type); - begin - if Val.Expr = Mnode_Null then - return Val; - else - return Signal_Assign_Data' - (Expr => Stabilize (Val.Expr), - Reject => Val.Reject, - After => Val.After); - end if; - end Gen_Signal_Prepare_Data_Record; - - function Gen_Signal_Update_Data_Array - (Val : Signal_Assign_Data; - Targ_Type : Iir; - Index : O_Dnode) - return Signal_Assign_Data - is - Res : Signal_Assign_Data; - begin - if Val.Expr = Mnode_Null then - -- Handle null transaction. - return Val; - end if; - Res := Signal_Assign_Data' - (Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), - Targ_Type, New_Obj_Value (Index)), - Reject => Val.Reject, - After => Val.After); - return Res; - end Gen_Signal_Update_Data_Array; - - function Gen_Signal_Update_Data_Record - (Val : Signal_Assign_Data; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Signal_Assign_Data - is - pragma Unreferenced (Targ_Type); - Res : Signal_Assign_Data; - begin - if Val.Expr = Mnode_Null then - -- Handle null transaction. - return Val; - end if; - Res := Signal_Assign_Data' - (Expr => Chap6.Translate_Selected_Element (Val.Expr, El), - Reject => Val.Reject, - After => Val.After); - return Res; - end Gen_Signal_Update_Data_Record; - - procedure Gen_Signal_Finish_Data_Composite - (Data : in out Signal_Assign_Data) - is - pragma Unreferenced (Data); - begin - null; - end Gen_Signal_Finish_Data_Composite; - - procedure Gen_Start_Signal_Assign is new Foreach_Non_Composite - (Data_Type => Signal_Assign_Data, - Composite_Data_Type => Signal_Assign_Data, - Do_Non_Composite => Gen_Start_Signal_Assign_Non_Composite, - Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, - Update_Data_Array => Gen_Signal_Update_Data_Array, - Finish_Data_Array => Gen_Signal_Finish_Data_Composite, - Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, - Update_Data_Record => Gen_Signal_Update_Data_Record, - Finish_Data_Record => Gen_Signal_Finish_Data_Composite); - - procedure Gen_Next_Signal_Assign_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) - is - Type_Info : Type_Info_Acc; - Subprg : O_Dnode; - Conv : O_Tnode; - Assoc : O_Assoc_List; - begin - if Data.Expr = Mnode_Null then - -- Null transaction. - Start_Association (Assoc, Ghdl_Signal_Next_Assign_Null); - New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), - Ghdl_Signal_Ptr)); - New_Association (Assoc, New_Obj_Value (Data.After)); - New_Procedure_Call (Assoc); - return; - end if; - - Type_Info := Get_Info (Targ_Type); - case Type_Info.Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Signal_Next_Assign_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Subprg := Ghdl_Signal_Next_Assign_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Subprg := Ghdl_Signal_Next_Assign_E32; - Conv := Ghdl_I32_Type; - when Type_Mode_I32 - | Type_Mode_P32 => - Subprg := Ghdl_Signal_Next_Assign_I32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 - | Type_Mode_I64 => - Subprg := Ghdl_Signal_Next_Assign_I64; - Conv := Ghdl_I64_Type; - when Type_Mode_F64 => - Subprg := Ghdl_Signal_Next_Assign_F64; - Conv := Ghdl_Real_Type; - when Type_Mode_Array => - raise Internal_Error; - when others => - Error_Kind ("gen_signal_next_assign_non_composite", Targ_Type); - end case; - if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then - declare - If_Blk : O_If_Block; - V : Mnode; - Starg : O_Dnode; - begin - Open_Temp; - V := Stabilize_Value (Data.Expr); - Starg := Create_Temp_Init - (Ghdl_Signal_Ptr, - New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); - Start_If_Stmt - (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); - - Start_Association (Assoc, Ghdl_Signal_Next_Assign_Error); - New_Association (Assoc, New_Obj_Value (Starg)); - New_Association (Assoc, New_Obj_Value (Data.After)); - Assoc_Filename_Line (Assoc, Signal_Assign_Line); - New_Procedure_Call (Assoc); - - New_Else_Stmt (If_Blk); - - Start_Association (Assoc, Subprg); - New_Association (Assoc, New_Obj_Value (Starg)); - New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); - New_Association (Assoc, New_Obj_Value (Data.After)); - New_Procedure_Call (Assoc); - - Finish_If_Stmt (If_Blk); - Close_Temp; - end; - else - Start_Association (Assoc, Subprg); - New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), - Ghdl_Signal_Ptr)); - New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); - New_Association (Assoc, New_Obj_Value (Data.After)); - New_Procedure_Call (Assoc); - end if; - end Gen_Next_Signal_Assign_Non_Composite; - - procedure Gen_Next_Signal_Assign is new Foreach_Non_Composite - (Data_Type => Signal_Assign_Data, - Composite_Data_Type => Signal_Assign_Data, - Do_Non_Composite => Gen_Next_Signal_Assign_Non_Composite, - Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, - Update_Data_Array => Gen_Signal_Update_Data_Array, - Finish_Data_Array => Gen_Signal_Finish_Data_Composite, - Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, - Update_Data_Record => Gen_Signal_Update_Data_Record, - Finish_Data_Record => Gen_Signal_Finish_Data_Composite); - - procedure Translate_Signal_Target_Aggr - (Aggr : Mnode; Target : Iir; Target_Type : Iir); - - procedure Translate_Signal_Target_Array_Aggr - (Aggr : Mnode; - Target : Iir; - Target_Type : Iir; - Idx : O_Dnode; - Dim : Natural) - is - Index_List : constant Iir_List := - Get_Index_Subtype_List (Target_Type); - Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); - Sub_Aggr : Mnode; - El : Iir; - Expr : Iir; - begin - El := Get_Association_Choices_Chain (Target); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Choice_By_None => - Sub_Aggr := Chap3.Index_Base - (Aggr, Target_Type, New_Obj_Value (Idx)); - when others => - Error_Kind ("translate_signal_target_array_aggr", El); - end case; - Expr := Get_Associated_Expr (El); - if Dim = Nbr_Dim then - Translate_Signal_Target_Aggr - (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type)); - if Get_Kind (El) = Iir_Kind_Choice_By_None then - Inc_Var (Idx); - else - raise Internal_Error; - end if; - else - Translate_Signal_Target_Array_Aggr - (Sub_Aggr, Expr, Target_Type, Idx, Dim + 1); - end if; - El := Get_Chain (El); - end loop; - end Translate_Signal_Target_Array_Aggr; - - procedure Translate_Signal_Target_Record_Aggr - (Aggr : Mnode; Target : Iir; Target_Type : Iir) - is - Aggr_El : Iir; - El_List : Iir_List; - El_Index : Natural; - Element : Iir_Element_Declaration; - begin - El_List := Get_Elements_Declaration_List - (Get_Base_Type (Target_Type)); - El_Index := 0; - Aggr_El := Get_Association_Choices_Chain (Target); - while Aggr_El /= Null_Iir loop - case Get_Kind (Aggr_El) is - when Iir_Kind_Choice_By_None => - Element := Get_Nth_Element (El_List, El_Index); - El_Index := El_Index + 1; - when Iir_Kind_Choice_By_Name => - Element := Get_Choice_Name (Aggr_El); - El_Index := Natural'Last; - when others => - Error_Kind ("translate_signal_target_record_aggr", Aggr_El); - end case; - Translate_Signal_Target_Aggr - (Chap6.Translate_Selected_Element (Aggr, Element), - Get_Associated_Expr (Aggr_El), Get_Type (Element)); - Aggr_El := Get_Chain (Aggr_El); - end loop; - end Translate_Signal_Target_Record_Aggr; - - procedure Translate_Signal_Target_Aggr - (Aggr : Mnode; Target : Iir; Target_Type : Iir) - is - Src : Mnode; - begin - if Get_Kind (Target) = Iir_Kind_Aggregate then - declare - Idx : O_Dnode; - St_Aggr : Mnode; - begin - Open_Temp; - St_Aggr := Stabilize (Aggr); - case Get_Kind (Target_Type) is - when Iir_Kinds_Array_Type_Definition => - Idx := Create_Temp (Ghdl_Index_Type); - Init_Var (Idx); - Translate_Signal_Target_Array_Aggr - (St_Aggr, Target, Target_Type, Idx, 1); - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - Translate_Signal_Target_Record_Aggr - (St_Aggr, Target, Target_Type); - when others => - Error_Kind ("translate_signal_target_aggr", Target_Type); - end case; - Close_Temp; - end; - else - Src := Chap6.Translate_Name (Target); - Chap3.Translate_Object_Copy (Aggr, M2E (Src), Target_Type); - end if; - end Translate_Signal_Target_Aggr; - - type Signal_Direct_Assign_Data is record - -- The driver - Drv : Mnode; - - -- The value - Expr : Mnode; - - -- The node for the expression (used to locate errors). - Expr_Node : Iir; - end record; - - procedure Gen_Signal_Direct_Assign_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Signal_Direct_Assign_Data) - is - Targ_Sig : Mnode; - If_Blk : O_If_Block; - Constr : O_Assoc_List; - Cond : O_Dnode; - Drv : Mnode; - begin - Open_Temp; - Targ_Sig := Stabilize (Targ, True); - Cond := Create_Temp (Ghdl_Bool_Type); - Drv := Stabilize (Data.Drv, False); - - -- Set driver. - Chap7.Translate_Assign - (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node); - - -- Test if the signal is active. - Start_If_Stmt - (If_Blk, - New_Value (Chap14.Get_Signal_Field - (Targ_Sig, Ghdl_Signal_Has_Active_Field))); - -- Either because has_active is true. - New_Assign_Stmt (New_Obj (Cond), - New_Lit (Ghdl_Bool_True_Node)); - New_Else_Stmt (If_Blk); - -- Or because the value is different from the current driving value. - -- FIXME: ideally, we should compare the value with the current - -- value of the driver. This is an approximation that might break - -- with weird resolution functions. - New_Assign_Stmt - (New_Obj (Cond), - New_Compare_Op (ON_Neq, - Chap7.Translate_Signal_Driving_Value - (M2E (Targ_Sig), Targ_Type), - M2E (Drv), - Ghdl_Bool_Type)); - Finish_If_Stmt (If_Blk); - - -- Put signal into active list (if not already in the list). - -- FIXME: this is not thread-safe! - Start_If_Stmt (If_Blk, New_Obj_Value (Cond)); - Start_Association (Constr, Ghdl_Signal_Direct_Assign); - New_Association (Constr, - New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), - Ghdl_Signal_Ptr)); - New_Procedure_Call (Constr); - Finish_If_Stmt (If_Blk); - - Close_Temp; - end Gen_Signal_Direct_Assign_Non_Composite; - - function Gen_Signal_Direct_Prepare_Data_Composite - (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) - return Signal_Direct_Assign_Data - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Val; - end Gen_Signal_Direct_Prepare_Data_Composite; - - function Gen_Signal_Direct_Prepare_Data_Record - (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) - return Signal_Direct_Assign_Data - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Signal_Direct_Assign_Data' - (Drv => Stabilize (Val.Drv), - Expr => Stabilize (Val.Expr), - Expr_Node => Val.Expr_Node); - end Gen_Signal_Direct_Prepare_Data_Record; - - function Gen_Signal_Direct_Update_Data_Array - (Val : Signal_Direct_Assign_Data; - Targ_Type : Iir; - Index : O_Dnode) - return Signal_Direct_Assign_Data - is - begin - return Signal_Direct_Assign_Data' - (Drv => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Drv), - Targ_Type, New_Obj_Value (Index)), - Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), - Targ_Type, New_Obj_Value (Index)), - Expr_Node => Val.Expr_Node); - end Gen_Signal_Direct_Update_Data_Array; - - function Gen_Signal_Direct_Update_Data_Record - (Val : Signal_Direct_Assign_Data; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Signal_Direct_Assign_Data - is - pragma Unreferenced (Targ_Type); - begin - return Signal_Direct_Assign_Data' - (Drv => Chap6.Translate_Selected_Element (Val.Drv, El), - Expr => Chap6.Translate_Selected_Element (Val.Expr, El), - Expr_Node => Val.Expr_Node); - end Gen_Signal_Direct_Update_Data_Record; - - procedure Gen_Signal_Direct_Finish_Data_Composite - (Data : in out Signal_Direct_Assign_Data) - is - pragma Unreferenced (Data); - begin - null; - end Gen_Signal_Direct_Finish_Data_Composite; - - procedure Gen_Signal_Direct_Assign is new Foreach_Non_Composite - (Data_Type => Signal_Direct_Assign_Data, - Composite_Data_Type => Signal_Direct_Assign_Data, - Do_Non_Composite => Gen_Signal_Direct_Assign_Non_Composite, - Prepare_Data_Array => Gen_Signal_Direct_Prepare_Data_Composite, - Update_Data_Array => Gen_Signal_Direct_Update_Data_Array, - Finish_Data_Array => Gen_Signal_Direct_Finish_Data_Composite, - Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Record, - Update_Data_Record => Gen_Signal_Direct_Update_Data_Record, - Finish_Data_Record => Gen_Signal_Direct_Finish_Data_Composite); - - procedure Translate_Direct_Signal_Assignment (Stmt : Iir; We : Iir) - is - Target : constant Iir := Get_Target (Stmt); - Target_Type : constant Iir := Get_Type (Target); - Arg : Signal_Direct_Assign_Data; - Targ_Sig : Mnode; - begin - Chap6.Translate_Direct_Driver (Target, Targ_Sig, Arg.Drv); - - Arg.Expr := E2M (Chap7.Translate_Expression (We, Target_Type), - Get_Info (Target_Type), Mode_Value); - Arg.Expr_Node := We; - Gen_Signal_Direct_Assign (Targ_Sig, Target_Type, Arg); - end Translate_Direct_Signal_Assignment; - - procedure Translate_Signal_Assignment_Statement (Stmt : Iir) - is - Target : Iir; - Target_Type : Iir; - We : Iir_Waveform_Element; - Targ : Mnode; - Val : O_Enode; - Value : Iir; - Is_Simple : Boolean; - begin - Target := Get_Target (Stmt); - Target_Type := Get_Type (Target); - We := Get_Waveform_Chain (Stmt); - - if We /= Null_Iir - and then Get_Chain (We) = Null_Iir - and then Get_Time (We) = Null_Iir - and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay - and then Get_Reject_Time_Expression (Stmt) = Null_Iir - then - -- Simple signal assignment ? - Value := Get_We_Value (We); - Is_Simple := Get_Kind (Value) /= Iir_Kind_Null_Literal; - else - Is_Simple := False; - end if; - - if Get_Kind (Target) = Iir_Kind_Aggregate then - Chap3.Translate_Anonymous_Type_Definition (Target_Type, True); - Targ := Create_Temp (Get_Info (Target_Type), Mode_Signal); - Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ); - Translate_Signal_Target_Aggr (Targ, Target, Target_Type); - else - if Is_Simple - and then Flag_Direct_Drivers - and then Chap4.Has_Direct_Driver (Target) - then - Translate_Direct_Signal_Assignment (Stmt, Value); - return; - end if; - Targ := Chap6.Translate_Name (Target); - if Get_Object_Kind (Targ) /= Mode_Signal then - raise Internal_Error; - end if; - end if; - - if We = Null_Iir then - -- Implicit disconnect statment. - Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect); - return; - end if; - - -- Handle a simple and common case: only one waveform, inertial, - -- and no time (eg: sig <= expr). - Value := Get_We_Value (We); - Signal_Assign_Line := Get_Line_Number (Value); - if Get_Chain (We) = Null_Iir - and then Get_Time (We) = Null_Iir - and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay - and then Get_Reject_Time_Expression (Stmt) = Null_Iir - and then Get_Kind (Value) /= Iir_Kind_Null_Literal - then - Val := Chap7.Translate_Expression (Value, Target_Type); - Gen_Simple_Signal_Assign (Targ, Target_Type, Val); - return; - end if; - - -- General case. - declare - Var_Targ : Mnode; - Targ_Tinfo : Type_Info_Acc; - begin - Open_Temp; - Targ_Tinfo := Get_Info (Target_Type); - Var_Targ := Stabilize (Targ, True); - - -- Translate the first waveform element. - declare - Reject_Time : O_Dnode; - After_Time : O_Dnode; - Del : Iir; - Rej : Iir; - Val : Mnode; - Data : Signal_Assign_Data; - begin - Open_Temp; - Reject_Time := Create_Temp (Std_Time_Otype); - After_Time := Create_Temp (Std_Time_Otype); - Del := Get_Time (We); - if Del = Null_Iir then - New_Assign_Stmt - (New_Obj (After_Time), - New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); - else - New_Assign_Stmt - (New_Obj (After_Time), - Chap7.Translate_Expression (Del, Time_Type_Definition)); - end if; - case Get_Delay_Mechanism (Stmt) is - when Iir_Transport_Delay => - New_Assign_Stmt - (New_Obj (Reject_Time), - New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); - when Iir_Inertial_Delay => - Rej := Get_Reject_Time_Expression (Stmt); - if Rej = Null_Iir then - New_Assign_Stmt (New_Obj (Reject_Time), - New_Obj_Value (After_Time)); - else - New_Assign_Stmt - (New_Obj (Reject_Time), Chap7.Translate_Expression - (Rej, Time_Type_Definition)); - end if; - end case; - if Get_Kind (Value) = Iir_Kind_Null_Literal then - Val := Mnode_Null; - else - Val := E2M (Chap7.Translate_Expression (Value, Target_Type), - Targ_Tinfo, Mode_Value); - Val := Stabilize (Val); - end if; - Data := Signal_Assign_Data'(Expr => Val, - Reject => Reject_Time, - After => After_Time); - Gen_Start_Signal_Assign (Var_Targ, Target_Type, Data); - Close_Temp; - end; - - -- Translate other waveform elements. - We := Get_Chain (We); - while We /= Null_Iir loop - declare - After_Time : O_Dnode; - Val : Mnode; - Data : Signal_Assign_Data; - begin - Open_Temp; - After_Time := Create_Temp (Std_Time_Otype); - New_Assign_Stmt - (New_Obj (After_Time), - Chap7.Translate_Expression (Get_Time (We), - Time_Type_Definition)); - Value := Get_We_Value (We); - Signal_Assign_Line := Get_Line_Number (Value); - if Get_Kind (Value) = Iir_Kind_Null_Literal then - Val := Mnode_Null; - else - Val := - E2M (Chap7.Translate_Expression (Value, Target_Type), - Targ_Tinfo, Mode_Value); - end if; - Data := Signal_Assign_Data'(Expr => Val, - Reject => O_Dnode_Null, - After => After_Time); - Gen_Next_Signal_Assign (Var_Targ, Target_Type, Data); - Close_Temp; - end; - We := Get_Chain (We); - end loop; - - Close_Temp; - end; - end Translate_Signal_Assignment_Statement; - - procedure Translate_Statement (Stmt : Iir) - is - begin - New_Debug_Line_Stmt (Get_Line_Number (Stmt)); - Open_Temp; - case Get_Kind (Stmt) is - when Iir_Kind_Return_Statement => - Translate_Return_Statement (Stmt); - - when Iir_Kind_If_Statement => - Translate_If_Statement (Stmt); - when Iir_Kind_Assertion_Statement => - Translate_Assertion_Statement (Stmt); - when Iir_Kind_Report_Statement => - Translate_Report_Statement (Stmt); - when Iir_Kind_Case_Statement => - Translate_Case_Statement (Stmt); - - when Iir_Kind_For_Loop_Statement => - Translate_For_Loop_Statement (Stmt); - when Iir_Kind_While_Loop_Statement => - Translate_While_Loop_Statement (Stmt); - when Iir_Kind_Next_Statement - | Iir_Kind_Exit_Statement => - Translate_Exit_Next_Statement (Stmt); - - when Iir_Kind_Signal_Assignment_Statement => - Translate_Signal_Assignment_Statement (Stmt); - when Iir_Kind_Variable_Assignment_Statement => - Translate_Variable_Assignment_Statement (Stmt); - - when Iir_Kind_Null_Statement => - -- A null statement is translated to a NOP, so that the - -- statement generates code (and a breakpoint can be set on - -- it). - -- Emit_Nop; - null; - - when Iir_Kind_Procedure_Call_Statement => - declare - Call : constant Iir := Get_Procedure_Call (Stmt); - Imp : constant Iir := Get_Implementation (Call); - begin - Canon.Canon_Subprogram_Call (Call); - if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration - then - Translate_Implicit_Procedure_Call (Call); - else - Translate_Procedure_Call (Call); - end if; - end; - - when Iir_Kind_Wait_Statement => - Translate_Wait_Statement (Stmt); - - when others => - Error_Kind ("translate_statement", Stmt); - end case; - Close_Temp; - end Translate_Statement; - - procedure Translate_Statements_Chain (First : Iir) - is - Stmt : Iir; - begin - Stmt := First; - while Stmt /= Null_Iir loop - Translate_Statement (Stmt); - Stmt := Get_Chain (Stmt); - end loop; - end Translate_Statements_Chain; - - function Translate_Statements_Chain_Has_Return (First : Iir) - return Boolean - is - Stmt : Iir; - Has_Return : Boolean := False; - begin - Stmt := First; - while Stmt /= Null_Iir loop - Translate_Statement (Stmt); - if Get_Kind (Stmt) = Iir_Kind_Return_Statement then - Has_Return := True; - end if; - Stmt := Get_Chain (Stmt); - end loop; - return Has_Return; - end Translate_Statements_Chain_Has_Return; - end Chap8; - - package body Chap9 is - procedure Set_Direct_Drivers (Proc : Iir) - is - Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); - Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; - Info : Ortho_Info_Acc; - Var : Var_Type; - Sig : Iir; - begin - for I in Drivers.all'Range loop - Var := Drivers (I).Var; - if Var /= Null_Var then - Sig := Get_Object_Prefix (Drivers (I).Sig); - Info := Get_Info (Sig); - case Info.Kind is - when Kind_Object => - Info.Object_Driver := Var; - when Kind_Alias => - null; - when others => - raise Internal_Error; - end case; - end if; - end loop; - end Set_Direct_Drivers; - - procedure Reset_Direct_Drivers (Proc : Iir) - is - Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); - Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; - Info : Ortho_Info_Acc; - Var : Var_Type; - Sig : Iir; - begin - for I in Drivers.all'Range loop - Var := Drivers (I).Var; - if Var /= Null_Var then - Sig := Get_Object_Prefix (Drivers (I).Sig); - Info := Get_Info (Sig); - case Info.Kind is - when Kind_Object => - Info.Object_Driver := Null_Var; - when Kind_Alias => - null; - when others => - raise Internal_Error; - end case; - end if; - end loop; - end Reset_Direct_Drivers; - - procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc) - is - Info : constant Proc_Info_Acc := Get_Info (Proc); - Inter_List : O_Inter_List; - Instance : O_Dnode; - begin - Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), - O_Storage_Private); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Base.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Info.Process_Subprg); - - Start_Subprogram_Body (Info.Process_Subprg); - Push_Local_Factory; - -- Push scope for architecture declarations. - Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); - - Chap8.Translate_Statements_Chain - (Get_Sequential_Statement_Chain (Proc)); - - Clear_Scope (Base.Block_Scope); - Pop_Local_Factory; - Finish_Subprogram_Body; - end Translate_Process_Statement; - - procedure Translate_Implicit_Guard_Signal - (Guard : Iir; Base : Block_Info_Acc) - is - Info : Object_Info_Acc; - Inter_List : O_Inter_List; - Instance : O_Dnode; - Guard_Expr : Iir; - begin - Guard_Expr := Get_Guard_Expression (Guard); - -- Create the subprogram to compute the value of GUARD. - Info := Get_Info (Guard); - Start_Function_Decl (Inter_List, Create_Identifier ("_GUARD_PROC"), - O_Storage_Private, Std_Boolean_Type_Node); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Base.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Info.Object_Function); - - Start_Subprogram_Body (Info.Object_Function); - Push_Local_Factory; - Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); - Open_Temp; - New_Return_Stmt (Chap7.Translate_Expression (Guard_Expr)); - Close_Temp; - Clear_Scope (Base.Block_Scope); - Pop_Local_Factory; - Finish_Subprogram_Body; - end Translate_Implicit_Guard_Signal; - - procedure Translate_Component_Instantiation_Statement (Inst : Iir) - is - Comp : constant Iir := Get_Instantiated_Unit (Inst); - Info : Block_Info_Acc; - Comp_Info : Comp_Info_Acc; - - Mark2 : Id_Mark_Type; - Assoc, Conv, In_Type : Iir; - Has_Conv_Record : Boolean := False; - begin - Info := Add_Info (Inst, Kind_Block); - - if Is_Component_Instantiation (Inst) then - -- Via a component declaration. - Comp_Info := Get_Info (Get_Named_Entity (Comp)); - Info.Block_Link_Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (Inst), - Get_Scope_Type (Comp_Info.Comp_Scope)); - else - -- Direct instantiation. - Info.Block_Link_Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (Inst), - Rtis.Ghdl_Component_Link_Type); - end if; - - -- When conversions are used, the subtype of the actual (or of the - -- formal for out conversions) may not be yet translated. This - -- can happen if the name is a slice. - -- We need to translate it and create variables in the instance - -- because it will be referenced by the conversion subprogram. - Assoc := Get_Port_Map_Aspect_Chain (Inst); - while Assoc /= Null_Iir loop - if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression - then - Conv := Get_In_Conversion (Assoc); - In_Type := Get_Type (Get_Actual (Assoc)); - if Conv /= Null_Iir - and then Is_Anonymous_Type_Definition (In_Type) - then - -- Lazy creation of the record. - if not Has_Conv_Record then - Has_Conv_Record := True; - Push_Instance_Factory (Info.Block_Scope'Access); - end if; - - -- FIXME: handle with overload multiple case on the same - -- formal. - Push_Identifier_Prefix - (Mark2, - Get_Identifier (Get_Association_Interface (Assoc))); - Chap3.Translate_Type_Definition (In_Type, True); - Pop_Identifier_Prefix (Mark2); - end if; - end if; - Assoc := Get_Chain (Assoc); - end loop; - if Has_Conv_Record then - Pop_Instance_Factory (Info.Block_Scope'Access); - New_Type_Decl - (Create_Identifier (Get_Identifier (Inst), "__CONVS"), - Get_Scope_Type (Info.Block_Scope)); - Info.Block_Parent_Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (Get_Identifier (Inst), - "__CONVS"), - Get_Scope_Type (Info.Block_Scope)); - end if; - end Translate_Component_Instantiation_Statement; - - procedure Translate_Process_Declarations (Proc : Iir) - is - Mark : Id_Mark_Type; - Info : Ortho_Info_Acc; - - Drivers : Iir_List; - Nbr_Drivers : Natural; - Sig : Iir; - begin - Info := Add_Info (Proc, Kind_Process); - - -- Create process record. - Push_Identifier_Prefix (Mark, Get_Identifier (Proc)); - Push_Instance_Factory (Info.Process_Scope'Access); - Chap4.Translate_Declaration_Chain (Proc); - - if Flag_Direct_Drivers then - -- Create direct drivers. - Drivers := Trans_Analyzes.Extract_Drivers (Proc); - if Flag_Dump_Drivers then - Trans_Analyzes.Dump_Drivers (Proc, Drivers); - end if; - - Nbr_Drivers := Get_Nbr_Elements (Drivers); - Info.Process_Drivers := new Direct_Driver_Arr (1 .. Nbr_Drivers); - for I in 1 .. Nbr_Drivers loop - Sig := Get_Nth_Element (Drivers, I - 1); - Info.Process_Drivers (I) := (Sig => Sig, Var => Null_Var); - Sig := Get_Object_Prefix (Sig); - if Get_Kind (Sig) /= Iir_Kind_Object_Alias_Declaration - and then not Get_After_Drivers_Flag (Sig) - then - Info.Process_Drivers (I).Var := - Create_Var (Create_Var_Identifier (Sig, "_DDRV", I), - Chap4.Get_Object_Type - (Get_Info (Get_Type (Sig)), Mode_Value)); - - -- Do not create driver severals times. - Set_After_Drivers_Flag (Sig, True); - end if; - end loop; - Trans_Analyzes.Free_Drivers_List (Drivers); - end if; - Pop_Instance_Factory (Info.Process_Scope'Access); - New_Type_Decl (Create_Identifier ("INSTTYPE"), - Get_Scope_Type (Info.Process_Scope)); - Pop_Identifier_Prefix (Mark); - - -- Create a field in the parent record. - Add_Scope_Field (Create_Identifier_Without_Prefix (Proc), - Info.Process_Scope); - end Translate_Process_Declarations; - - procedure Translate_Psl_Directive_Declarations (Stmt : Iir) - is - use PSL.Nodes; - use PSL.NFAs; - - N : constant NFA := Get_PSL_NFA (Stmt); - - Mark : Id_Mark_Type; - Info : Ortho_Info_Acc; - begin - Info := Add_Info (Stmt, Kind_Psl_Directive); - - -- Create process record. - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Push_Instance_Factory (Info.Psl_Scope'Access); - - Labelize_States (N, Info.Psl_Vect_Len); - Info.Psl_Vect_Type := New_Constrained_Array_Type - (Std_Boolean_Array_Type, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Info.Psl_Vect_Len))); - New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type); - Info.Psl_Vect_Var := Create_Var - (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type); - - if Get_Kind (Stmt) = Iir_Kind_Psl_Cover_Statement then - Info.Psl_Bool_Var := Create_Var - (Create_Var_Identifier ("BOOL"), Ghdl_Bool_Type); - end if; - - Pop_Instance_Factory (Info.Psl_Scope'Access); - New_Type_Decl (Create_Identifier ("INSTTYPE"), - Get_Scope_Type (Info.Psl_Scope)); - Pop_Identifier_Prefix (Mark); - - -- Create a field in the parent record. - Add_Scope_Field - (Create_Identifier_Without_Prefix (Stmt), Info.Psl_Scope); - end Translate_Psl_Directive_Declarations; - - function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean) - return O_Enode - is - use PSL.Nodes; - begin - case Get_Kind (Expr) is - when N_HDL_Expr => - declare - E : Iir; - Rtype : Iir; - Res : O_Enode; - begin - E := Get_HDL_Node (Expr); - Rtype := Get_Base_Type (Get_Type (E)); - Res := Chap7.Translate_Expression (E); - if Rtype = Boolean_Type_Definition then - return Res; - elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then - return New_Value - (New_Indexed_Element - (New_Obj (Ghdl_Std_Ulogic_To_Boolean_Array), - New_Convert_Ov (Res, Ghdl_Index_Type))); - else - Error_Kind ("translate_psl_expr/hdl_expr", Expr); - end if; - end; - when N_True => - return New_Lit (Std_Boolean_True_Node); - when N_EOS => - if Eos then - return New_Lit (Std_Boolean_True_Node); - else - return New_Lit (Std_Boolean_False_Node); - end if; - when N_Not_Bool => - return New_Monadic_Op - (ON_Not, - Translate_Psl_Expr (Get_Boolean (Expr), Eos)); - when N_And_Bool => - return New_Dyadic_Op - (ON_And, - Translate_Psl_Expr (Get_Left (Expr), Eos), - Translate_Psl_Expr (Get_Right (Expr), Eos)); - when N_Or_Bool => - return New_Dyadic_Op - (ON_Or, - Translate_Psl_Expr (Get_Left (Expr), Eos), - Translate_Psl_Expr (Get_Right (Expr), Eos)); - when others => - Error_Kind ("translate_psl_expr", Expr); - end case; - end Translate_Psl_Expr; - - -- Return TRUE iff NFA has an edge with an EOS. - -- If so, we need to create a finalizer. - function Psl_Need_Finalizer (Nfa : PSL_NFA) return Boolean - is - use PSL.NFAs; - S : NFA_State; - E : NFA_Edge; - begin - S := Get_Final_State (Nfa); - E := Get_First_Dest_Edge (S); - while E /= No_Edge loop - if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then - return True; - end if; - E := Get_Next_Dest_Edge (E); - end loop; - return False; - end Psl_Need_Finalizer; - - procedure Create_Psl_Final_Proc - (Stmt : Iir; Base : Block_Info_Acc; Instance : out O_Dnode) - is - Inter_List : O_Inter_List; - Info : constant Psl_Info_Acc := Get_Info (Stmt); - begin - Start_Procedure_Decl (Inter_List, Create_Identifier ("FINALPROC"), - O_Storage_Private); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Base.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Final_Subprg); - end Create_Psl_Final_Proc; - - procedure Translate_Psl_Directive_Statement - (Stmt : Iir; Base : Block_Info_Acc) - is - use PSL.NFAs; - Inter_List : O_Inter_List; - Instance : O_Dnode; - Info : constant Psl_Info_Acc := Get_Info (Stmt); - Var_I : O_Dnode; - Var_Nvec : O_Dnode; - Label : O_Snode; - Clk_Blk : O_If_Block; - S_Blk : O_If_Block; - E_Blk : O_If_Block; - S : NFA_State; - S_Num : Int32; - E : NFA_Edge; - Sd : NFA_State; - Cond : O_Enode; - NFA : PSL_NFA; - D_Lit : O_Cnode; - begin - Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), - O_Storage_Private); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Base.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Subprg); - - Start_Subprogram_Body (Info.Psl_Proc_Subprg); - Push_Local_Factory; - -- Push scope for architecture declarations. - Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); - - -- New state vector. - New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type); - - -- For cover directive, return now if already covered. - case Get_Kind (Stmt) is - when Iir_Kind_Psl_Assert_Statement => - null; - when Iir_Kind_Psl_Cover_Statement => - Start_If_Stmt (S_Blk, New_Value (Get_Var (Info.Psl_Bool_Var))); - New_Return_Stmt; - Finish_If_Stmt (S_Blk); - when others => - Error_Kind ("Translate_Psl_Directive_Statement(1)", Stmt); - end case; - - -- Initialize the new state vector. - Start_Declare_Stmt; - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, - Unsigned_64 (Info.Psl_Vect_Len))), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Indexed_Element (New_Obj (Var_Nvec), - New_Obj_Value (Var_I)), - New_Lit (Std_Boolean_False_Node)); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Declare_Stmt; - - -- Global if statement for the clock. - Open_Temp; - Start_If_Stmt (Clk_Blk, - Translate_Psl_Expr (Get_PSL_Clock (Stmt), False)); - - -- For each state: if set, evaluate all outgoing edges. - NFA := Get_PSL_NFA (Stmt); - S := Get_First_State (NFA); - while S /= No_State loop - S_Num := Get_State_Label (S); - Open_Temp; - - Start_If_Stmt - (S_Blk, - New_Value - (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), - New_Lit (New_Index_Lit - (Unsigned_64 (S_Num)))))); - - E := Get_First_Src_Edge (S); - while E /= No_Edge loop - Sd := Get_Edge_Dest (E); - Open_Temp; - - D_Lit := New_Index_Lit (Unsigned_64 (Get_State_Label (Sd))); - Cond := New_Monadic_Op - (ON_Not, - New_Value (New_Indexed_Element (New_Obj (Var_Nvec), - New_Lit (D_Lit)))); - Cond := New_Dyadic_Op - (ON_And, Cond, Translate_Psl_Expr (Get_Edge_Expr (E), False)); - Start_If_Stmt (E_Blk, Cond); - New_Assign_Stmt - (New_Indexed_Element (New_Obj (Var_Nvec), New_Lit (D_Lit)), - New_Lit (Std_Boolean_True_Node)); - Finish_If_Stmt (E_Blk); - - Close_Temp; - E := Get_Next_Src_Edge (E); - end loop; - - Finish_If_Stmt (S_Blk); - Close_Temp; - S := Get_Next_State (S); - end loop; - - -- Check fail state. - S := Get_Final_State (NFA); - S_Num := Get_State_Label (S); - pragma Assert (Integer (S_Num) = Info.Psl_Vect_Len - 1); - Start_If_Stmt - (S_Blk, - New_Value - (New_Indexed_Element (New_Obj (Var_Nvec), - New_Lit (New_Index_Lit - (Unsigned_64 (S_Num)))))); - case Get_Kind (Stmt) is - when Iir_Kind_Psl_Assert_Statement => - Chap8.Translate_Report - (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); - when Iir_Kind_Psl_Cover_Statement => - Chap8.Translate_Report - (Stmt, Ghdl_Psl_Cover, Severity_Level_Note); - New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), - New_Lit (Ghdl_Bool_True_Node)); - when others => - Error_Kind ("Translate_Psl_Directive_Statement", Stmt); - end case; - Finish_If_Stmt (S_Blk); - - -- Assign state vector. - Start_Declare_Stmt; - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, - Unsigned_64 (Info.Psl_Vect_Len))), - Ghdl_Bool_Type)); - New_Assign_Stmt - (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), - New_Obj_Value (Var_I)), - New_Value (New_Indexed_Element (New_Obj (Var_Nvec), - New_Obj_Value (Var_I)))); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Declare_Stmt; - - Close_Temp; - Finish_If_Stmt (Clk_Blk); - - Clear_Scope (Base.Block_Scope); - Pop_Local_Factory; - Finish_Subprogram_Body; - - -- The finalizer. - case Get_Kind (Stmt) is - when Iir_Kind_Psl_Assert_Statement => - if Psl_Need_Finalizer (NFA) then - Create_Psl_Final_Proc (Stmt, Base, Instance); - - Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); - Push_Local_Factory; - -- Push scope for architecture declarations. - Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); - - S := Get_Final_State (NFA); - E := Get_First_Dest_Edge (S); - while E /= No_Edge loop - Sd := Get_Edge_Src (E); - - if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then - - S_Num := Get_State_Label (Sd); - Open_Temp; - - Cond := New_Value - (New_Indexed_Element - (Get_Var (Info.Psl_Vect_Var), - New_Lit (New_Index_Lit (Unsigned_64 (S_Num))))); - Cond := New_Dyadic_Op - (ON_And, Cond, - Translate_Psl_Expr (Get_Edge_Expr (E), True)); - Start_If_Stmt (E_Blk, Cond); - Chap8.Translate_Report - (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); - New_Return_Stmt; - Finish_If_Stmt (E_Blk); - - Close_Temp; - end if; - - E := Get_Next_Dest_Edge (E); - end loop; - - Clear_Scope (Base.Block_Scope); - Pop_Local_Factory; - Finish_Subprogram_Body; - else - Info.Psl_Proc_Final_Subprg := O_Dnode_Null; - end if; - - when Iir_Kind_Psl_Cover_Statement => - Create_Psl_Final_Proc (Stmt, Base, Instance); - - Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); - Push_Local_Factory; - -- Push scope for architecture declarations. - Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); - - Start_If_Stmt - (S_Blk, - New_Monadic_Op (ON_Not, - New_Value (Get_Var (Info.Psl_Bool_Var)))); - Chap8.Translate_Report - (Stmt, Ghdl_Psl_Cover_Failed, Severity_Level_Error); - Finish_If_Stmt (S_Blk); - - Clear_Scope (Base.Block_Scope); - Pop_Local_Factory; - Finish_Subprogram_Body; - - when others => - Error_Kind ("Translate_Psl_Directive_Statement(3)", Stmt); - end case; - end Translate_Psl_Directive_Statement; - - -- Create the instance for block BLOCK. - -- BLOCK can be either an entity, an architecture or a block statement. - procedure Translate_Block_Declarations (Block : Iir; Origin : Iir) - is - El : Iir; - begin - Chap4.Translate_Declaration_Chain (Block); - - El := Get_Concurrent_Statement_Chain (Block); - while El /= Null_Iir loop - case Get_Kind (El) is - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Translate_Process_Declarations (El); - when Iir_Kind_Psl_Default_Clock => - null; - when Iir_Kind_Psl_Declaration => - null; - when Iir_Kind_Psl_Assert_Statement - | Iir_Kind_Psl_Cover_Statement => - Translate_Psl_Directive_Declarations (El); - when Iir_Kind_Component_Instantiation_Statement => - Translate_Component_Instantiation_Statement (El); - when Iir_Kind_Block_Statement => - declare - Info : Block_Info_Acc; - Hdr : Iir_Block_Header; - Guard : Iir; - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - - Info := Add_Info (El, Kind_Block); - Chap1.Start_Block_Decl (El); - Push_Instance_Factory (Info.Block_Scope'Access); - - Guard := Get_Guard_Decl (El); - if Guard /= Null_Iir then - Chap4.Translate_Declaration (Guard); - end if; - - -- generics, ports. - Hdr := Get_Block_Header (El); - if Hdr /= Null_Iir then - Chap4.Translate_Generic_Chain (Hdr); - Chap4.Translate_Port_Chain (Hdr); - end if; - - Chap9.Translate_Block_Declarations (El, Origin); - - Pop_Instance_Factory (Info.Block_Scope'Access); - Pop_Identifier_Prefix (Mark); - - -- Create a field in the parent record. - Add_Scope_Field - (Create_Identifier_Without_Prefix (El), - Info.Block_Scope); - end; - when Iir_Kind_Generate_Statement => - declare - Scheme : constant Iir := Get_Generation_Scheme (El); - Info : Block_Info_Acc; - Mark : Id_Mark_Type; - Iter_Type : Iir; - It_Info : Ortho_Info_Acc; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - - if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - Iter_Type := Get_Type (Scheme); - Chap3.Translate_Object_Subtype (Scheme, True); - end if; - - Info := Add_Info (El, Kind_Block); - Chap1.Start_Block_Decl (El); - Push_Instance_Factory (Info.Block_Scope'Access); - - -- Add a parent field in the current instance. - Info.Block_Origin_Field := Add_Instance_Factory_Field - (Get_Identifier ("ORIGIN"), - Get_Info (Origin).Block_Decls_Ptr_Type); - - -- Iterator. - if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - Info.Block_Configured_Field := - Add_Instance_Factory_Field - (Get_Identifier ("CONFIGURED"), Ghdl_Bool_Type); - It_Info := Add_Info (Scheme, Kind_Iterator); - It_Info.Iterator_Var := Create_Var - (Create_Var_Identifier (Scheme), - Get_Info (Get_Base_Type (Iter_Type)).Ortho_Type - (Mode_Value)); - end if; - - Chap9.Translate_Block_Declarations (El, El); - - Pop_Instance_Factory (Info.Block_Scope'Access); - - if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - -- Create array type of block_decls_type - Info.Block_Decls_Array_Type := New_Array_Type - (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type); - New_Type_Decl (Create_Identifier ("INSTARRTYPE"), - Info.Block_Decls_Array_Type); - -- Create access to the array type. - Info.Block_Decls_Array_Ptr_Type := New_Access_Type - (Info.Block_Decls_Array_Type); - New_Type_Decl (Create_Identifier ("INSTARRPTR"), - Info.Block_Decls_Array_Ptr_Type); - -- Add a field in parent record - Info.Block_Parent_Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (El), - Info.Block_Decls_Array_Ptr_Type); - else - -- Create an access field in the parent record. - Info.Block_Parent_Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (El), - Info.Block_Decls_Ptr_Type); - end if; - - Pop_Identifier_Prefix (Mark); - end; - when others => - Error_Kind ("translate_block_declarations", El); - end case; - El := Get_Chain (El); - end loop; - end Translate_Block_Declarations; - - procedure Translate_Component_Instantiation_Subprogram - (Stmt : Iir; Base : Block_Info_Acc) - is - procedure Set_Component_Link (Ref_Scope : Var_Scope_Type; - Comp_Field : O_Fnode) - is - begin - New_Assign_Stmt - (New_Selected_Element - (New_Selected_Element (Get_Instance_Ref (Ref_Scope), - Comp_Field), - Rtis.Ghdl_Component_Link_Stmt), - New_Lit (Rtis.Get_Context_Rti (Stmt))); - end Set_Component_Link; - - Info : constant Block_Info_Acc := Get_Info (Stmt); - - Parent : constant Iir := Get_Parent (Stmt); - Parent_Info : constant Block_Info_Acc := Get_Info (Parent); - - Comp : Iir; - Comp_Info : Comp_Info_Acc; - Inter_List : O_Inter_List; - Instance : O_Dnode; - begin - -- Create the elaborator for the instantiation. - Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB"), - O_Storage_Private); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Base.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Info.Block_Elab_Subprg); - - Start_Subprogram_Body (Info.Block_Elab_Subprg); - Push_Local_Factory; - Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); - - New_Debug_Line_Stmt (Get_Line_Number (Stmt)); - - -- Add access to the instantiation-specific data. - -- This is used only for anonymous subtype variables. - if Has_Scope_Type (Info.Block_Scope) then - Set_Scope_Via_Field (Info.Block_Scope, - Info.Block_Parent_Field, - Parent_Info.Block_Scope'Access); - end if; - - Comp := Get_Instantiated_Unit (Stmt); - if Is_Entity_Instantiation (Stmt) then - -- This is a direct instantiation. - Set_Component_Link (Parent_Info.Block_Scope, - Info.Block_Link_Field); - Translate_Entity_Instantiation (Comp, Stmt, Stmt, Null_Iir); - else - Comp := Get_Named_Entity (Comp); - Comp_Info := Get_Info (Comp); - Set_Scope_Via_Field (Comp_Info.Comp_Scope, - Info.Block_Link_Field, - Parent_Info.Block_Scope'Access); - - -- Set the link from component declaration to component - -- instantiation statement. - Set_Component_Link (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); - - Chap5.Elab_Map_Aspect (Stmt, Comp); - - Clear_Scope (Comp_Info.Comp_Scope); - end if; - - if Has_Scope_Type (Info.Block_Scope) then - Clear_Scope (Info.Block_Scope); - end if; - - Clear_Scope (Base.Block_Scope); - Pop_Local_Factory; - Finish_Subprogram_Body; - end Translate_Component_Instantiation_Subprogram; - - -- Translate concurrent statements into subprograms. - procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir) - is - Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); - Stmt : Iir; - Mark : Id_Mark_Type; - begin - Chap4.Translate_Declaration_Chain_Subprograms (Block); - - Stmt := Get_Concurrent_Statement_Chain (Block); - while Stmt /= Null_Iir loop - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - case Get_Kind (Stmt) is - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - if Flag_Direct_Drivers then - Chap9.Set_Direct_Drivers (Stmt); - end if; - - Chap4.Translate_Declaration_Chain_Subprograms (Stmt); - Translate_Process_Statement (Stmt, Base_Info); - - if Flag_Direct_Drivers then - Chap9.Reset_Direct_Drivers (Stmt); - end if; - when Iir_Kind_Psl_Default_Clock => - null; - when Iir_Kind_Psl_Declaration => - null; - when Iir_Kind_Psl_Assert_Statement - | Iir_Kind_Psl_Cover_Statement => - Translate_Psl_Directive_Statement (Stmt, Base_Info); - when Iir_Kind_Component_Instantiation_Statement => - Chap4.Translate_Association_Subprograms - (Stmt, Block, Base_Block, - Get_Entity_From_Entity_Aspect - (Get_Instantiated_Unit (Stmt))); - Translate_Component_Instantiation_Subprogram - (Stmt, Base_Info); - when Iir_Kind_Block_Statement => - declare - Guard : constant Iir := Get_Guard_Decl (Stmt); - Hdr : constant Iir := Get_Block_Header (Stmt); - begin - if Guard /= Null_Iir then - Translate_Implicit_Guard_Signal (Guard, Base_Info); - end if; - if Hdr /= Null_Iir then - Chap4.Translate_Association_Subprograms - (Hdr, Block, Base_Block, Null_Iir); - end if; - Translate_Block_Subprograms (Stmt, Base_Block); - end; - when Iir_Kind_Generate_Statement => - declare - Info : constant Block_Info_Acc := Get_Info (Stmt); - Prev_Subprg_Instance : Subprgs.Subprg_Instance_Stack; - begin - Subprgs.Push_Subprg_Instance (Info.Block_Scope'Access, - Info.Block_Decls_Ptr_Type, - Wki_Instance, - Prev_Subprg_Instance); - Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, - Info.Block_Origin_Field, - Info.Block_Scope'Access); - Translate_Block_Subprograms (Stmt, Stmt); - Clear_Scope (Base_Info.Block_Scope); - Subprgs.Pop_Subprg_Instance - (Wki_Instance, Prev_Subprg_Instance); - end; - when others => - Error_Kind ("translate_block_subprograms", Stmt); - end case; - Pop_Identifier_Prefix (Mark); - Stmt := Get_Chain (Stmt); - end loop; - end Translate_Block_Subprograms; - - -- Remove anonymous and implicit type definitions in a list of names. - -- Such type definitions are created during slice translations, however - -- variables created are defined in the translation scope. - -- If the type is referenced again, the variables must be reachable. - -- This is not the case for elaborator subprogram (which may references - -- slices in the sensitivity or driver list) and the process subprg. - procedure Destroy_Types_In_Name (Name : Iir) - is - El : Iir; - Atype : Iir; - Info : Type_Info_Acc; - begin - El := Name; - loop - Atype := Null_Iir; - case Get_Kind (El) is - when Iir_Kind_Selected_Element - | Iir_Kind_Indexed_Name => - El := Get_Prefix (El); - when Iir_Kind_Slice_Name => - Atype := Get_Type (El); - El := Get_Prefix (El); - when Iir_Kind_Object_Alias_Declaration => - El := Get_Name (El); - when Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute => - El := Get_Prefix (El); - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration => - exit; - when Iir_Kinds_Denoting_Name => - El := Get_Named_Entity (El); - when others => - Error_Kind ("destroy_types_in_name", El); - end case; - if Atype /= Null_Iir - and then Is_Anonymous_Type_Definition (Atype) - then - Info := Get_Info (Atype); - if Info /= null then - Free_Type_Info (Info); - Clear_Info (Atype); - end if; - end if; - end loop; - end Destroy_Types_In_Name; - - procedure Destroy_Types_In_List (List : Iir_List) - is - El : Iir; - begin - if List = Null_Iir_List then - return; - end if; - for I in Natural loop - El := Get_Nth_Element (List, I); - exit when El = Null_Iir; - Destroy_Types_In_Name (El); - end loop; - end Destroy_Types_In_List; - - procedure Gen_Register_Direct_Driver_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Drv : Mnode) - is - pragma Unreferenced (Targ_Type); - Constr : O_Assoc_List; - begin - Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); - New_Association - (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); - New_Association - (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); - New_Procedure_Call (Constr); - end Gen_Register_Direct_Driver_Non_Composite; - - function Gen_Register_Direct_Driver_Prepare_Data_Composite - (Targ : Mnode; Targ_Type : Iir; Val : Mnode) - return Mnode - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Val; - end Gen_Register_Direct_Driver_Prepare_Data_Composite; - - function Gen_Register_Direct_Driver_Prepare_Data_Record - (Targ : Mnode; Targ_Type : Iir; Val : Mnode) - return Mnode - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Stabilize (Val); - end Gen_Register_Direct_Driver_Prepare_Data_Record; - - function Gen_Register_Direct_Driver_Update_Data_Array - (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) - return Mnode - is - begin - return Chap3.Index_Base (Chap3.Get_Array_Base (Val), - Targ_Type, New_Obj_Value (Index)); - end Gen_Register_Direct_Driver_Update_Data_Array; - - function Gen_Register_Direct_Driver_Update_Data_Record - (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) - return Mnode - is - pragma Unreferenced (Targ_Type); - begin - return Chap6.Translate_Selected_Element (Val, El); - end Gen_Register_Direct_Driver_Update_Data_Record; - - procedure Gen_Register_Direct_Driver_Finish_Data_Composite - (Data : in out Mnode) - is - pragma Unreferenced (Data); - begin - null; - end Gen_Register_Direct_Driver_Finish_Data_Composite; - - procedure Gen_Register_Direct_Driver is new Foreach_Non_Composite - (Data_Type => Mnode, - Composite_Data_Type => Mnode, - Do_Non_Composite => Gen_Register_Direct_Driver_Non_Composite, - Prepare_Data_Array => - Gen_Register_Direct_Driver_Prepare_Data_Composite, - Update_Data_Array => Gen_Register_Direct_Driver_Update_Data_Array, - Finish_Data_Array => Gen_Register_Direct_Driver_Finish_Data_Composite, - Prepare_Data_Record => Gen_Register_Direct_Driver_Prepare_Data_Record, - Update_Data_Record => Gen_Register_Direct_Driver_Update_Data_Record, - Finish_Data_Record => - Gen_Register_Direct_Driver_Finish_Data_Composite); - --- procedure Register_Scalar_Direct_Driver (Sig : Mnode; --- Sig_Type : Iir; --- Drv : Mnode) --- is --- pragma Unreferenced (Sig_Type); --- Constr : O_Assoc_List; --- begin --- Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); --- New_Association --- (Constr, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); --- New_Association --- (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); --- New_Procedure_Call (Constr); --- end Register_Scalar_Direct_Driver; - - -- PROC: the process to be elaborated - -- BASE_INFO: info for the global block - procedure Elab_Process (Proc : Iir; Base_Info : Block_Info_Acc) - is - Info : constant Proc_Info_Acc := Get_Info (Proc); - Is_Sensitized : constant Boolean := - Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement; - Subprg : O_Dnode; - Constr : O_Assoc_List; - List : Iir_List; - List_Orig : Iir_List; - Final : Boolean; - begin - New_Debug_Line_Stmt (Get_Line_Number (Proc)); - - -- Register process. - if Is_Sensitized then - if Get_Postponed_Flag (Proc) then - Subprg := Ghdl_Postponed_Sensitized_Process_Register; - else - Subprg := Ghdl_Sensitized_Process_Register; - end if; - else - if Get_Postponed_Flag (Proc) then - Subprg := Ghdl_Postponed_Process_Register; - else - Subprg := Ghdl_Process_Register; - end if; - end if; - - Start_Association (Constr, Subprg); - New_Association - (Constr, New_Unchecked_Address - (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); - New_Association - (Constr, - New_Lit (New_Subprogram_Address (Info.Process_Subprg, - Ghdl_Ptr_Type))); - Rtis.Associate_Rti_Context (Constr, Proc); - New_Procedure_Call (Constr); - - -- First elaborate declarations since a driver may depend on - -- an alias declaration. - -- Also, with vhdl 08 a sensitivity element may depend on an alias. - Open_Temp; - Chap4.Elab_Declaration_Chain (Proc, Final); - Close_Temp; - - -- Register drivers. - if Flag_Direct_Drivers then - Chap9.Set_Direct_Drivers (Proc); - - declare - Sig : Iir; - Base : Iir; - Sig_Node, Drv_Node : Mnode; - begin - for I in Info.Process_Drivers.all'Range loop - Sig := Info.Process_Drivers (I).Sig; - Open_Temp; - Base := Get_Object_Prefix (Sig); - if Info.Process_Drivers (I).Var /= Null_Var then - -- Elaborate direct driver. Done only once. - Chap4.Elab_Direct_Driver_Declaration_Storage (Base); - end if; - if Chap4.Has_Direct_Driver (Base) then - -- Signal has a direct driver. - Chap6.Translate_Direct_Driver (Sig, Sig_Node, Drv_Node); - Gen_Register_Direct_Driver - (Sig_Node, Get_Type (Sig), Drv_Node); - else - Register_Signal (Chap6.Translate_Name (Sig), - Get_Type (Sig), - Ghdl_Process_Add_Driver); - end if; - Close_Temp; - end loop; - end; - - Chap9.Reset_Direct_Drivers (Proc); - else - List := Trans_Analyzes.Extract_Drivers (Proc); - Destroy_Types_In_List (List); - Register_Signal_List (List, Ghdl_Process_Add_Driver); - if Flag_Dump_Drivers then - Trans_Analyzes.Dump_Drivers (Proc, List); - end if; - Trans_Analyzes.Free_Drivers_List (List); - end if; - - if Is_Sensitized then - List_Orig := Get_Sensitivity_List (Proc); - if List_Orig = Iir_List_All then - List := Canon.Canon_Extract_Process_Sensitivity (Proc); - else - List := List_Orig; - end if; - Destroy_Types_In_List (List); - Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); - if List_Orig = Iir_List_All then - Destroy_Iir_List (List); - end if; - end if; - end Elab_Process; - - -- PROC: the process to be elaborated - -- BLOCK: the block containing the process (its parent) - -- BASE_INFO: info for the global block - procedure Elab_Psl_Directive (Stmt : Iir; - Base_Info : Block_Info_Acc) - is - Info : constant Psl_Info_Acc := Get_Info (Stmt); - Constr : O_Assoc_List; - List : Iir_List; - Clk : PSL_Node; - Var_I : O_Dnode; - Label : O_Snode; - begin - New_Debug_Line_Stmt (Get_Line_Number (Stmt)); - - -- Register process. - Start_Association (Constr, Ghdl_Sensitized_Process_Register); - New_Association - (Constr, New_Unchecked_Address - (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); - New_Association - (Constr, - New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg, - Ghdl_Ptr_Type))); - Rtis.Associate_Rti_Context (Constr, Stmt); - New_Procedure_Call (Constr); - - -- Register clock sensitivity. - Clk := Get_PSL_Clock (Stmt); - List := Create_Iir_List; - Canon_PSL.Canon_Extract_Sensitivity (Clk, List); - Destroy_Types_In_List (List); - Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); - Destroy_Iir_List (List); - - -- Register finalizer (if any). - if Info.Psl_Proc_Final_Subprg /= O_Dnode_Null then - Start_Association (Constr, Ghdl_Finalize_Register); - New_Association - (Constr, New_Unchecked_Address - (Get_Instance_Ref (Base_Info.Block_Scope), - Ghdl_Ptr_Type)); - New_Association - (Constr, - New_Lit (New_Subprogram_Address (Info.Psl_Proc_Final_Subprg, - Ghdl_Ptr_Type))); - New_Procedure_Call (Constr); - end if; - - -- Initialize state vector. - Start_Declare_Stmt; - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), - New_Lit (Ghdl_Index_0)), - New_Lit (Std_Boolean_True_Node)); - New_Assign_Stmt (New_Obj (Var_I), New_Lit (Ghdl_Index_1)); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op (ON_Ge, - New_Obj_Value (Var_I), - New_Lit (New_Unsigned_Literal - (Ghdl_Index_Type, - Unsigned_64 (Info.Psl_Vect_Len))), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var), - New_Obj_Value (Var_I)), - New_Lit (Std_Boolean_False_Node)); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Declare_Stmt; - - if Info.Psl_Bool_Var /= Null_Var then - New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), - New_Lit (Ghdl_Bool_False_Node)); - end if; - end Elab_Psl_Directive; - - procedure Elab_Implicit_Guard_Signal - (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc) - is - Guard : Iir; - Type_Info : Type_Info_Acc; - Info : Object_Info_Acc; - Constr : O_Assoc_List; - begin - -- Create the guard signal. - Guard := Get_Guard_Decl (Block); - Info := Get_Info (Guard); - Type_Info := Get_Info (Get_Type (Guard)); - Start_Association (Constr, Ghdl_Signal_Create_Guard); - New_Association - (Constr, New_Unchecked_Address - (Get_Instance_Ref (Block_Info.Block_Scope), Ghdl_Ptr_Type)); - New_Association - (Constr, - New_Lit (New_Subprogram_Address (Info.Object_Function, - Ghdl_Ptr_Type))); --- New_Association (Constr, Chap6.Get_Instance_Name_Ref (Block)); - New_Assign_Stmt (Get_Var (Info.Object_Var), - New_Convert_Ov (New_Function_Call (Constr), - Type_Info.Ortho_Type (Mode_Signal))); - - -- Register sensitivity list of the guard signal. - Register_Signal_List (Get_Guard_Sensitivity_List (Guard), - Ghdl_Signal_Guard_Dependence); - end Elab_Implicit_Guard_Signal; - - procedure Translate_Entity_Instantiation - (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir) - is - Entity_Unit : Iir_Design_Unit; - Config : Iir; - Arch : Iir; - Entity : Iir_Entity_Declaration; - Entity_Info : Block_Info_Acc; - Arch_Info : Block_Info_Acc; - - Instance_Size : O_Dnode; - Arch_Elab : O_Dnode; - Arch_Config : O_Dnode; - Arch_Config_Type : O_Tnode; - - Var_Sub : O_Dnode; - begin - -- Extract entity, architecture and configuration from - -- binding aspect. - case Get_Kind (Aspect) is - when Iir_Kind_Entity_Aspect_Entity => - Entity := Get_Entity (Aspect); - Arch := Get_Architecture (Aspect); - if Flags.Flag_Elaborate and then Arch = Null_Iir then - -- This is valid only during elaboration. - Arch := Libraries.Get_Latest_Architecture (Entity); - end if; - Config := Null_Iir; - when Iir_Kind_Entity_Aspect_Configuration => - Config := Get_Configuration (Aspect); - Entity := Get_Entity (Config); - Arch := Get_Block_Specification - (Get_Block_Configuration (Config)); - when Iir_Kind_Entity_Aspect_Open => - return; - when others => - Error_Kind ("translate_entity_instantiation", Aspect); - end case; - Entity_Unit := Get_Design_Unit (Entity); - Entity_Info := Get_Info (Entity); - if Config_Override /= Null_Iir then - Config := Config_Override; - if Get_Kind (Arch) = Iir_Kind_Simple_Name then - Arch := Get_Block_Specification - (Get_Block_Configuration (Config)); - end if; - end if; - - -- 1) Create instance for the arch - if Arch /= Null_Iir then - Arch_Info := Get_Info (Arch); - if Config = Null_Iir - and then Get_Kind (Arch) = Iir_Kind_Architecture_Body - then - Config := Get_Default_Configuration_Declaration (Arch); - if Config /= Null_Iir then - Config := Get_Library_Unit (Config); - end if; - end if; - else - Arch_Info := null; - end if; - if Arch_Info = null or Config = Null_Iir then - declare - function Get_Arch_Name return String is - begin - if Arch /= Null_Iir then - return "ARCH__" & Image_Identifier (Arch); - else - return "LASTARCH"; - end if; - end Get_Arch_Name; - - Str : constant String := - Image_Identifier (Get_Library (Get_Design_File (Entity_Unit))) - & "__" & Image_Identifier (Entity) & "__" - & Get_Arch_Name & "__"; - Sub_Inter : O_Inter_List; - Arg : O_Dnode; - begin - if Arch_Info = null then - New_Const_Decl - (Instance_Size, Get_Identifier (Str & "INSTSIZE"), - O_Storage_External, Ghdl_Index_Type); - - Start_Procedure_Decl - (Sub_Inter, Get_Identifier (Str & "ELAB"), - O_Storage_External); - New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, - Entity_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Sub_Inter, Arch_Elab); - end if; - - if Config = Null_Iir then - Start_Procedure_Decl - (Sub_Inter, Get_Identifier (Str & "DEFAULT_CONFIG"), - O_Storage_External); - New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, - Entity_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Sub_Inter, Arch_Config); - - Arch_Config_Type := Entity_Info.Block_Decls_Ptr_Type; - end if; - end; - end if; - - if Arch_Info = null then - if Config /= Null_Iir then - -- Architecture is unknown, but we know how to configure - -- the block inside it. - raise Internal_Error; - end if; - else - Instance_Size := Arch_Info.Block_Instance_Size; - Arch_Elab := Arch_Info.Block_Elab_Subprg; - if Config /= Null_Iir then - Arch_Config := Get_Info (Config).Config_Subprg; - Arch_Config_Type := Arch_Info.Block_Decls_Ptr_Type; - end if; - end if; - - -- Create the instance variable and allocate storage. - New_Var_Decl (Var_Sub, Get_Identifier ("SUB_INSTANCE"), - O_Storage_Local, Entity_Info.Block_Decls_Ptr_Type); - - New_Assign_Stmt - (New_Obj (Var_Sub), - Gen_Alloc (Alloc_System, New_Obj_Value (Instance_Size), - Entity_Info.Block_Decls_Ptr_Type)); - - -- 1.5) link instance. - declare - procedure Set_Links (Ref_Scope : Var_Scope_Type; - Link_Field : O_Fnode) - is - begin - -- Set the ghdl_component_link_instance field. - New_Assign_Stmt - (New_Selected_Element - (New_Selected_Element (Get_Instance_Ref (Ref_Scope), - Link_Field), - Rtis.Ghdl_Component_Link_Instance), - New_Address (New_Selected_Acc_Value - (New_Obj (Var_Sub), - Entity_Info.Block_Link_Field), - Rtis.Ghdl_Entity_Link_Acc)); - -- Set the ghdl_entity_link_parent field. - New_Assign_Stmt - (New_Selected_Element - (New_Selected_Acc_Value (New_Obj (Var_Sub), - Entity_Info.Block_Link_Field), - Rtis.Ghdl_Entity_Link_Parent), - New_Address - (New_Selected_Element (Get_Instance_Ref (Ref_Scope), - Link_Field), - Rtis.Ghdl_Component_Link_Acc)); - end Set_Links; - begin - case Get_Kind (Parent) is - when Iir_Kind_Component_Declaration => - -- Instantiation via a component declaration. - declare - Comp_Info : constant Comp_Info_Acc := Get_Info (Parent); - begin - Set_Links (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); - end; - when Iir_Kind_Component_Instantiation_Statement => - -- Direct instantiation. - declare - Parent_Info : constant Block_Info_Acc := - Get_Info (Get_Parent (Parent)); - begin - Set_Links (Parent_Info.Block_Scope, - Get_Info (Parent).Block_Link_Field); - end; - when others => - Error_Kind ("translate_entity_instantiation(1)", Parent); - end case; - end; - - -- Elab entity packages. - declare - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); - New_Procedure_Call (Assoc); - end; - - -- Elab map aspects. - Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Var_Sub); - Chap5.Elab_Map_Aspect (Mapping, Entity); - Clear_Scope (Entity_Info.Block_Scope); - - -- 3) Elab instance. - declare - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Arch_Elab); - New_Association (Assoc, New_Obj_Value (Var_Sub)); - New_Procedure_Call (Assoc); - end; - - -- 5) Configure - declare - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Arch_Config); - New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Var_Sub), - Arch_Config_Type)); - New_Procedure_Call (Assoc); - end; - end Translate_Entity_Instantiation; - - procedure Elab_Conditionnal_Generate_Statement - (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) - is - Scheme : constant Iir := Get_Generation_Scheme (Stmt); - Info : constant Block_Info_Acc := Get_Info (Stmt); - Parent_Info : constant Block_Info_Acc := Get_Info (Parent); - Var : O_Dnode; - Blk : O_If_Block; - V : O_Lnode; - begin - Open_Temp; - - Var := Create_Temp (Info.Block_Decls_Ptr_Type); - Start_If_Stmt (Blk, Chap7.Translate_Expression (Scheme)); - New_Assign_Stmt - (New_Obj (Var), - Gen_Alloc (Alloc_System, - New_Lit (Get_Scope_Size (Info.Block_Scope)), - Info.Block_Decls_Ptr_Type)); - New_Else_Stmt (Blk); - New_Assign_Stmt - (New_Obj (Var), - New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type))); - Finish_If_Stmt (Blk); - - -- Add a link to child in parent. - V := Get_Instance_Ref (Parent_Info.Block_Scope); - V := New_Selected_Element (V, Info.Block_Parent_Field); - New_Assign_Stmt (V, New_Obj_Value (Var)); - - Start_If_Stmt - (Blk, - New_Compare_Op - (ON_Neq, - New_Obj_Value (Var), - New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), - Ghdl_Bool_Type)); - -- Add a link to parent in child. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), - Get_Instance_Access (Base_Block)); - -- Elaborate block - Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); - Elab_Block_Declarations (Stmt, Stmt); - Clear_Scope (Info.Block_Scope); - Finish_If_Stmt (Blk); - Close_Temp; - end Elab_Conditionnal_Generate_Statement; - - procedure Elab_Iterative_Generate_Statement - (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) - is - Scheme : constant Iir := Get_Generation_Scheme (Stmt); - Iter_Type : constant Iir := Get_Type (Scheme); - Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); - Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); - Info : constant Block_Info_Acc := Get_Info (Stmt); - Parent_Info : constant Block_Info_Acc := Get_Info (Parent); --- Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); - Var_Inst : O_Dnode; - Var_I : O_Dnode; - Label : O_Snode; - V : O_Lnode; - Var : O_Dnode; - Range_Ptr : O_Dnode; - begin - Open_Temp; - - -- Evaluate iterator range. - Chap3.Elab_Object_Subtype (Iter_Type); - - Range_Ptr := Create_Temp_Ptr - (Iter_Type_Info.T.Range_Ptr_Type, - Get_Var (Get_Info (Iter_Type).T.Range_Var)); - - -- Allocate instances. - Var_Inst := Create_Temp (Info.Block_Decls_Array_Ptr_Type); - New_Assign_Stmt - (New_Obj (Var_Inst), - Gen_Alloc - (Alloc_System, - New_Dyadic_Op (ON_Mul_Ov, - New_Value_Selected_Acc_Value - (New_Obj (Range_Ptr), - Iter_Type_Info.T.Range_Length), - New_Lit (Get_Scope_Size (Info.Block_Scope))), - Info.Block_Decls_Array_Ptr_Type)); - - -- Add a link to child in parent. - V := Get_Instance_Ref (Parent_Info.Block_Scope); - V := New_Selected_Element (V, Info.Block_Parent_Field); - New_Assign_Stmt (V, New_Obj_Value (Var_Inst)); - - -- Start loop. - Var_I := Create_Temp (Ghdl_Index_Type); - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op (ON_Eq, - New_Obj_Value (Var_I), - New_Value_Selected_Acc_Value - (New_Obj (Range_Ptr), - Iter_Type_Info.T.Range_Length), - Ghdl_Bool_Type)); - - Var := Create_Temp_Ptr - (Info.Block_Decls_Ptr_Type, - New_Indexed_Element (New_Acc_Value (New_Obj (Var_Inst)), - New_Obj_Value (Var_I))); - -- Add a link to parent in child. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), - Get_Instance_Access (Base_Block)); - -- Mark the block as not (yet) configured. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Var), - Info.Block_Configured_Field), - New_Lit (Ghdl_Bool_False_Node)); - - -- Elaborate block - Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); - -- Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, - -- Info.Block_Origin_Field, - -- Info.Block_Scope'Access); - - -- Set iterator value. - -- FIXME: this could be slighly optimized... - declare - Val : O_Dnode; - If_Blk : O_If_Block; - begin - Val := Create_Temp (Iter_Type_Info.Ortho_Type (Mode_Value)); - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Eq, - New_Value_Selected_Acc_Value - (New_Obj (Range_Ptr), - Iter_Type_Info.T.Range_Dir), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value - (New_Obj (Range_Ptr), - Iter_Type_Info.T.Range_Left)); - New_Else_Stmt (If_Blk); - New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value - (New_Obj (Range_Ptr), - Iter_Type_Info.T.Range_Right)); - Finish_If_Stmt (If_Blk); - - New_Assign_Stmt - (Get_Var (Get_Info (Scheme).Iterator_Var), - New_Dyadic_Op - (ON_Add_Ov, - New_Obj_Value (Val), - New_Convert_Ov (New_Obj_Value (Var_I), - Iter_Type_Info.Ortho_Type (Mode_Value)))); - end; - - -- Elaboration. - Elab_Block_Declarations (Stmt, Stmt); - --- Clear_Scope (Base_Info.Block_Scope); - Clear_Scope (Info.Block_Scope); - - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Close_Temp; - end Elab_Iterative_Generate_Statement; - - type Merge_Signals_Data is record - Sig : Iir; - Set_Init : Boolean; - Has_Val : Boolean; - Val : Mnode; - end record; - - procedure Merge_Signals_Rti_Non_Composite (Targ : Mnode; - Targ_Type : Iir; - Data : Merge_Signals_Data) - is - Type_Info : Type_Info_Acc; - Sig : Mnode; - - Init_Subprg : O_Dnode; - Conv : O_Tnode; - Assoc : O_Assoc_List; - Init_Val : O_Enode; - begin - Type_Info := Get_Info (Targ_Type); - - Open_Temp; - - if Data.Set_Init then - case Type_Info.Type_Mode is - when Type_Mode_B1 => - Init_Subprg := Ghdl_Signal_Init_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Init_Subprg := Ghdl_Signal_Init_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Init_Subprg := Ghdl_Signal_Init_E32; - Conv := Ghdl_I32_Type; - when Type_Mode_I32 - | Type_Mode_P32 => - Init_Subprg := Ghdl_Signal_Init_I32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 - | Type_Mode_I64 => - Init_Subprg := Ghdl_Signal_Init_I64; - Conv := Ghdl_I64_Type; - when Type_Mode_F64 => - Init_Subprg := Ghdl_Signal_Init_F64; - Conv := Ghdl_Real_Type; - when others => - Error_Kind ("merge_signals_rti_non_composite", Targ_Type); - end case; - - Sig := Stabilize (Targ, True); - - -- Init the signal. - Start_Association (Assoc, Init_Subprg); - New_Association - (Assoc, - New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); - if Data.Has_Val then - Init_Val := M2E (Data.Val); - else - Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); - end if; - New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); - New_Procedure_Call (Assoc); - else - Sig := Targ; - end if; - - Start_Association (Assoc, Ghdl_Signal_Merge_Rti); - - New_Association - (Assoc, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); - New_Association - (Assoc, - New_Lit (New_Global_Unchecked_Address - (Get_Info (Data.Sig).Object_Rti, - Rtis.Ghdl_Rti_Access))); - New_Procedure_Call (Assoc); - Close_Temp; - end Merge_Signals_Rti_Non_Composite; - - function Merge_Signals_Rti_Prepare (Targ : Mnode; - Targ_Type : Iir; - Data : Merge_Signals_Data) - return Merge_Signals_Data - is - pragma Unreferenced (Targ); - pragma Unreferenced (Targ_Type); - Res : Merge_Signals_Data; - begin - Res := Data; - if Data.Has_Val then - if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then - Res.Val := Stabilize (Data.Val); - else - Res.Val := Chap3.Get_Array_Base (Data.Val); - end if; - end if; - - return Res; - end Merge_Signals_Rti_Prepare; - - function Merge_Signals_Rti_Update_Data_Array - (Data : Merge_Signals_Data; Targ_Type : Iir; Index : O_Dnode) - return Merge_Signals_Data - is - begin - if not Data.Has_Val then - return Data; - else - return Merge_Signals_Data' - (Sig => Data.Sig, - Val => Chap3.Index_Base (Data.Val, Targ_Type, - New_Obj_Value (Index)), - Has_Val => True, - Set_Init => Data.Set_Init); - end if; - end Merge_Signals_Rti_Update_Data_Array; - - procedure Merge_Signals_Rti_Finish_Data_Composite - (Data : in out Merge_Signals_Data) - is - pragma Unreferenced (Data); - begin - null; - end Merge_Signals_Rti_Finish_Data_Composite; - - function Merge_Signals_Rti_Update_Data_Record - (Data : Merge_Signals_Data; - Targ_Type : Iir; - El : Iir_Element_Declaration) return Merge_Signals_Data - is - pragma Unreferenced (Targ_Type); - begin - if not Data.Has_Val then - return Data; - else - return Merge_Signals_Data' - (Sig => Data.Sig, - Val => Chap6.Translate_Selected_Element (Data.Val, El), - Has_Val => True, - Set_Init => Data.Set_Init); - end if; - end Merge_Signals_Rti_Update_Data_Record; - - pragma Inline (Merge_Signals_Rti_Finish_Data_Composite); - - procedure Merge_Signals_Rti is new Foreach_Non_Composite - (Data_Type => Merge_Signals_Data, - Composite_Data_Type => Merge_Signals_Data, - Do_Non_Composite => Merge_Signals_Rti_Non_Composite, - Prepare_Data_Array => Merge_Signals_Rti_Prepare, - Update_Data_Array => Merge_Signals_Rti_Update_Data_Array, - Finish_Data_Array => Merge_Signals_Rti_Finish_Data_Composite, - Prepare_Data_Record => Merge_Signals_Rti_Prepare, - Update_Data_Record => Merge_Signals_Rti_Update_Data_Record, - Finish_Data_Record => Merge_Signals_Rti_Finish_Data_Composite); - - procedure Merge_Signals_Rti_Of_Port_Chain (Chain : Iir) - is - Port : Iir; - Port_Type : Iir; - Data : Merge_Signals_Data; - Val : Iir; - begin - Port := Chain; - while Port /= Null_Iir loop - Port_Type := Get_Type (Port); - Data.Sig := Port; - case Get_Mode (Port) is - when Iir_Buffer_Mode - | Iir_Out_Mode - | Iir_Inout_Mode => - Data.Set_Init := True; - when others => - Data.Set_Init := False; - end case; - - Open_Temp; - Val := Get_Default_Value (Port); - if Val = Null_Iir then - Data.Has_Val := False; - else - Data.Has_Val := True; - Data.Val := E2M (Chap7.Translate_Expression (Val, Port_Type), - Get_Info (Port_Type), - Mode_Value); - end if; - - Merge_Signals_Rti (Chap6.Translate_Name (Port), Port_Type, Data); - Close_Temp; - - Port := Get_Chain (Port); - end loop; - end Merge_Signals_Rti_Of_Port_Chain; - - procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir) - is - Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); - Stmt : Iir; - Final : Boolean; - begin - New_Debug_Line_Stmt (Get_Line_Number (Block)); - - case Get_Kind (Block) is - when Iir_Kind_Entity_Declaration => - Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Block)); - when Iir_Kind_Architecture_Body => - null; - when Iir_Kind_Block_Statement => - declare - Header : constant Iir_Block_Header := - Get_Block_Header (Block); - Guard : constant Iir := Get_Guard_Decl (Block); - begin - if Guard /= Null_Iir then - New_Debug_Line_Stmt (Get_Line_Number (Guard)); - Elab_Implicit_Guard_Signal (Block, Base_Info); - end if; - if Header /= Null_Iir then - New_Debug_Line_Stmt (Get_Line_Number (Header)); - Chap5.Elab_Map_Aspect (Header, Block); - Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Header)); - end if; - end; - when Iir_Kind_Generate_Statement => - null; - when others => - Error_Kind ("elab_block_declarations", Block); - end case; - - Open_Temp; - Chap4.Elab_Declaration_Chain (Block, Final); - Close_Temp; - - Stmt := Get_Concurrent_Statement_Chain (Block); - while Stmt /= Null_Iir loop - case Get_Kind (Stmt) is - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Elab_Process (Stmt, Base_Info); - when Iir_Kind_Psl_Default_Clock => - null; - when Iir_Kind_Psl_Declaration => - null; - when Iir_Kind_Psl_Assert_Statement - | Iir_Kind_Psl_Cover_Statement => - Elab_Psl_Directive (Stmt, Base_Info); - when Iir_Kind_Component_Instantiation_Statement => - declare - Info : constant Block_Info_Acc := Get_Info (Stmt); - Constr : O_Assoc_List; - begin - Start_Association (Constr, Info.Block_Elab_Subprg); - New_Association - (Constr, Get_Instance_Access (Base_Block)); - New_Procedure_Call (Constr); - end; - when Iir_Kind_Block_Statement => - declare - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Elab_Block_Declarations (Stmt, Base_Block); - Pop_Identifier_Prefix (Mark); - end; - when Iir_Kind_Generate_Statement => - declare - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - - if Get_Kind (Get_Generation_Scheme (Stmt)) - = Iir_Kind_Iterator_Declaration - then - Elab_Iterative_Generate_Statement - (Stmt, Block, Base_Block); - else - Elab_Conditionnal_Generate_Statement - (Stmt, Block, Base_Block); - end if; - Pop_Identifier_Prefix (Mark); - end; - when others => - Error_Kind ("elab_block_declarations", Stmt); - end case; - Stmt := Get_Chain (Stmt); - end loop; - end Elab_Block_Declarations; - end Chap9; - - - package body Chap14 is - function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode - is - Prefix : constant Iir := Get_Prefix (Expr); - Type_Name : constant Iir := Is_Type_Name (Prefix); - Arr : Mnode; - Dim : Natural; - begin - if Type_Name /= Null_Iir then - -- Prefix denotes a type name - Arr := T2M (Type_Name, Mode_Value); - else - -- Prefix is an object. - Arr := Chap6.Translate_Name (Prefix); - end if; - Dim := Natural (Get_Value (Get_Parameter (Expr))); - return Chap3.Get_Array_Range (Arr, Get_Type (Prefix), Dim); - end Translate_Array_Attribute_To_Range; - - function Translate_Range_Array_Attribute (Expr : Iir) - return O_Lnode is - begin - return M2Lv (Translate_Array_Attribute_To_Range (Expr)); - end Translate_Range_Array_Attribute; - - function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) - return O_Enode - is - Rng : Mnode; - Val : O_Enode; - begin - Rng := Translate_Array_Attribute_To_Range (Expr); - Val := M2E (Chap3.Range_To_Length (Rng)); - if Rtype /= Null_Iir then - Val := New_Convert_Ov (Val, Get_Ortho_Type (Rtype, Mode_Value)); - end if; - return Val; - end Translate_Length_Array_Attribute; - - -- Extract high or low bound of RANGE_VAR. - function Range_To_High_Low - (Range_Var : Mnode; Range_Type : Iir; Is_High : Boolean) - return Mnode - is - Op : ON_Op_Kind; - If_Blk : O_If_Block; - Range_Svar : constant Mnode := Stabilize (Range_Var); - Res : O_Dnode; - Tinfo : constant Ortho_Info_Acc := - Get_Info (Get_Base_Type (Range_Type)); - begin - Res := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); - Open_Temp; - if Is_High then - Op := ON_Neq; - else - Op := ON_Eq; - end if; - Start_If_Stmt (If_Blk, - New_Compare_Op (Op, - M2E (Chap3.Range_To_Dir (Range_Svar)), - New_Lit (Ghdl_Dir_To_Node), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Obj (Res), - M2E (Chap3.Range_To_Left (Range_Svar))); - New_Else_Stmt (If_Blk); - New_Assign_Stmt (New_Obj (Res), - M2E (Chap3.Range_To_Right (Range_Svar))); - Finish_If_Stmt (If_Blk); - Close_Temp; - return Dv2M (Res, Tinfo, Mode_Value); - end Range_To_High_Low; - - function Translate_High_Low_Type_Attribute - (Atype : Iir; Is_High : Boolean) return O_Enode - is - Cons : constant Iir := Get_Range_Constraint (Atype); - begin - -- FIXME: improve code if constraint is a range expression. - if Get_Type_Staticness (Atype) = Locally then - if Get_Direction (Cons) = Iir_To xor Is_High then - return New_Lit - (Chap7.Translate_Static_Range_Left (Cons, Atype)); - else - return New_Lit - (Chap7.Translate_Static_Range_Right (Cons, Atype)); - end if; - else - return M2E (Range_To_High_Low - (Chap3.Type_To_Range (Atype), Atype, Is_High)); - end if; - end Translate_High_Low_Type_Attribute; - - function Translate_High_Low_Array_Attribute (Expr : Iir; - Is_High : Boolean) - return O_Enode - is - begin - -- FIXME: improve code if index is a range expression. - return M2E (Range_To_High_Low - (Translate_Array_Attribute_To_Range (Expr), - Get_Type (Expr), Is_High)); - end Translate_High_Low_Array_Attribute; - - function Translate_Low_Array_Attribute (Expr : Iir) - return O_Enode - is - begin - return Translate_High_Low_Array_Attribute (Expr, False); - end Translate_Low_Array_Attribute; - - function Translate_High_Array_Attribute (Expr : Iir) - return O_Enode - is - begin - return Translate_High_Low_Array_Attribute (Expr, True); - end Translate_High_Array_Attribute; - - function Translate_Left_Array_Attribute (Expr : Iir) - return O_Enode - is - Rng : Mnode; - begin - Rng := Translate_Array_Attribute_To_Range (Expr); - return M2E (Chap3.Range_To_Left (Rng)); - end Translate_Left_Array_Attribute; - - function Translate_Right_Array_Attribute (Expr : Iir) - return O_Enode - is - Rng : Mnode; - begin - Rng := Translate_Array_Attribute_To_Range (Expr); - return M2E (Chap3.Range_To_Right (Rng)); - end Translate_Right_Array_Attribute; - - function Translate_Ascending_Array_Attribute (Expr : Iir) - return O_Enode - is - Rng : Mnode; - begin - Rng := Translate_Array_Attribute_To_Range (Expr); - return New_Compare_Op (ON_Eq, - M2E (Chap3.Range_To_Dir (Rng)), - New_Lit (Ghdl_Dir_To_Node), - Std_Boolean_Type_Node); - end Translate_Ascending_Array_Attribute; - - function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode is - begin - if Get_Type_Staticness (Atype) = Locally then - return New_Lit (Chap7.Translate_Static_Range_Left - (Get_Range_Constraint (Atype), Atype)); - else - return M2E (Chap3.Range_To_Left (Chap3.Type_To_Range (Atype))); - end if; - end Translate_Left_Type_Attribute; - - function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode is - begin - if Get_Type_Staticness (Atype) = Locally then - return New_Lit (Chap7.Translate_Static_Range_Right - (Get_Range_Constraint (Atype), Atype)); - else - return M2E (Chap3.Range_To_Right (Chap3.Type_To_Range (Atype))); - end if; - end Translate_Right_Type_Attribute; - - function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode - is - Info : Type_Info_Acc; - begin - if Get_Type_Staticness (Atype) = Locally then - return New_Lit (Chap7.Translate_Static_Range_Dir - (Get_Range_Constraint (Atype))); - else - Info := Get_Info (Atype); - return New_Value - (New_Selected_Element (Get_Var (Info.T.Range_Var), - Info.T.Range_Dir)); - end if; - end Translate_Dir_Type_Attribute; - - function Translate_Val_Attribute (Attr : Iir) return O_Enode - is - Val : O_Enode; - Attr_Type : Iir; - Res_Var : O_Dnode; - Res_Type : O_Tnode; - begin - Attr_Type := Get_Type (Attr); - Res_Type := Get_Ortho_Type (Attr_Type, Mode_Value); - Res_Var := Create_Temp (Res_Type); - Val := Chap7.Translate_Expression (Get_Parameter (Attr)); - - case Get_Kind (Attr_Type) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - -- For enumeration, always check the value is in the enum - -- range. - declare - Val_Type : O_Tnode; - Val_Var : O_Dnode; - If_Blk : O_If_Block; - begin - Val_Type := Get_Ortho_Type (Get_Type (Get_Parameter (Attr)), - Mode_Value); - Val_Var := Create_Temp_Init (Val_Type, Val); - Start_If_Stmt - (If_Blk, - New_Dyadic_Op - (ON_Or, - New_Compare_Op (ON_Lt, - New_Obj_Value (Val_Var), - New_Lit (New_Signed_Literal - (Val_Type, 0)), - Ghdl_Bool_Type), - New_Compare_Op (ON_Ge, - New_Obj_Value (Val_Var), - New_Lit (New_Signed_Literal - (Val_Type, - Integer_64 - (Get_Nbr_Elements - (Get_Enumeration_Literal_List - (Attr_Type))))), - Ghdl_Bool_Type))); - Chap6.Gen_Bound_Error (Attr); - Finish_If_Stmt (If_Blk); - Val := New_Obj_Value (Val_Var); - end; - when others => - null; - end case; - - New_Assign_Stmt (New_Obj (Res_Var), New_Convert_Ov (Val, Res_Type)); - Chap3.Check_Range - (Res_Var, Attr, Get_Type (Get_Prefix (Attr)), Attr); - return New_Obj_Value (Res_Var); - end Translate_Val_Attribute; - - function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) - return O_Enode - is - T : O_Dnode; - Ttype : O_Tnode; - begin - Ttype := Get_Ortho_Type (Res_Type, Mode_Value); - T := Create_Temp (Ttype); - New_Assign_Stmt - (New_Obj (T), - New_Convert_Ov (Chap7.Translate_Expression (Get_Parameter (Attr)), - Ttype)); - Chap3.Check_Range (T, Attr, Res_Type, Attr); - return New_Obj_Value (T); - end Translate_Pos_Attribute; - - function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode - is - Expr_Type : Iir; - Tinfo : Type_Info_Acc; - Ttype : O_Tnode; - Expr : O_Enode; - List : Iir_List; - Limit : Iir; - Is_Succ : Boolean; - Op : ON_Op_Kind; - begin - -- FIXME: should check bounds. - Expr_Type := Get_Type (Attr); - Tinfo := Get_Info (Expr_Type); - Expr := Chap7.Translate_Expression (Get_Parameter (Attr), Expr_Type); - Ttype := Tinfo.Ortho_Type (Mode_Value); - Is_Succ := Get_Kind (Attr) = Iir_Kind_Succ_Attribute; - if Is_Succ then - Op := ON_Add_Ov; - else - Op := ON_Sub_Ov; - end if; - case Tinfo.Type_Mode is - when Type_Mode_B1 - | Type_Mode_E8 - | Type_Mode_E32 => - -- Should check it is not the last. - declare - L : O_Dnode; - begin - List := Get_Enumeration_Literal_List (Get_Base_Type - (Expr_Type)); - L := Create_Temp_Init (Ttype, Expr); - if Is_Succ then - Limit := Get_Last_Element (List); - else - Limit := Get_First_Element (List); - end if; - Chap6.Check_Bound_Error - (New_Compare_Op (ON_Eq, - New_Obj_Value (L), - New_Lit (Get_Ortho_Expr (Limit)), - Ghdl_Bool_Type), - Attr, 0); - return New_Convert_Ov - (New_Dyadic_Op - (Op, - New_Convert_Ov (New_Obj_Value (L), Ghdl_I32_Type), - New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1))), - Ttype); - end; - when Type_Mode_I32 - | Type_Mode_P64 => - return New_Dyadic_Op - (Op, Expr, New_Lit (New_Signed_Literal (Ttype, 1))); - when others => - raise Internal_Error; - end case; - end Translate_Succ_Pred_Attribute; - - type Bool_Sigattr_Data_Type is record - Label : O_Snode; - Field : O_Fnode; - end record; - - procedure Bool_Sigattr_Non_Composite_Signal - (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) - is - pragma Unreferenced (Targ_Type); - begin - Gen_Exit_When (Data.Label, - New_Value (Get_Signal_Field (Targ, Data.Field))); - end Bool_Sigattr_Non_Composite_Signal; - - function Bool_Sigattr_Prepare_Data_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) - return Bool_Sigattr_Data_Type - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Data; - end Bool_Sigattr_Prepare_Data_Composite; - - function Bool_Sigattr_Update_Data_Array (Data : Bool_Sigattr_Data_Type; - Targ_Type : Iir; - Index : O_Dnode) - return Bool_Sigattr_Data_Type - is - pragma Unreferenced (Targ_Type, Index); - begin - return Data; - end Bool_Sigattr_Update_Data_Array; - - function Bool_Sigattr_Update_Data_Record (Data : Bool_Sigattr_Data_Type; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Bool_Sigattr_Data_Type - is - pragma Unreferenced (Targ_Type, El); - begin - return Data; - end Bool_Sigattr_Update_Data_Record; - - procedure Bool_Sigattr_Finish_Data_Composite - (Data : in out Bool_Sigattr_Data_Type) - is - pragma Unreferenced (Data); - begin - null; - end Bool_Sigattr_Finish_Data_Composite; - - procedure Bool_Sigattr_Foreach is new Foreach_Non_Composite - (Data_Type => Bool_Sigattr_Data_Type, - Composite_Data_Type => Bool_Sigattr_Data_Type, - Do_Non_Composite => Bool_Sigattr_Non_Composite_Signal, - Prepare_Data_Array => Bool_Sigattr_Prepare_Data_Composite, - Update_Data_Array => Bool_Sigattr_Update_Data_Array, - Finish_Data_Array => Bool_Sigattr_Finish_Data_Composite, - Prepare_Data_Record => Bool_Sigattr_Prepare_Data_Composite, - Update_Data_Record => Bool_Sigattr_Update_Data_Record, - Finish_Data_Record => Bool_Sigattr_Finish_Data_Composite); - - function Translate_Bool_Signal_Attribute (Attr : Iir; Field : O_Fnode) - return O_Enode - is - Data : Bool_Sigattr_Data_Type; - Res : O_Dnode; - Name : Mnode; - Prefix : constant Iir := Get_Prefix (Attr); - Prefix_Type : constant Iir := Get_Type (Prefix); - begin - if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then - -- Effecient handling for a scalar signal. - Name := Chap6.Translate_Name (Prefix); - return New_Value (Get_Signal_Field (Name, Field)); - else - -- Element per element handling for composite signals. - Res := Create_Temp (Std_Boolean_Type_Node); - Open_Temp; - New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); - Name := Chap6.Translate_Name (Prefix); - Start_Loop_Stmt (Data.Label); - Data.Field := Field; - Bool_Sigattr_Foreach (Name, Prefix_Type, Data); - New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); - New_Exit_Stmt (Data.Label); - Finish_Loop_Stmt (Data.Label); - Close_Temp; - return New_Obj_Value (Res); - end if; - end Translate_Bool_Signal_Attribute; - - function Translate_Event_Attribute (Attr : Iir) return O_Enode is - begin - return Translate_Bool_Signal_Attribute - (Attr, Ghdl_Signal_Event_Field); - end Translate_Event_Attribute; - - function Translate_Active_Attribute (Attr : Iir) return O_Enode is - begin - return Translate_Bool_Signal_Attribute - (Attr, Ghdl_Signal_Active_Field); - end Translate_Active_Attribute; - - -- Read signal value FIELD of signal SIG. - function Get_Signal_Value_Field - (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) - return O_Lnode - is - S_Type : O_Tnode; - T : O_Lnode; - begin - S_Type := Get_Ortho_Type (Sig_Type, Mode_Signal); - T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); - return New_Access_Element - (New_Unchecked_Address (New_Selected_Element (T, Field), S_Type)); - end Get_Signal_Value_Field; - - function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) - return O_Lnode - is - S : O_Enode; - begin - S := New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr); - return New_Selected_Element (New_Access_Element (S), Field); - end Get_Signal_Field; - - function Read_Last_Value (Sig : O_Enode; Sig_Type : Iir) return O_Enode - is - begin - return New_Value (Get_Signal_Value_Field - (Sig, Sig_Type, Ghdl_Signal_Last_Value_Field)); - end Read_Last_Value; - - function Translate_Last_Value is new Chap7.Translate_Signal_Value - (Read_Value => Read_Last_Value); - - function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode - is - Name : Mnode; - Prefix : Iir; - Prefix_Type : Iir; - begin - Prefix := Get_Prefix (Attr); - Prefix_Type := Get_Type (Prefix); - - Name := Chap6.Translate_Name (Prefix); - if Get_Object_Kind (Name) /= Mode_Signal then - raise Internal_Error; - end if; - return Translate_Last_Value (M2E (Name), Prefix_Type); - end Translate_Last_Value_Attribute; - - function Read_Last_Time (Sig : O_Enode; Field : O_Fnode) return O_Enode - is - T : O_Lnode; - begin - T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); - return New_Value (New_Selected_Element (T, Field)); - end Read_Last_Time; - - type Last_Time_Data is record - Var : O_Dnode; - Field : O_Fnode; - end record; - - procedure Translate_Last_Time_Non_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) - is - pragma Unreferenced (Targ_Type); - Val : O_Dnode; - If_Blk : O_If_Block; - begin - Open_Temp; - Val := Create_Temp_Init - (Std_Time_Otype, - Read_Last_Time (New_Value (M2Lv (Targ)), Data.Field)); - Start_If_Stmt (If_Blk, - New_Compare_Op (ON_Gt, - New_Obj_Value (Val), - New_Obj_Value (Data.Var), - Ghdl_Bool_Type)); - New_Assign_Stmt (New_Obj (Data.Var), New_Obj_Value (Val)); - Finish_If_Stmt (If_Blk); - Close_Temp; - end Translate_Last_Time_Non_Composite; - - function Last_Time_Prepare_Data_Composite - (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) - return Last_Time_Data - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Data; - end Last_Time_Prepare_Data_Composite; - - function Last_Time_Update_Data_Array (Data : Last_Time_Data; - Targ_Type : Iir; - Index : O_Dnode) - return Last_Time_Data - is - pragma Unreferenced (Targ_Type, Index); - begin - return Data; - end Last_Time_Update_Data_Array; - - function Last_Time_Update_Data_Record (Data : Last_Time_Data; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return Last_Time_Data - is - pragma Unreferenced (Targ_Type, El); - begin - return Data; - end Last_Time_Update_Data_Record; - - procedure Last_Time_Finish_Data_Composite - (Data : in out Last_Time_Data) - is - pragma Unreferenced (Data); - begin - null; - end Last_Time_Finish_Data_Composite; - - procedure Translate_Last_Time is new Foreach_Non_Composite - (Data_Type => Last_Time_Data, - Composite_Data_Type => Last_Time_Data, - Do_Non_Composite => Translate_Last_Time_Non_Composite, - Prepare_Data_Array => Last_Time_Prepare_Data_Composite, - Update_Data_Array => Last_Time_Update_Data_Array, - Finish_Data_Array => Last_Time_Finish_Data_Composite, - Prepare_Data_Record => Last_Time_Prepare_Data_Composite, - Update_Data_Record => Last_Time_Update_Data_Record, - Finish_Data_Record => Last_Time_Finish_Data_Composite); - - function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) - return O_Enode - is - Prefix_Type : Iir; - Name : Mnode; - Info : Type_Info_Acc; - Var : O_Dnode; - Data : Last_Time_Data; - Right_Bound : Iir_Int64; - If_Blk : O_If_Block; - begin - Prefix_Type := Get_Type (Prefix); - Name := Chap6.Translate_Name (Prefix); - Info := Get_Info (Prefix_Type); - Var := Create_Temp (Std_Time_Otype); - - if Info.Type_Mode in Type_Mode_Scalar then - New_Assign_Stmt (New_Obj (Var), - Read_Last_Time (M2E (Name), Field)); - else - -- Init with a negative value. - New_Assign_Stmt - (New_Obj (Var), - New_Lit (New_Signed_Literal (Std_Time_Otype, -1))); - Data := Last_Time_Data'(Var => Var, Field => Field); - Translate_Last_Time (Name, Prefix_Type, Data); - end if; - - Right_Bound := Get_Value - (Get_Right_Limit (Get_Range_Constraint (Time_Subtype_Definition))); - - -- VAR < 0 ? - Start_If_Stmt - (If_Blk, - New_Compare_Op (ON_Lt, - New_Obj_Value (Var), - New_Lit (New_Signed_Literal (Std_Time_Otype, 0)), - Ghdl_Bool_Type)); - -- LRM 14.1 Predefined attributes - -- [...]; otherwise, it returns TIME'HIGH. - New_Assign_Stmt - (New_Obj (Var), - New_Lit (New_Signed_Literal - (Std_Time_Otype, Integer_64 (Right_Bound)))); - New_Else_Stmt (If_Blk); - -- Returns NOW - Var. - New_Assign_Stmt (New_Obj (Var), - New_Dyadic_Op (ON_Sub_Ov, - New_Obj_Value (Ghdl_Now), - New_Obj_Value (Var))); - Finish_If_Stmt (If_Blk); - return New_Obj_Value (Var); - end Translate_Last_Time_Attribute; - - -- Return TRUE if the scalar signal SIG is being driven. - function Read_Driving_Attribute (Sig : O_Enode) return O_Enode - is - Assoc : O_Assoc_List; - begin - Start_Association (Assoc, Ghdl_Signal_Driving); - New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); - return New_Function_Call (Assoc); - end Read_Driving_Attribute; - - procedure Driving_Non_Composite_Signal - (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) - is - pragma Unreferenced (Targ_Type); - begin - Gen_Exit_When - (Label, - New_Monadic_Op - (ON_Not, Read_Driving_Attribute (New_Value (M2Lv (Targ))))); - end Driving_Non_Composite_Signal; - - function Driving_Prepare_Data_Composite - (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) - return O_Snode - is - pragma Unreferenced (Targ, Targ_Type); - begin - return Label; - end Driving_Prepare_Data_Composite; - - function Driving_Update_Data_Array (Label : O_Snode; - Targ_Type : Iir; - Index : O_Dnode) - return O_Snode - is - pragma Unreferenced (Targ_Type, Index); - begin - return Label; - end Driving_Update_Data_Array; - - function Driving_Update_Data_Record (Label : O_Snode; - Targ_Type : Iir; - El : Iir_Element_Declaration) - return O_Snode - is - pragma Unreferenced (Targ_Type, El); - begin - return Label; - end Driving_Update_Data_Record; - - procedure Driving_Finish_Data_Composite (Label : in out O_Snode) - is - pragma Unreferenced (Label); - begin - null; - end Driving_Finish_Data_Composite; - - procedure Driving_Foreach is new Foreach_Non_Composite - (Data_Type => O_Snode, - Composite_Data_Type => O_Snode, - Do_Non_Composite => Driving_Non_Composite_Signal, - Prepare_Data_Array => Driving_Prepare_Data_Composite, - Update_Data_Array => Driving_Update_Data_Array, - Finish_Data_Array => Driving_Finish_Data_Composite, - Prepare_Data_Record => Driving_Prepare_Data_Composite, - Update_Data_Record => Driving_Update_Data_Record, - Finish_Data_Record => Driving_Finish_Data_Composite); - - function Translate_Driving_Attribute (Attr : Iir) return O_Enode - is - Label : O_Snode; - Res : O_Dnode; - Name : Mnode; - Prefix : Iir; - Prefix_Type : Iir; - begin - Prefix := Get_Prefix (Attr); - Prefix_Type := Get_Type (Prefix); - - if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then - -- Effecient handling for a scalar signal. - Name := Chap6.Translate_Name (Prefix); - return Read_Driving_Attribute (New_Value (M2Lv (Name))); - else - -- Element per element handling for composite signals. - Res := Create_Temp (Std_Boolean_Type_Node); - Open_Temp; - New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); - Name := Chap6.Translate_Name (Prefix); - Start_Loop_Stmt (Label); - Driving_Foreach (Name, Prefix_Type, Label); - New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); - New_Exit_Stmt (Label); - Finish_Loop_Stmt (Label); - Close_Temp; - return New_Obj_Value (Res); - end if; - end Translate_Driving_Attribute; - - function Read_Driving_Value (Sig : O_Enode; Sig_Type : Iir) - return O_Enode - is - Tinfo : Type_Info_Acc; - Subprg : O_Dnode; - Assoc : O_Assoc_List; - begin - Tinfo := Get_Info (Sig_Type); - case Tinfo.Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Signal_Driving_Value_B1; - when Type_Mode_E8 => - Subprg := Ghdl_Signal_Driving_Value_E8; - when Type_Mode_E32 => - Subprg := Ghdl_Signal_Driving_Value_E32; - when Type_Mode_I32 - | Type_Mode_P32 => - Subprg := Ghdl_Signal_Driving_Value_I32; - when Type_Mode_P64 - | Type_Mode_I64 => - Subprg := Ghdl_Signal_Driving_Value_I64; - when Type_Mode_F64 => - Subprg := Ghdl_Signal_Driving_Value_F64; - when others => - raise Internal_Error; - end case; - Start_Association (Assoc, Subprg); - New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); - return New_Convert_Ov (New_Function_Call (Assoc), - Tinfo.Ortho_Type (Mode_Value)); - end Read_Driving_Value; - - function Translate_Driving_Value is new Chap7.Translate_Signal_Value - (Read_Value => Read_Driving_Value); - - function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode - is - Name : Mnode; - Prefix : Iir; - Prefix_Type : Iir; - begin - Prefix := Get_Prefix (Attr); - Prefix_Type := Get_Type (Prefix); - - Name := Chap6.Translate_Name (Prefix); - if Get_Object_Kind (Name) /= Mode_Signal then - raise Internal_Error; - end if; - return Translate_Driving_Value (M2E (Name), Prefix_Type); - end Translate_Driving_Value_Attribute; - - function Translate_Image_Attribute (Attr : Iir) return O_Enode - is - Prefix_Type : constant Iir := - Get_Base_Type (Get_Type (Get_Prefix (Attr))); - Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); - Res : O_Dnode; - Subprg : O_Dnode; - Assoc : O_Assoc_List; - Conv : O_Tnode; - begin - Res := Create_Temp (Std_String_Node); - Create_Temp_Stack2_Mark; - case Pinfo.Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Image_B1; - Conv := Ghdl_Bool_Type; - when Type_Mode_E8 => - Subprg := Ghdl_Image_E8; - Conv := Ghdl_I32_Type; - when Type_Mode_E32 => - Subprg := Ghdl_Image_E32; - Conv := Ghdl_I32_Type; - when Type_Mode_I32 => - Subprg := Ghdl_Image_I32; - Conv := Ghdl_I32_Type; - when Type_Mode_P32 => - Subprg := Ghdl_Image_P32; - Conv := Ghdl_I32_Type; - when Type_Mode_P64 => - Subprg := Ghdl_Image_P64; - Conv := Ghdl_I64_Type; - when Type_Mode_F64 => - Subprg := Ghdl_Image_F64; - Conv := Ghdl_Real_Type; - when others => - raise Internal_Error; - end case; - Start_Association (Assoc, Subprg); - New_Association (Assoc, - New_Address (New_Obj (Res), Std_String_Ptr_Node)); - New_Association - (Assoc, - New_Convert_Ov - (Chap7.Translate_Expression (Get_Parameter (Attr), Prefix_Type), - Conv)); - case Pinfo.Type_Mode is - when Type_Mode_B1 - | Type_Mode_E8 - | Type_Mode_E32 - | Type_Mode_P32 - | Type_Mode_P64 => - New_Association - (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); - when Type_Mode_I32 - | Type_Mode_F64 => - null; - when others => - raise Internal_Error; - end case; - New_Procedure_Call (Assoc); - return New_Address (New_Obj (Res), Std_String_Ptr_Node); - end Translate_Image_Attribute; - - function Translate_Value_Attribute (Attr : Iir) return O_Enode - is - Prefix_Type : constant Iir := - Get_Base_Type (Get_Type (Get_Prefix (Attr))); - Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); - Subprg : O_Dnode; - Assoc : O_Assoc_List; - begin - case Pinfo.Type_Mode is - when Type_Mode_B1 => - Subprg := Ghdl_Value_B1; - when Type_Mode_E8 => - Subprg := Ghdl_Value_E8; - when Type_Mode_E32 => - Subprg := Ghdl_Value_E32; - when Type_Mode_I32 => - Subprg := Ghdl_Value_I32; - when Type_Mode_P32 => - Subprg := Ghdl_Value_P32; - when Type_Mode_P64 => - Subprg := Ghdl_Value_P64; - when Type_Mode_F64 => - Subprg := Ghdl_Value_F64; - when others => - raise Internal_Error; - end case; - Start_Association (Assoc, Subprg); - New_Association - (Assoc, - Chap7.Translate_Expression (Get_Parameter (Attr), - String_Type_Definition)); - case Pinfo.Type_Mode is - when Type_Mode_B1 - | Type_Mode_E8 - | Type_Mode_E32 - | Type_Mode_P32 - | Type_Mode_P64 => - New_Association - (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); - when Type_Mode_I32 - | Type_Mode_F64 => - null; - when others => - raise Internal_Error; - end case; - return New_Convert_Ov (New_Function_Call (Assoc), - Pinfo.Ortho_Type (Mode_Value)); - end Translate_Value_Attribute; - - function Translate_Path_Instance_Name_Attribute (Attr : Iir) - return O_Enode - is - Name : constant Path_Instance_Name_Type := - Get_Path_Instance_Name_Suffix (Attr); - Res : O_Dnode; - Name_Cst : O_Dnode; - Str_Cst : O_Cnode; - Constr : O_Assoc_List; - Is_Instance : constant Boolean := - Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; - begin - Create_Temp_Stack2_Mark; - - Res := Create_Temp (Std_String_Node); - Str_Cst := Create_String_Len (Name.Suffix, Create_Uniq_Identifier); - New_Const_Decl (Name_Cst, Create_Uniq_Identifier, O_Storage_Private, - Ghdl_Str_Len_Type_Node); - Start_Const_Value (Name_Cst); - Finish_Const_Value (Name_Cst, Str_Cst); - if Is_Instance then - Start_Association (Constr, Ghdl_Get_Instance_Name); - else - Start_Association (Constr, Ghdl_Get_Path_Name); - end if; - New_Association - (Constr, New_Address (New_Obj (Res), Std_String_Ptr_Node)); - if Name.Path_Instance = Null_Iir then - Rtis.Associate_Null_Rti_Context (Constr); - else - Rtis.Associate_Rti_Context (Constr, Name.Path_Instance); - end if; - New_Association (Constr, - New_Address (New_Obj (Name_Cst), - Ghdl_Str_Len_Ptr_Node)); - New_Procedure_Call (Constr); - return New_Address (New_Obj (Res), Std_String_Ptr_Node); - end Translate_Path_Instance_Name_Attribute; - end Chap14; - - package body Rtis is - -- Node for package, body, entity, architecture, block, generate, - -- processes. - Ghdl_Rtin_Block : O_Tnode; - Ghdl_Rtin_Block_Common : O_Fnode; - Ghdl_Rtin_Block_Name : O_Fnode; - Ghdl_Rtin_Block_Loc : O_Fnode; - Ghdl_Rtin_Block_Parent : O_Fnode; - Ghdl_Rtin_Block_Size : O_Fnode; - Ghdl_Rtin_Block_Nbr_Child : O_Fnode; - Ghdl_Rtin_Block_Children : O_Fnode; - - -- Node for scalar type decls. - Ghdl_Rtin_Type_Scalar : O_Tnode; - Ghdl_Rtin_Type_Scalar_Common : O_Fnode; - Ghdl_Rtin_Type_Scalar_Name : O_Fnode; - - -- Node for an enumeration type definition. - Ghdl_Rtin_Type_Enum : O_Tnode; - Ghdl_Rtin_Type_Enum_Common : O_Fnode; - Ghdl_Rtin_Type_Enum_Name : O_Fnode; - Ghdl_Rtin_Type_Enum_Nbr : O_Fnode; - Ghdl_Rtin_Type_Enum_Lits : O_Fnode; - - -- Node for an unit64. - Ghdl_Rtin_Unit64 : O_Tnode; - Ghdl_Rtin_Unit64_Common : O_Fnode; - Ghdl_Rtin_Unit64_Name : O_Fnode; - Ghdl_Rtin_Unit64_Value : O_Fnode; - - -- Node for an unitptr. - Ghdl_Rtin_Unitptr : O_Tnode; - Ghdl_Rtin_Unitptr_Common : O_Fnode; - Ghdl_Rtin_Unitptr_Name : O_Fnode; - Ghdl_Rtin_Unitptr_Value : O_Fnode; - - -- Node for a physical type - Ghdl_Rtin_Type_Physical : O_Tnode; - Ghdl_Rtin_Type_Physical_Common : O_Fnode; - Ghdl_Rtin_Type_Physical_Name : O_Fnode; - Ghdl_Rtin_Type_Physical_Nbr : O_Fnode; - Ghdl_Rtin_Type_Physical_Units : O_Fnode; - - -- Node for a scalar subtype definition. - Ghdl_Rtin_Subtype_Scalar : O_Tnode; - Ghdl_Rtin_Subtype_Scalar_Common : O_Fnode; - Ghdl_Rtin_Subtype_Scalar_Name : O_Fnode; - Ghdl_Rtin_Subtype_Scalar_Base : O_Fnode; - Ghdl_Rtin_Subtype_Scalar_Range : O_Fnode; - - -- Node for an access or a file type. - Ghdl_Rtin_Type_Fileacc : O_Tnode; - Ghdl_Rtin_Type_Fileacc_Common : O_Fnode; - Ghdl_Rtin_Type_Fileacc_Name : O_Fnode; - Ghdl_Rtin_Type_Fileacc_Base : O_Fnode; - - -- Node for an array type. - Ghdl_Rtin_Type_Array : O_Tnode; - Ghdl_Rtin_Type_Array_Common : O_Fnode; - Ghdl_Rtin_Type_Array_Name : O_Fnode; - Ghdl_Rtin_Type_Array_Element : O_Fnode; - Ghdl_Rtin_Type_Array_Nbrdim : O_Fnode; - Ghdl_Rtin_Type_Array_Indexes : O_Fnode; - - -- Node for an array subtype. - Ghdl_Rtin_Subtype_Array : O_Tnode; - Ghdl_Rtin_Subtype_Array_Common : O_Fnode; - Ghdl_Rtin_Subtype_Array_Name : O_Fnode; - Ghdl_Rtin_Subtype_Array_Basetype : O_Fnode; - Ghdl_Rtin_Subtype_Array_Bounds : O_Fnode; - Ghdl_Rtin_Subtype_Array_Valsize : O_Fnode; - Ghdl_Rtin_Subtype_Array_Sigsize : O_Fnode; - - -- Node for a record element. - Ghdl_Rtin_Element : O_Tnode; - Ghdl_Rtin_Element_Common : O_Fnode; - Ghdl_Rtin_Element_Name : O_Fnode; - Ghdl_Rtin_Element_Type : O_Fnode; - Ghdl_Rtin_Element_Valoff : O_Fnode; - Ghdl_Rtin_Element_Sigoff : O_Fnode; - - -- Node for a record type. - Ghdl_Rtin_Type_Record : O_Tnode; - Ghdl_Rtin_Type_Record_Common : O_Fnode; - Ghdl_Rtin_Type_Record_Name : O_Fnode; - Ghdl_Rtin_Type_Record_Nbrel : O_Fnode; - Ghdl_Rtin_Type_Record_Elements : O_Fnode; - --Ghdl_Rtin_Type_Record_Valsize : O_Fnode; - --Ghdl_Rtin_Type_Record_Sigsize : O_Fnode; - - -- Node for an object. - Ghdl_Rtin_Object : O_Tnode; - Ghdl_Rtin_Object_Common : O_Fnode; - Ghdl_Rtin_Object_Name : O_Fnode; - Ghdl_Rtin_Object_Loc : O_Fnode; - Ghdl_Rtin_Object_Type : O_Fnode; - - -- Node for an instance. - Ghdl_Rtin_Instance : O_Tnode; - Ghdl_Rtin_Instance_Common : O_Fnode; - Ghdl_Rtin_Instance_Name : O_Fnode; - Ghdl_Rtin_Instance_Loc : O_Fnode; - Ghdl_Rtin_Instance_Parent : O_Fnode; - Ghdl_Rtin_Instance_Type : O_Fnode; - - -- Node for a component. - Ghdl_Rtin_Component : O_Tnode; - Ghdl_Rtin_Component_Common : O_Fnode; - Ghdl_Rtin_Component_Name : O_Fnode; - Ghdl_Rtin_Component_Nbr_Child : O_Fnode; - Ghdl_Rtin_Component_Children : O_Fnode; - - procedure Rti_Initialize - is - begin - -- Create type ghdl_rti_kind is (ghdl_rtik_typedef_bool, ...) - declare - Constr : O_Enum_List; - begin - Start_Enum_Type (Constr, 8); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_top"), - Ghdl_Rtik_Top); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_library"), - Ghdl_Rtik_Library); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_package"), - Ghdl_Rtik_Package); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_package_body"), - Ghdl_Rtik_Package_Body); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_entity"), - Ghdl_Rtik_Entity); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_architecture"), - Ghdl_Rtik_Architecture); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_process"), - Ghdl_Rtik_Process); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_block"), - Ghdl_Rtik_Block); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_if_generate"), - Ghdl_Rtik_If_Generate); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_for_generate"), - Ghdl_Rtik_For_Generate); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_instance"), - Ghdl_Rtik_Instance); - - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_constant"), - Ghdl_Rtik_Constant); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_iterator"), - Ghdl_Rtik_Iterator); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_variable"), - Ghdl_Rtik_Variable); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_signal"), - Ghdl_Rtik_Signal); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_file"), - Ghdl_Rtik_File); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_port"), - Ghdl_Rtik_Port); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_generic"), - Ghdl_Rtik_Generic); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_alias"), - Ghdl_Rtik_Alias); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_guard"), - Ghdl_Rtik_Guard); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_component"), - Ghdl_Rtik_Component); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_attribute"), - Ghdl_Rtik_Attribute); - - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_b1"), - Ghdl_Rtik_Type_B1); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_e8"), - Ghdl_Rtik_Type_E8); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_e32"), - Ghdl_Rtik_Type_E32); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_i32"), - Ghdl_Rtik_Type_I32); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_i64"), - Ghdl_Rtik_Type_I64); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_f64"), - Ghdl_Rtik_Type_F64); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_p32"), - Ghdl_Rtik_Type_P32); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_p64"), - Ghdl_Rtik_Type_P64); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_access"), - Ghdl_Rtik_Type_Access); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_array"), - Ghdl_Rtik_Type_Array); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_record"), - Ghdl_Rtik_Type_Record); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_file"), - Ghdl_Rtik_Type_File); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_subtype_scalar"), - Ghdl_Rtik_Subtype_Scalar); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_subtype_array"), - Ghdl_Rtik_Subtype_Array); - New_Enum_Literal - (Constr, - Get_Identifier ("__ghdl_rtik_subtype_unconstrained_array"), - Ghdl_Rtik_Subtype_Unconstrained_Array); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_subtype_record"), - Ghdl_Rtik_Subtype_Record); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_subtype_access"), - Ghdl_Rtik_Subtype_Access); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_type_protected"), - Ghdl_Rtik_Type_Protected); - - New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_element"), - Ghdl_Rtik_Element); - New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unit64"), - Ghdl_Rtik_Unit64); - New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unitptr"), - Ghdl_Rtik_Unitptr); - - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_attribute_transaction"), - Ghdl_Rtik_Attribute_Transaction); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_attribute_quiet"), - Ghdl_Rtik_Attribute_Quiet); - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_attribute_stable"), - Ghdl_Rtik_Attribute_Stable); - - New_Enum_Literal - (Constr, Get_Identifier ("__ghdl_rtik_psl_assert"), - Ghdl_Rtik_Psl_Assert); - - New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_error"), - Ghdl_Rtik_Error); - Finish_Enum_Type (Constr, Ghdl_Rtik); - New_Type_Decl (Get_Identifier ("__ghdl_rtik"), Ghdl_Rtik); - end; - - -- Create type ghdl_rti_depth. - Ghdl_Rti_Depth := New_Unsigned_Type (8); - New_Type_Decl (Get_Identifier ("__ghdl_rti_depth"), Ghdl_Rti_Depth); - Ghdl_Rti_U8 := New_Unsigned_Type (8); - New_Type_Decl (Get_Identifier ("__ghdl_rti_u8"), Ghdl_Rti_U8); - - -- Create type ghdl_rti_common. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rti_Common_Kind, - Get_Identifier ("kind"), Ghdl_Rtik); - New_Record_Field (Constr, Ghdl_Rti_Common_Depth, - Get_Identifier ("depth"), Ghdl_Rti_Depth); - New_Record_Field (Constr, Ghdl_Rti_Common_Mode, - Get_Identifier ("mode"), Ghdl_Rti_U8); - New_Record_Field (Constr, Ghdl_Rti_Common_Max_Depth, - Get_Identifier ("max_depth"), Ghdl_Rti_Depth); - Finish_Record_Type (Constr, Ghdl_Rti_Common); - New_Type_Decl (Get_Identifier ("__ghdl_rti_common"), - Ghdl_Rti_Common); - end; - - Ghdl_Rti_Access := New_Access_Type (Ghdl_Rti_Common); - New_Type_Decl (Get_Identifier ("__ghdl_rti_access"), Ghdl_Rti_Access); - - Ghdl_Rti_Array := New_Array_Type (Ghdl_Rti_Access, Ghdl_Index_Type); - New_Type_Decl (Get_Identifier ("__ghdl_rti_array"), Ghdl_Rti_Array); - - Ghdl_Rti_Arr_Acc := New_Access_Type (Ghdl_Rti_Array); - New_Type_Decl (Get_Identifier ("__ghdl_rti_arr_acc"), - Ghdl_Rti_Arr_Acc); - - -- Ghdl_Component_Link_Type. - New_Uncomplete_Record_Type (Ghdl_Component_Link_Type); - New_Type_Decl (Get_Identifier ("__ghdl_component_link_type"), - Ghdl_Component_Link_Type); - - Ghdl_Component_Link_Acc := New_Access_Type (Ghdl_Component_Link_Type); - New_Type_Decl (Get_Identifier ("__ghdl_component_link_acc"), - Ghdl_Component_Link_Acc); - - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Entity_Link_Rti, - Get_Identifier ("rti"), Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Entity_Link_Parent, - Wki_Parent, Ghdl_Component_Link_Acc); - Finish_Record_Type (Constr, Ghdl_Entity_Link_Type); - New_Type_Decl (Get_Identifier ("__ghdl_entity_link_type"), - Ghdl_Entity_Link_Type); - end; - - Ghdl_Entity_Link_Acc := New_Access_Type (Ghdl_Entity_Link_Type); - New_Type_Decl (Get_Identifier ("__ghdl_entity_link_acc"), - Ghdl_Entity_Link_Acc); - - declare - Constr : O_Element_List; - begin - Start_Uncomplete_Record_Type (Ghdl_Component_Link_Type, Constr); - New_Record_Field (Constr, Ghdl_Component_Link_Instance, - Wki_Instance, Ghdl_Entity_Link_Acc); - New_Record_Field (Constr, Ghdl_Component_Link_Stmt, - Get_Identifier ("stmt"), Ghdl_Rti_Access); - Finish_Record_Type (Constr, Ghdl_Component_Link_Type); - end; - - -- Create type ghdl_rtin_block - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Block_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Block_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Block_Loc, - Get_Identifier ("loc"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Block_Parent, - Wki_Parent, Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Block_Size, - Get_Identifier ("size"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Block_Nbr_Child, - Get_Identifier ("nbr_child"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Block_Children, - Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); - Finish_Record_Type (Constr, Ghdl_Rtin_Block); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_block"), - Ghdl_Rtin_Block); - end; - - -- type (type and subtype declarations). - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Name, - Get_Identifier ("name"), Char_Ptr_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Type_Scalar); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_scalar"), - Ghdl_Rtin_Type_Scalar); - end; - - -- Type_Enum - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Nbr, - Get_Identifier ("nbr"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Lits, - Get_Identifier ("lits"), - Char_Ptr_Array_Ptr_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Type_Enum); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_enum"), - Ghdl_Rtin_Type_Enum); - end; - - -- subtype_scalar - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Base, - Get_Identifier ("base"), Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Range, - Get_Identifier ("range"), Ghdl_Ptr_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Scalar); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_scalar"), - Ghdl_Rtin_Subtype_Scalar); - end; - - -- Unit64 - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Unit64_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Unit64_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Unit64_Value, - Wki_Val, Ghdl_I64_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Unit64); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_unit64"), - Ghdl_Rtin_Unit64); - end; - - -- Unitptr - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Value, - Get_Identifier ("addr"), Ghdl_Ptr_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Unitptr); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_unitptr"), - Ghdl_Rtin_Unitptr); - end; - - -- Physical type. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Nbr, - Get_Identifier ("nbr"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Units, - Get_Identifier ("units"), Ghdl_Rti_Arr_Acc); - Finish_Record_Type (Constr, Ghdl_Rtin_Type_Physical); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_physical"), - Ghdl_Rtin_Type_Physical); - end; - - -- file and access type. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Base, - Get_Identifier ("base"), Ghdl_Rti_Access); - Finish_Record_Type (Constr, Ghdl_Rtin_Type_Fileacc); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_fileacc"), - Ghdl_Rtin_Type_Fileacc); - end; - - -- arraytype. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Element, - Get_Identifier ("element"), Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Nbrdim, - Get_Identifier ("nbr_dim"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Indexes, - Get_Identifier ("indexes"), Ghdl_Rti_Arr_Acc); - Finish_Record_Type (Constr, Ghdl_Rtin_Type_Array); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_array"), - Ghdl_Rtin_Type_Array); - end; - - -- subtype_Array. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Basetype, - Get_Identifier ("basetype"), Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Bounds, - Get_Identifier ("bounds"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Valsize, - Get_Identifier ("val_size"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Sigsize, - Get_Identifier ("sig_size"), Ghdl_Ptr_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Array); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_array"), - Ghdl_Rtin_Subtype_Array); - end; - - -- type record. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Nbrel, - Get_Identifier ("nbrel"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Elements, - Get_Identifier ("elements"), Ghdl_Rti_Arr_Acc); - Finish_Record_Type (Constr, Ghdl_Rtin_Type_Record); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_record"), - Ghdl_Rtin_Type_Record); - end; - - -- record element. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Element_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Element_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Element_Type, - Get_Identifier ("eltype"), Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Element_Valoff, - Get_Identifier ("val_off"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Element_Sigoff, - Get_Identifier ("sig_off"), Ghdl_Index_Type); - Finish_Record_Type (Constr, Ghdl_Rtin_Element); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_element"), - Ghdl_Rtin_Element); - end; - - -- Object. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Object_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Object_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Object_Loc, - Get_Identifier ("loc"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Object_Type, - Get_Identifier ("obj_type"), Ghdl_Rti_Access); - Finish_Record_Type (Constr, Ghdl_Rtin_Object); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_object"), - Ghdl_Rtin_Object); - end; - - -- Instance. - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Instance_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Instance_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Instance_Loc, - Get_Identifier ("loc"), Ghdl_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Instance_Parent, - Wki_Parent, Ghdl_Rti_Access); - New_Record_Field (Constr, Ghdl_Rtin_Instance_Type, - Get_Identifier ("instance"), Ghdl_Rti_Access); - Finish_Record_Type (Constr, Ghdl_Rtin_Instance); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_instance"), - Ghdl_Rtin_Instance); - end; - - -- Component - declare - Constr : O_Element_List; - begin - Start_Record_Type (Constr); - New_Record_Field (Constr, Ghdl_Rtin_Component_Common, - Get_Identifier ("common"), Ghdl_Rti_Common); - New_Record_Field (Constr, Ghdl_Rtin_Component_Name, - Get_Identifier ("name"), Char_Ptr_Type); - New_Record_Field (Constr, Ghdl_Rtin_Component_Nbr_Child, - Get_Identifier ("nbr_child"), Ghdl_Index_Type); - New_Record_Field (Constr, Ghdl_Rtin_Component_Children, - Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); - Finish_Record_Type (Constr, Ghdl_Rtin_Component); - New_Type_Decl (Get_Identifier ("__ghdl_rtin_component"), - Ghdl_Rtin_Component); - end; - - end Rti_Initialize; - - type Rti_Array is array (1 .. 8) of O_Dnode; - type Rti_Array_List; - type Rti_Array_List_Acc is access Rti_Array_List; - type Rti_Array_List is record - Rtis : Rti_Array; - Next : Rti_Array_List_Acc; - end record; - - type Rti_Block is record - Depth : Rti_Depth_Type; - Nbr : Integer; - List : Rti_Array_List; - Last_List : Rti_Array_List_Acc; - Last_Nbr : Integer; - end record; - - Cur_Block : Rti_Block := (Depth => 0, - Nbr => 0, - List => (Rtis => (others => O_Dnode_Null), - Next => null), - Last_List => null, - Last_Nbr => 0); - - Free_List : Rti_Array_List_Acc := null; - - procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True) - is - Ndepth : Rti_Depth_Type; - begin - if Deeper then - Ndepth := Cur_Block.Depth + 1; - else - Ndepth := Cur_Block.Depth; - end if; - Prev := Cur_Block; - Cur_Block := (Depth => Ndepth, - Nbr => 0, - List => (Rtis => (others => O_Dnode_Null), - Next => null), - Last_List => null, - Last_Nbr => 0); - end Push_Rti_Node; - - procedure Add_Rti_Node (Node : O_Dnode) - is - begin - if Node = O_Dnode_Null then - -- FIXME: temporary for not yet handled types. - return; - end if; - if Cur_Block.Last_Nbr = Rti_Array'Last then - declare - N : Rti_Array_List_Acc; - begin - if Free_List = null then - N := new Rti_Array_List; - else - N := Free_List; - Free_List := N.Next; - end if; - N.Next := null; - if Cur_Block.Last_List = null then - Cur_Block.List.Next := N; - else - Cur_Block.Last_List.Next := N; - end if; - Cur_Block.Last_List := N; - end; - Cur_Block.Last_Nbr := 1; - else - Cur_Block.Last_Nbr := Cur_Block.Last_Nbr + 1; - end if; - if Cur_Block.Last_List = null then - Cur_Block.List.Rtis (Cur_Block.Last_Nbr) := Node; - else - Cur_Block.Last_List.Rtis (Cur_Block.Last_Nbr) := Node; - end if; - Cur_Block.Nbr := Cur_Block.Nbr + 1; - end Add_Rti_Node; - - function Generate_Rti_Array (Id : O_Ident) return O_Dnode - is - Arr_Type : O_Tnode; - List : O_Array_Aggr_List; - L : Rti_Array_List_Acc; - Nbr : Integer; - Val : O_Cnode; - Res : O_Dnode; - begin - Arr_Type := New_Constrained_Array_Type - (Ghdl_Rti_Array, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Cur_Block.Nbr + 1))); - New_Const_Decl (Res, Id, O_Storage_Private, Arr_Type); - Start_Const_Value (Res); - Start_Array_Aggr (List, Arr_Type); - Nbr := Cur_Block.Nbr; - for I in Cur_Block.List.Rtis'Range loop - exit when I > Nbr; - New_Array_Aggr_El - (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I), - Ghdl_Rti_Access)); - end loop; - L := Cur_Block.List.Next; - while L /= null loop - Nbr := Nbr - Cur_Block.List.Rtis'Length; - for I in L.Rtis'Range loop - exit when I > Nbr; - New_Array_Aggr_El - (List, New_Global_Unchecked_Address (L.Rtis (I), - Ghdl_Rti_Access)); - end loop; - L := L.Next; - end loop; - New_Array_Aggr_El (List, New_Null_Access (Ghdl_Rti_Access)); - Finish_Array_Aggr (List, Val); - Finish_Const_Value (Res, Val); - return Res; - end Generate_Rti_Array; - - procedure Pop_Rti_Node (Prev : Rti_Block) - is - L : Rti_Array_List_Acc; - begin - L := Cur_Block.List.Next; - if L /= null then - Cur_Block.Last_List.Next := Free_List; - Free_List := Cur_Block.List.Next; - Cur_Block.List.Next := null; - end if; - Cur_Block := Prev; - end Pop_Rti_Node; - - function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type - is - begin - if Var = Null_Var or else Is_Var_Field (Var) then - return Cur_Block.Depth; - else - return 0; - end if; - end Get_Depth_From_Var; - - function Generate_Common - (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0) - return O_Cnode - is - List : O_Record_Aggr_List; - Res : O_Cnode; - Val : Unsigned_64; - begin - Start_Record_Aggr (List, Ghdl_Rti_Common); - New_Record_Aggr_El (List, Kind); - Val := Unsigned_64 (Get_Depth_From_Var (Var)); - New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, Val)); - New_Record_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); - New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, 0)); - Finish_Record_Aggr (List, Res); - return Res; - end Generate_Common; - - -- Same as Generat_Common but for types. - function Generate_Common_Type (Kind : O_Cnode; - Depth : Rti_Depth_Type; - Max_Depth : Rti_Depth_Type; - Mode : Natural := 0) - return O_Cnode - is - List : O_Record_Aggr_List; - Res : O_Cnode; - begin - Start_Record_Aggr (List, Ghdl_Rti_Common); - New_Record_Aggr_El (List, Kind); - New_Record_Aggr_El - (List, - New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Depth))); - New_Record_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); - New_Record_Aggr_El - (List, - New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Max_Depth))); - Finish_Record_Aggr (List, Res); - return Res; - end Generate_Common_Type; - - function Generate_Name (Node : Iir) return O_Dnode - is - use Name_Table; - Id : Name_Id; - begin - Id := Get_Identifier (Node); - if Is_Character (Id) then - Name_Buffer (1) := '''; - Name_Buffer (2) := Get_Character (Id); - Name_Buffer (3) := '''; - Name_Length := 3; - else - Image (Id); - end if; - return Create_String (Name_Buffer (1 .. Name_Length), - Create_Identifier ("RTISTR")); - end Generate_Name; - - function Get_Null_Loc return O_Cnode is - begin - return New_Null_Access (Ghdl_Ptr_Type); - end Get_Null_Loc; - - function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode - is - begin - if Is_Var_Field (Var) then - return Get_Var_Offset (Var, Ghdl_Ptr_Type); - else - return New_Global_Unchecked_Address (Get_Var_Label (Var), - Ghdl_Ptr_Type); - end if; - end Var_Acc_To_Loc; - - -- Generate a name constant for the name of type definition DEF. - -- If DEF is an anonymous subtype, returns O_LNODE_NULL. - -- Use function NEW_NAME_ADDRESS (defined below) to convert the - -- result into an address expression. - function Generate_Type_Name (Def : Iir) return O_Dnode - is - Decl : Iir; - begin - Decl := Get_Type_Declarator (Def); - if Decl /= Null_Iir then - return Generate_Name (Decl); - else - return O_Dnode_Null; - end if; - end Generate_Type_Name; - - -- Convert a name constant NAME into an address. - -- If NAME is O_LNODE_NULL, return a null address. - -- To be used with GENERATE_TYPE_NAME. - function New_Name_Address (Name : O_Dnode) return O_Cnode - is - begin - if Name = O_Dnode_Null then - return New_Null_Access (Char_Ptr_Type); - else - return New_Global_Unchecked_Address (Name, Char_Ptr_Type); - end if; - end New_Name_Address; - - function New_Rti_Address (Rti : O_Dnode) return O_Cnode is - begin - return New_Global_Unchecked_Address (Rti, Ghdl_Rti_Access); - end New_Rti_Address; - - -- Declare the RTI constant for type definition attached to INFO. - -- The only feature is not to declare it if it was already declared. - -- (due to an incomplete type declaration). - procedure Generate_Type_Rti (Info : Type_Info_Acc; Rti_Type : O_Tnode) - is - begin - if Info.Type_Rti = O_Dnode_Null then - New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), - Global_Storage, Rti_Type); - end if; - end Generate_Type_Rti; - - function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) - return O_Dnode; - - procedure Generate_Enumeration_Type_Definition (Atype : Iir) - is - Info : constant Type_Info_Acc := Get_Info (Atype); - Val : O_Cnode; - begin - Generate_Type_Rti (Info, Ghdl_Rtin_Type_Enum); - Info.T.Rti_Max_Depth := 0; - - if Global_Storage = O_Storage_External then - return; - end if; - - declare - Lit_List : constant Iir_List := - Get_Enumeration_Literal_List (Atype); - Nbr_Lit : constant Integer := Get_Nbr_Elements (Lit_List); - Lit : Iir; - - type Dnode_Array is array (Natural range <>) of O_Dnode; - Name_Lits : Dnode_Array (0 .. Nbr_Lit - 1); - Mark : Id_Mark_Type; - Name_Arr_Type : O_Tnode; - Name_Arr : O_Dnode; - - Arr_Aggr : O_Array_Aggr_List; - Rec_Aggr : O_Record_Aggr_List; - Kind : O_Cnode; - Name : O_Dnode; - begin - -- Generate name for each literal. - for I in Name_Lits'Range loop - Lit := Get_Nth_Element (Lit_List, I); - Push_Identifier_Prefix (Mark, Get_Identifier (Lit)); - Name_Lits (I) := Generate_Name (Lit); - Pop_Identifier_Prefix (Mark); - end loop; - - -- Generate array of names. - Name_Arr_Type := New_Constrained_Array_Type - (Char_Ptr_Array_Type, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Nbr_Lit))); - New_Const_Decl (Name_Arr, Create_Identifier ("RTINAMES"), - O_Storage_Private, Name_Arr_Type); - Start_Const_Value (Name_Arr); - Start_Array_Aggr (Arr_Aggr, Name_Arr_Type); - for I in Name_Lits'Range loop - New_Array_Aggr_El - (Arr_Aggr, New_Global_Address (Name_Lits (I), Char_Ptr_Type)); - end loop; - Finish_Array_Aggr (Arr_Aggr, Val); - Finish_Const_Value (Name_Arr, Val); - - Name := Generate_Type_Name (Atype); - - Start_Const_Value (Info.Type_Rti); - case Info.Type_Mode is - when Type_Mode_B1 => - Kind := Ghdl_Rtik_Type_B1; - when Type_Mode_E8 => - Kind := Ghdl_Rtik_Type_E8; - when Type_Mode_E32 => - Kind := Ghdl_Rtik_Type_E32; - when others => - raise Internal_Error; - end case; - Start_Record_Aggr (Rec_Aggr, Ghdl_Rtin_Type_Enum); - New_Record_Aggr_El (Rec_Aggr, Generate_Common_Type (Kind, 0, 0)); - New_Record_Aggr_El (Rec_Aggr, New_Name_Address (Name)); - New_Record_Aggr_El - (Rec_Aggr, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Nbr_Lit))); - New_Record_Aggr_El - (Rec_Aggr, - New_Global_Address (Name_Arr, Char_Ptr_Array_Ptr_Type)); - Finish_Record_Aggr (Rec_Aggr, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end; - end Generate_Enumeration_Type_Definition; - - procedure Generate_Scalar_Type_Definition (Atype : Iir; Name : O_Dnode) - is - Info : Type_Info_Acc; - Kind : O_Cnode; - Val : O_Cnode; - List : O_Record_Aggr_List; - begin - Info := Get_Info (Atype); - - Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); - Info.T.Rti_Max_Depth := 0; - - if Global_Storage = O_Storage_External then - return; - end if; - - Start_Const_Value (Info.Type_Rti); - case Info.Type_Mode is - when Type_Mode_I32 => - Kind := Ghdl_Rtik_Type_I32; - when Type_Mode_I64 => - Kind := Ghdl_Rtik_Type_I64; - when Type_Mode_F64 => - Kind := Ghdl_Rtik_Type_F64; - when Type_Mode_P64 => - Kind := Ghdl_Rtik_Type_P64; - when others => - Error_Kind ("generate_scalar_type_definition", Atype); - end case; - Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); - New_Record_Aggr_El (List, Generate_Common_Type (Kind, 0, 0)); - New_Record_Aggr_El (List, New_Name_Address (Name)); - Finish_Record_Aggr (List, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end Generate_Scalar_Type_Definition; - - procedure Generate_Unit_Declaration (Unit : Iir_Unit_Declaration) - is - Name : O_Dnode; - Mark : Id_Mark_Type; - Aggr : O_Record_Aggr_List; - Val : O_Cnode; - Const : O_Dnode; - Info : constant Object_Info_Acc := Get_Info (Unit); - Rti_Type : O_Tnode; - Rtik : O_Cnode; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Unit)); - Name := Generate_Name (Unit); - if Info /= null then - -- Non-static units. The only possibility is a unit of - -- std.standard.time. - Rti_Type := Ghdl_Rtin_Unitptr; - Rtik := Ghdl_Rtik_Unitptr; - else - Rti_Type := Ghdl_Rtin_Unit64; - Rtik := Ghdl_Rtik_Unit64; - end if; - New_Const_Decl (Const, Create_Identifier ("RTI"), - Global_Storage, Rti_Type); - Start_Const_Value (Const); - Start_Record_Aggr (Aggr, Rti_Type); - New_Record_Aggr_El (Aggr, Generate_Common (Rtik)); - New_Record_Aggr_El (Aggr, New_Name_Address (Name)); - if Info /= null then - -- Handle non-static units. The only possibility is a unit of - -- std.standard.time. - Val := New_Global_Unchecked_Address - (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type); - else - Val := Chap7.Translate_Numeric_Literal (Unit, Ghdl_I64_Type); - end if; - New_Record_Aggr_El (Aggr, Val); - Finish_Record_Aggr (Aggr, Val); - Finish_Const_Value (Const, Val); - Add_Rti_Node (Const); - Pop_Identifier_Prefix (Mark); - end Generate_Unit_Declaration; - - procedure Generate_Physical_Type_Definition (Atype : Iir; Name : O_Dnode) - is - Info : Type_Info_Acc; - Val : O_Cnode; - List : O_Record_Aggr_List; - Prev : Rti_Block; - Unit : Iir_Unit_Declaration; - Nbr_Units : Integer; - Unit_Arr : O_Dnode; - Rti_Kind : O_Cnode; - begin - Info := Get_Info (Atype); - - Generate_Type_Rti (Info, Ghdl_Rtin_Type_Physical); - - if Global_Storage = O_Storage_External then - return; - end if; - - Push_Rti_Node (Prev, False); - Unit := Get_Unit_Chain (Atype); - Nbr_Units := 0; - while Unit /= Null_Iir loop - Generate_Unit_Declaration (Unit); - Nbr_Units := Nbr_Units + 1; - Unit := Get_Chain (Unit); - end loop; - Unit_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); - Pop_Rti_Node (Prev); - - Start_Const_Value (Info.Type_Rti); - Start_Record_Aggr (List, Ghdl_Rtin_Type_Physical); - case Info.Type_Mode is - when Type_Mode_P64 => - Rti_Kind := Ghdl_Rtik_Type_P64; - when Type_Mode_P32 => - Rti_Kind := Ghdl_Rtik_Type_P32; - when others => - raise Internal_Error; - end case; - New_Record_Aggr_El (List, Generate_Common_Type (Rti_Kind, 0, 0, 0)); - New_Record_Aggr_El (List, New_Name_Address (Name)); - New_Record_Aggr_El - (List, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Nbr_Units))); - New_Record_Aggr_El - (List, New_Global_Address (Unit_Arr, Ghdl_Rti_Arr_Acc)); - Finish_Record_Aggr (List, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end Generate_Physical_Type_Definition; - - procedure Generate_Scalar_Subtype_Definition (Atype : Iir) - is - Base_Type : Iir; - Base_Info : Type_Info_Acc; - Info : Type_Info_Acc; - Aggr : O_Record_Aggr_List; - Val : O_Cnode; - Name : O_Dnode; - begin - Info := Get_Info (Atype); - - if Global_Storage = O_Storage_External then - Name := O_Dnode_Null; - else - Name := Generate_Type_Name (Atype); - end if; - - -- Generate base type definition, if necessary. - -- (do it even in packages). - Base_Type := Get_Base_Type (Atype); - Base_Info := Get_Info (Base_Type); - if Base_Info.Type_Rti = O_Dnode_Null then - declare - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, "BT"); - if Get_Kind (Base_Type) = Iir_Kind_Physical_Type_Definition then - Generate_Physical_Type_Definition (Base_Type, Name); - else - Generate_Scalar_Type_Definition (Base_Type, Name); - end if; - Pop_Identifier_Prefix (Mark); - end; - end if; - - Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Scalar); - Info.T.Rti_Max_Depth := Get_Depth_From_Var (Info.T.Range_Var); - if Global_Storage = O_Storage_External then - return; - end if; - - Start_Const_Value (Info.Type_Rti); - Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Scalar); - New_Record_Aggr_El - (Aggr, Generate_Common_Type (Ghdl_Rtik_Subtype_Scalar, - Info.T.Rti_Max_Depth, - Info.T.Rti_Max_Depth)); - - New_Record_Aggr_El (Aggr, New_Name_Address (Name)); - New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); - New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Info.T.Range_Var)); - Finish_Record_Aggr (Aggr, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end Generate_Scalar_Subtype_Definition; - - procedure Generate_Fileacc_Type_Definition (Atype : Iir) - is - Info : Type_Info_Acc; - Kind : O_Cnode; - Val : O_Cnode; - List : O_Record_Aggr_List; - Name : O_Dnode; - Base : O_Dnode; - Base_Type : Iir; - begin - Info := Get_Info (Atype); - - Generate_Type_Rti (Info, Ghdl_Rtin_Type_Fileacc); - - if Global_Storage = O_Storage_External then - return; - end if; - - case Get_Kind (Atype) is - when Iir_Kind_Access_Type_Definition => - declare - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, "AT"); - Base := Generate_Type_Definition - (Get_Designated_Type (Atype)); - Pop_Identifier_Prefix (Mark); - end; - if Get_Kind (Atype) = Iir_Kind_Access_Subtype_Definition then - Kind := Ghdl_Rtik_Subtype_Access; - else - Kind := Ghdl_Rtik_Type_Access; - end if; - -- Don't bother with designated type. This at least avoid - -- loops. - Base_Type := Null_Iir; - when Iir_Kind_File_Type_Definition => - Base_Type := Get_Type (Get_File_Type_Mark (Atype)); - Base := Generate_Type_Definition (Base_Type); - Kind := Ghdl_Rtik_Type_File; - when Iir_Kind_Record_Subtype_Definition => - Base_Type := Get_Base_Type (Atype); - Base := Get_Info (Base_Type).Type_Rti; - Kind := Ghdl_Rtik_Subtype_Record; - when Iir_Kind_Access_Subtype_Definition => - Base_Type := Get_Base_Type (Atype); - Base := Get_Info (Base_Type).Type_Rti; - Kind := Ghdl_Rtik_Subtype_Access; - when others => - Error_Kind ("rti.generate_fileacc_type_definition", Atype); - end case; - if Base_Type = Null_Iir then - Info.T.Rti_Max_Depth := 0; - else - Info.T.Rti_Max_Depth := Get_Info (Base_Type).T.Rti_Max_Depth; - end if; - Name := Generate_Type_Name (Atype); - - Start_Const_Value (Info.Type_Rti); - Start_Record_Aggr (List, Ghdl_Rtin_Type_Fileacc); - New_Record_Aggr_El - (List, Generate_Common_Type (Kind, 0, Info.T.Rti_Max_Depth)); - New_Record_Aggr_El (List, New_Name_Address (Name)); - New_Record_Aggr_El (List, New_Rti_Address (Base)); - Finish_Record_Aggr (List, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end Generate_Fileacc_Type_Definition; - - procedure Generate_Array_Type_Indexes - (Atype : Iir; Res : out O_Dnode; Max_Depth : in out Rti_Depth_Type) - is - List : constant Iir_List := Get_Index_Subtype_List (Atype); - Nbr_Indexes : constant Natural := Get_Nbr_Elements (List); - Index : Iir; - Tmp : O_Dnode; - pragma Unreferenced (Tmp); - Arr_Type : O_Tnode; - Arr_Aggr : O_Array_Aggr_List; - Val : O_Cnode; - Mark : Id_Mark_Type; - begin - -- Translate each index. - for I in 1 .. Nbr_Indexes loop - Index := Get_Index_Type (List, I - 1); - Push_Identifier_Prefix (Mark, "DIM", Iir_Int32 (I)); - Tmp := Generate_Type_Definition (Index); - Max_Depth := Rti_Depth_Type'Max (Max_Depth, - Get_Info (Index).T.Rti_Max_Depth); - Pop_Identifier_Prefix (Mark); - end loop; - - -- Generate array of index. - Arr_Type := New_Constrained_Array_Type - (Ghdl_Rti_Array, - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Indexes))); - New_Const_Decl (Res, Create_Identifier ("RTIINDEXES"), - Global_Storage, Arr_Type); - Start_Const_Value (Res); - - Start_Array_Aggr (Arr_Aggr, Arr_Type); - for I in 1 .. Nbr_Indexes loop - Index := Get_Index_Type (List, I - 1); - New_Array_Aggr_El - (Arr_Aggr, New_Rti_Address (Generate_Type_Definition (Index))); - end loop; - Finish_Array_Aggr (Arr_Aggr, Val); - Finish_Const_Value (Res, Val); - end Generate_Array_Type_Indexes; - - function Type_To_Mode (Atype : Iir) return Natural is - Res : Natural := 0; - begin - if Is_Complex_Type (Get_Info (Atype)) then - Res := Res + 1; - end if; - if Is_Anonymous_Type_Definition (Atype) - or else (Get_Kind (Get_Type_Declarator (Atype)) - = Iir_Kind_Anonymous_Type_Declaration) - then - Res := Res + 2; - end if; - return Res; - end Type_To_Mode; - - procedure Generate_Array_Type_Definition - (Atype : Iir_Array_Type_Definition) - is - Info : Type_Info_Acc; - Aggr : O_Record_Aggr_List; - Val : O_Cnode; - List : Iir_List; - Arr : O_Dnode; - Element : Iir; - Name : O_Dnode; - El_Info : Type_Info_Acc; - Max_Depth : Rti_Depth_Type; - begin - Info := Get_Info (Atype); - - Generate_Type_Rti (Info, Ghdl_Rtin_Type_Array); - - if Global_Storage = O_Storage_External then - return; - end if; - - Name := Generate_Type_Name (Atype); - Element := Get_Element_Subtype (Atype); - El_Info := Get_Info (Element); - if El_Info.Type_Rti = O_Dnode_Null then - declare - Mark : Id_Mark_Type; - El_Rti : O_Dnode; - pragma Unreferenced (El_Rti); - begin - Push_Identifier_Prefix (Mark, "EL"); - El_Rti := Generate_Type_Definition (Element); - Pop_Identifier_Prefix (Mark); - end; - end if; - Max_Depth := El_Info.T.Rti_Max_Depth; - - -- Translate each index. - Generate_Array_Type_Indexes (Atype, Arr, Max_Depth); - Info.T.Rti_Max_Depth := Max_Depth; - List := Get_Index_Subtype_List (Atype); - - -- Generate node. - Start_Const_Value (Info.Type_Rti); - Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Array); - New_Record_Aggr_El - (Aggr, - Generate_Common_Type - (Ghdl_Rtik_Type_Array, 0, Max_Depth, Type_To_Mode (Atype))); - New_Record_Aggr_El (Aggr, New_Name_Address (Name)); - New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti)); - New_Record_Aggr_El - (Aggr, - New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Get_Nbr_Elements (List)))); - New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); - Finish_Record_Aggr (Aggr, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end Generate_Array_Type_Definition; - - procedure Generate_Array_Subtype_Definition - (Atype : Iir_Array_Subtype_Definition) - is - Base_Type : Iir; - Base_Info : Type_Info_Acc; - Info : Type_Info_Acc; - Aggr : O_Record_Aggr_List; - Val : O_Cnode; - Base_Rti : O_Dnode; - pragma Unreferenced (Base_Rti); - Bounds : Var_Type; - Name : O_Dnode; - Kind : O_Cnode; - Mark : Id_Mark_Type; - Depth : Rti_Depth_Type; - begin - -- FIXME: temporary work-around - if Get_Constraint_State (Atype) /= Fully_Constrained then - return; - end if; - - Info := Get_Info (Atype); - - Base_Type := Get_Base_Type (Atype); - Base_Info := Get_Info (Base_Type); - if Base_Info.Type_Rti = O_Dnode_Null then - Push_Identifier_Prefix (Mark, "BT"); - Base_Rti := Generate_Type_Definition (Base_Type); - Pop_Identifier_Prefix (Mark); - end if; - - Bounds := Info.T.Array_Bounds; - Depth := Get_Depth_From_Var (Bounds); - Info.T.Rti_Max_Depth := - Rti_Depth_Type'Max (Depth, Base_Info.T.Rti_Max_Depth); - - -- Generate node. - Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Array); - - if Global_Storage = O_Storage_External then - return; - end if; - - Name := Generate_Type_Name (Atype); - - Start_Const_Value (Info.Type_Rti); - Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Array); - case Info.Type_Mode is - when Type_Mode_Array => - Kind := Ghdl_Rtik_Subtype_Array; - when Type_Mode_Fat_Array => - Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; - when others => - Error_Kind ("generate_array_subtype_definition", Atype); - end case; - New_Record_Aggr_El - (Aggr, - Generate_Common_Type - (Kind, Depth, Info.T.Rti_Max_Depth, Type_To_Mode (Atype))); - New_Record_Aggr_El (Aggr, New_Name_Address (Name)); - New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); - if Bounds = Null_Var then - Val := Get_Null_Loc; - else - Val := Var_Acc_To_Loc (Bounds); - end if; - New_Record_Aggr_El (Aggr, Val); - for I in Mode_Value .. Mode_Signal loop - case Info.Type_Mode is - when Type_Mode_Array => - Val := Get_Null_Loc; - if Info.Ortho_Type (I) /= O_Tnode_Null then - if Is_Complex_Type (Info) then - if Info.C (I).Size_Var /= Null_Var then - Val := Var_Acc_To_Loc (Info.C (I).Size_Var); - end if; - else - Val := New_Sizeof (Info.Ortho_Type (I), - Ghdl_Ptr_Type); - end if; - end if; - when Type_Mode_Fat_Array => - Val := Get_Null_Loc; - when others => - Error_Kind ("generate_array_subtype_definition", Atype); - end case; - New_Record_Aggr_El (Aggr, Val); - end loop; - - Finish_Record_Aggr (Aggr, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end Generate_Array_Subtype_Definition; - - procedure Generate_Record_Type_Definition (Atype : Iir) - is - El_List : Iir_List; - El : Iir; - Prev : Rti_Block; - El_Arr : O_Dnode; - Res : O_Cnode; - Info : constant Type_Info_Acc := Get_Info (Atype); - Max_Depth : Rti_Depth_Type; - begin - Generate_Type_Rti (Info, Ghdl_Rtin_Type_Record); - if Global_Storage = O_Storage_External then - return; - end if; - - El_List := Get_Elements_Declaration_List (Atype); - Max_Depth := 0; - - -- Generate elements. - Push_Rti_Node (Prev, False); - for I in Natural loop - El := Get_Nth_Element (El_List, I); - exit when El = Null_Iir; - declare - Type_Rti : O_Dnode; - El_Name : O_Dnode; - El_Type : constant Iir := Get_Type (El); - Aggr : O_Record_Aggr_List; - Field_Info : constant Field_Info_Acc := Get_Info (El); - Val : O_Cnode; - El_Const : O_Dnode; - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (El)); - - Type_Rti := Generate_Type_Definition (El_Type); - Max_Depth := - Rti_Depth_Type'Max (Max_Depth, - Get_Info (El_Type).T.Rti_Max_Depth); - - El_Name := Generate_Name (El); - New_Const_Decl (El_Const, Create_Identifier ("RTIEL"), - Global_Storage, Ghdl_Rtin_Element); - Start_Const_Value (El_Const); - Start_Record_Aggr (Aggr, Ghdl_Rtin_Element); - New_Record_Aggr_El (Aggr, - Generate_Common (Ghdl_Rtik_Element)); - New_Record_Aggr_El (Aggr, New_Name_Address (El_Name)); - New_Record_Aggr_El (Aggr, New_Rti_Address (Type_Rti)); - for I in Object_Kind_Type loop - if Field_Info.Field_Node (I) /= O_Fnode_Null then - Val := New_Offsetof (Info.Ortho_Type (I), - Field_Info.Field_Node (I), - Ghdl_Index_Type); - else - Val := Ghdl_Index_0; - end if; - New_Record_Aggr_El (Aggr, Val); - end loop; - Finish_Record_Aggr (Aggr, Val); - Finish_Const_Value (El_Const, Val); - Add_Rti_Node (El_Const); - - Pop_Identifier_Prefix (Mark); - end; - end loop; - El_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); - Pop_Rti_Node (Prev); - - Info.T.Rti_Max_Depth := Max_Depth; - -- Generate record. - declare - Aggr : O_Record_Aggr_List; - Name : O_Dnode; - begin - Name := Generate_Type_Name (Atype); - - Start_Const_Value (Info.Type_Rti); - Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record); - New_Record_Aggr_El - (Aggr, - Generate_Common_Type (Ghdl_Rtik_Type_Record, 0, Max_Depth, - Type_To_Mode (Atype))); - New_Record_Aggr_El (Aggr, New_Name_Address (Name)); - New_Record_Aggr_El - (Aggr, New_Unsigned_Literal - (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List)))); - New_Record_Aggr_El (Aggr, - New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc)); - Finish_Record_Aggr (Aggr, Res); - Finish_Const_Value (Info.Type_Rti, Res); - end; - end Generate_Record_Type_Definition; - - procedure Generate_Protected_Type_Declaration (Atype : Iir) - is - Info : Type_Info_Acc; - Name : O_Dnode; - Val : O_Cnode; - List : O_Record_Aggr_List; - begin - Info := Get_Info (Atype); - Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); - if Global_Storage = O_Storage_External then - return; - end if; - - Name := Generate_Type_Name (Atype); - Start_Const_Value (Info.Type_Rti); - Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); - New_Record_Aggr_El - (List, - Generate_Common_Type (Ghdl_Rtik_Type_Protected, 0, 0, - Type_To_Mode (Atype))); - New_Record_Aggr_El (List, New_Name_Address (Name)); - Finish_Record_Aggr (List, Val); - Finish_Const_Value (Info.Type_Rti, Val); - end Generate_Protected_Type_Declaration; - - -- If FORCE is true, force the creation of the type RTI. - -- Otherwise, only the declaration (and not the definition) may have - -- been created. - function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) - return O_Dnode - is - Info : constant Type_Info_Acc := Get_Info (Atype); - begin - if not Force and then Info.Type_Rti /= O_Dnode_Null then - return Info.Type_Rti; - end if; - case Get_Kind (Atype) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Floating_Type_Definition - | Iir_Kind_Physical_Type_Definition => - raise Internal_Error; - when Iir_Kind_Enumeration_Type_Definition => - Generate_Enumeration_Type_Definition (Atype); - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - Generate_Scalar_Subtype_Definition (Atype); - when Iir_Kind_Array_Type_Definition => - Generate_Array_Type_Definition (Atype); - when Iir_Kind_Array_Subtype_Definition => - Generate_Array_Subtype_Definition (Atype); - when Iir_Kind_Access_Type_Definition - | Iir_Kind_File_Type_Definition => - Generate_Fileacc_Type_Definition (Atype); - when Iir_Kind_Record_Subtype_Definition - | Iir_Kind_Access_Subtype_Definition => - -- FIXME: No separate infos (yet). - null; - when Iir_Kind_Record_Type_Definition => - Generate_Record_Type_Definition (Atype); - when Iir_Kind_Protected_Type_Declaration => - Generate_Protected_Type_Declaration (Atype); - when others => - Error_Kind ("rti.generate_type_definition", Atype); - return O_Dnode_Null; - end case; - return Info.Type_Rti; - end Generate_Type_Definition; - - function Generate_Incomplete_Type_Definition (Def : Iir) - return O_Dnode - is - Ndef : constant Iir := Get_Type (Get_Type_Declarator (Def)); - Info : constant Type_Info_Acc := Get_Info (Ndef); - Rti_Type : O_Tnode; - begin - case Get_Kind (Ndef) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Floating_Type_Definition => - Rti_Type := Ghdl_Rtin_Type_Scalar; - when Iir_Kind_Physical_Type_Definition => - Rti_Type := Ghdl_Rtin_Type_Physical; - when Iir_Kind_Enumeration_Type_Definition => - Rti_Type := Ghdl_Rtin_Type_Enum; - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - Rti_Type := Ghdl_Rtin_Subtype_Scalar; - when Iir_Kind_Array_Type_Definition => - Rti_Type := Ghdl_Rtin_Type_Array; - when Iir_Kind_Array_Subtype_Definition => - Rti_Type := Ghdl_Rtin_Subtype_Array; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_File_Type_Definition => - Rti_Type := Ghdl_Rtin_Type_Fileacc; - when Iir_Kind_Record_Type_Definition => - Rti_Type := Ghdl_Rtin_Type_Record; - when others => - Error_Kind ("rti.generate_incomplete_type_definition", Ndef); - end case; - New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), - Global_Storage, Rti_Type); - return Info.Type_Rti; - end Generate_Incomplete_Type_Definition; - - function Generate_Type_Decl (Decl : Iir) return O_Dnode - is - Id : constant Name_Id := Get_Identifier (Decl); - Def : constant Iir := Get_Type (Decl); - Rti : O_Dnode; - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Id); - if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then - Rti := Generate_Incomplete_Type_Definition (Def); - else - Rti := Generate_Type_Definition (Def, True); - end if; - Pop_Identifier_Prefix (Mark); - return Rti; - end Generate_Type_Decl; - - procedure Generate_Signal_Rti (Sig : Iir) - is - Info : Object_Info_Acc; - begin - Info := Get_Info (Sig); - New_Const_Decl (Info.Object_Rti, Create_Identifier (Sig, "__RTI"), - Global_Storage, Ghdl_Rtin_Object); - end Generate_Signal_Rti; - - procedure Generate_Object (Decl : Iir; Rti : in out O_Dnode) - is - Decl_Type : Iir; - Type_Info : Type_Info_Acc; - Name : O_Dnode; - Comm : O_Cnode; - Val : O_Cnode; - List : O_Record_Aggr_List; - Info : Ortho_Info_Acc; - Mark : Id_Mark_Type; - Var : Var_Type; - Mode : Natural; - Has_Id : Boolean; - begin - case Get_Kind (Decl) is - when Iir_Kind_Transaction_Attribute - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute => - Has_Id := False; - Push_Identifier_Prefix_Uniq (Mark); - when others => - Has_Id := True; - Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - end case; - - if Rti = O_Dnode_Null then - New_Const_Decl (Rti, Create_Identifier ("RTI"), - Global_Storage, Ghdl_Rtin_Object); - end if; - - if Global_Storage /= O_Storage_External then - Decl_Type := Get_Type (Decl); - Type_Info := Get_Info (Decl_Type); - if Type_Info.Type_Rti = O_Dnode_Null then - declare - Mark : Id_Mark_Type; - Tmp : O_Dnode; - pragma Unreferenced (Tmp); - begin - Push_Identifier_Prefix (Mark, "OT"); - Tmp := Generate_Type_Definition (Decl_Type); - Pop_Identifier_Prefix (Mark); - end; - end if; - - if Has_Id then - Name := Generate_Name (Decl); - else - Name := O_Dnode_Null; - end if; - - Info := Get_Info (Decl); - - Start_Const_Value (Rti); - Start_Record_Aggr (List, Ghdl_Rtin_Object); - Mode := 0; - case Get_Kind (Decl) is - when Iir_Kind_Signal_Declaration => - Comm := Ghdl_Rtik_Signal; - Var := Info.Object_Var; - when Iir_Kind_Interface_Signal_Declaration => - Comm := Ghdl_Rtik_Port; - Var := Info.Object_Var; - Mode := Iir_Mode'Pos (Get_Mode (Decl)); - when Iir_Kind_Constant_Declaration => - Comm := Ghdl_Rtik_Constant; - Var := Info.Object_Var; - when Iir_Kind_Interface_Constant_Declaration => - Comm := Ghdl_Rtik_Generic; - Var := Info.Object_Var; - when Iir_Kind_Variable_Declaration => - Comm := Ghdl_Rtik_Variable; - Var := Info.Object_Var; - when Iir_Kind_Guard_Signal_Declaration => - Comm := Ghdl_Rtik_Guard; - Var := Info.Object_Var; - when Iir_Kind_Iterator_Declaration => - Comm := Ghdl_Rtik_Iterator; - Var := Info.Iterator_Var; - when Iir_Kind_File_Declaration => - Comm := Ghdl_Rtik_File; - Var := Info.Object_Var; - when Iir_Kind_Attribute_Declaration => - Comm := Ghdl_Rtik_Attribute; - Var := Null_Var; - when Iir_Kind_Transaction_Attribute => - Comm := Ghdl_Rtik_Attribute_Transaction; - Var := Info.Object_Var; - when Iir_Kind_Quiet_Attribute => - Comm := Ghdl_Rtik_Attribute_Quiet; - Var := Info.Object_Var; - when Iir_Kind_Stable_Attribute => - Comm := Ghdl_Rtik_Attribute_Stable; - Var := Info.Object_Var; - when Iir_Kind_Object_Alias_Declaration => - Comm := Ghdl_Rtik_Alias; - Var := Info.Alias_Var; - Mode := Object_Kind_Type'Pos (Info.Alias_Kind); - when others => - Error_Kind ("rti.generate_object", Decl); - end case; - case Get_Kind (Decl) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration => - Mode := Mode - + 16 * Iir_Signal_Kind'Pos (Get_Signal_Kind (Decl)); - when others => - null; - end case; - case Get_Kind (Decl) is - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute => - if Get_Has_Active_Flag (Decl) then - Mode := Mode + 64; - end if; - when others => - null; - end case; - New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode)); - New_Record_Aggr_El (List, New_Name_Address (Name)); - if Var = Null_Var then - Val := Get_Null_Loc; - else - Val := Var_Acc_To_Loc (Var); - end if; - New_Record_Aggr_El (List, Val); - New_Record_Aggr_El (List, New_Rti_Address (Type_Info.Type_Rti)); - Finish_Record_Aggr (List, Val); - Finish_Const_Value (Rti, Val); - end if; - Pop_Identifier_Prefix (Mark); - end Generate_Object; - - procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode); - procedure Generate_Declaration_Chain (Chain : Iir); - - procedure Generate_Component_Declaration (Comp : Iir) - is - Prev : Rti_Block; - Name : O_Dnode; - Arr : O_Dnode; - List : O_Record_Aggr_List; - Res : O_Cnode; - Mark : Id_Mark_Type; - Info : Comp_Info_Acc; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Comp)); - Info := Get_Info (Comp); - - New_Const_Decl (Info.Comp_Rti_Const, Create_Identifier ("RTI"), - Global_Storage, Ghdl_Rtin_Component); - - if Global_Storage /= O_Storage_External then - Push_Rti_Node (Prev); - - Generate_Declaration_Chain (Get_Generic_Chain (Comp)); - Generate_Declaration_Chain (Get_Port_Chain (Comp)); - - Name := Generate_Name (Comp); - - Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); - - Start_Const_Value (Info.Comp_Rti_Const); - Start_Record_Aggr (List, Ghdl_Rtin_Component); - New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Component)); - New_Record_Aggr_El (List, - New_Global_Address (Name, Char_Ptr_Type)); - New_Record_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Cur_Block.Nbr))); - New_Record_Aggr_El (List, - New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); - Finish_Record_Aggr (List, Res); - Finish_Const_Value (Info.Comp_Rti_Const, Res); - Pop_Rti_Node (Prev); - end if; - - Pop_Identifier_Prefix (Mark); - Add_Rti_Node (Info.Comp_Rti_Const); - end Generate_Component_Declaration; - - -- Generate RTIs only for types. - procedure Generate_Declaration_Chain_Depleted (Chain : Iir) - is - Decl : Iir; - begin - Decl := Chain; - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Use_Clause => - null; - when Iir_Kind_Type_Declaration => - -- FIXME: physicals ? - if Get_Kind (Get_Type_Definition (Decl)) - = Iir_Kind_Enumeration_Type_Definition - then - Add_Rti_Node (Generate_Type_Decl (Decl)); - end if; - when Iir_Kind_Subtype_Declaration => - -- In a subprogram, a subtype may depends on parameters. - -- Eg: array subtypes. - null; - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Stable_Attribute => - null; - when Iir_Kind_Delayed_Attribute => - -- FIXME: to be added. - null; - when Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Attribute_Declaration => - null; - when Iir_Kind_Component_Declaration => - null; - when Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration - | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - -- FIXME: to be added (for foreign). - null; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - null; - when Iir_Kind_Anonymous_Type_Declaration => - -- Handled in subtype declaration. - null; - when Iir_Kind_Configuration_Specification - | Iir_Kind_Attribute_Specification - | Iir_Kind_Disconnection_Specification => - null; - when Iir_Kind_Protected_Type_Body => - null; - when Iir_Kind_Non_Object_Alias_Declaration => - null; - when Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration => - null; - when others => - Error_Kind ("rti.generate_declaration_chain_depleted", Decl); - end case; - Decl := Get_Chain (Decl); - end loop; - end Generate_Declaration_Chain_Depleted; - - procedure Generate_Subprogram_Body (Bod : Iir) - is - --Decl : Iir; - --Mark : Id_Mark_Type; - begin - --Decl := Get_Subprogram_Specification (Bod); - - --Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - -- Generate RTI only for types. - Generate_Declaration_Chain_Depleted (Get_Declaration_Chain (Bod)); - --Pop_Identifier_Prefix (Mark); - end Generate_Subprogram_Body; - - procedure Generate_Instance (Stmt : Iir; Parent : O_Dnode) - is - Name : O_Dnode; - List : O_Record_Aggr_List; - Val : O_Cnode; - Inst : constant Iir := Get_Instantiated_Unit (Stmt); - Info : constant Block_Info_Acc := Get_Info (Stmt); - begin - Name := Generate_Name (Stmt); - - New_Const_Decl (Info.Block_Rti_Const, Create_Identifier ("RTI"), - Global_Storage, Ghdl_Rtin_Instance); - - Start_Const_Value (Info.Block_Rti_Const); - Start_Record_Aggr (List, Ghdl_Rtin_Instance); - New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance)); - New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); - New_Record_Aggr_El - (List, New_Offsetof (Get_Scope_Type - (Get_Info (Get_Parent (Stmt)).Block_Scope), - Info.Block_Link_Field, - Ghdl_Ptr_Type)); - New_Record_Aggr_El (List, New_Rti_Address (Parent)); - if Is_Component_Instantiation (Stmt) then - Val := New_Rti_Address - (Get_Info (Get_Named_Entity (Inst)).Comp_Rti_Const); - else - declare - Ent : constant Iir := Get_Entity_From_Entity_Aspect (Inst); - begin - Val := New_Rti_Address (Get_Info (Ent).Block_Rti_Const); - end; - end if; - - New_Record_Aggr_El (List, Val); - Finish_Record_Aggr (List, Val); - Finish_Const_Value (Info.Block_Rti_Const, Val); - Add_Rti_Node (Info.Block_Rti_Const); - end Generate_Instance; - - procedure Generate_Psl_Directive (Stmt : Iir) - is - Name : O_Dnode; - List : O_Record_Aggr_List; - - Rti : O_Dnode; - Res : O_Cnode; - Info : constant Psl_Info_Acc := Get_Info (Stmt); - Mark : Id_Mark_Type; - begin - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Name := Generate_Name (Stmt); - - New_Const_Decl (Rti, Create_Identifier ("RTI"), - O_Storage_Public, Ghdl_Rtin_Type_Scalar); - - Start_Const_Value (Rti); - Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); - New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Psl_Assert)); - New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); - Finish_Record_Aggr (List, Res); - Finish_Const_Value (Rti, Res); - Info.Psl_Rti_Const := Rti; - Pop_Identifier_Prefix (Mark); - end Generate_Psl_Directive; - - procedure Generate_Declaration_Chain (Chain : Iir) - is - Decl : Iir; - begin - Decl := Chain; - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Use_Clause => - null; - when Iir_Kind_Anonymous_Type_Declaration => - -- Handled in subtype declaration. - null; - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - Add_Rti_Node (Generate_Type_Decl (Decl)); - when Iir_Kind_Constant_Declaration => - -- Do not generate RTIs for full declarations. - -- (RTI will be generated for the deferred declaration). - if Get_Deferred_Declaration (Decl) = Null_Iir - or else Get_Deferred_Declaration_Flag (Decl) - then - declare - Info : Object_Info_Acc; - begin - Info := Get_Info (Decl); - Generate_Object (Decl, Info.Object_Rti); - Add_Rti_Node (Info.Object_Rti); - end; - end if; - when Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Stable_Attribute => - declare - Info : Object_Info_Acc; - begin - Info := Get_Info (Decl); - Generate_Object (Decl, Info.Object_Rti); - Add_Rti_Node (Info.Object_Rti); - end; - when Iir_Kind_Delayed_Attribute => - -- FIXME: to be added. - null; - when Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Attribute_Declaration => - declare - Rti : O_Dnode := O_Dnode_Null; - begin - Generate_Object (Decl, Rti); - Add_Rti_Node (Rti); - end; - when Iir_Kind_Component_Declaration => - Generate_Component_Declaration (Decl); - when Iir_Kind_Implicit_Function_Declaration - | Iir_Kind_Implicit_Procedure_Declaration - | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - -- FIXME: to be added (for foreign). - null; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - -- Already handled by Translate_Subprogram_Body. - null; - when Iir_Kind_Configuration_Specification - | Iir_Kind_Attribute_Specification - | Iir_Kind_Disconnection_Specification => - null; - when Iir_Kind_Protected_Type_Body => - null; - when Iir_Kind_Non_Object_Alias_Declaration => - null; - when Iir_Kind_Group_Template_Declaration - | Iir_Kind_Group_Declaration => - null; - when others => - Error_Kind ("rti.generate_declaration_chain", Decl); - end case; - Decl := Get_Chain (Decl); - end loop; - end Generate_Declaration_Chain; - - procedure Generate_Concurrent_Statement_Chain - (Chain : Iir; Parent_Rti : O_Dnode) - is - Stmt : Iir; - Mark : Id_Mark_Type; - begin - Stmt := Chain; - while Stmt /= Null_Iir loop - case Get_Kind (Stmt) is - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement => - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Generate_Block (Stmt, Parent_Rti); - Pop_Identifier_Prefix (Mark); - when Iir_Kind_Component_Instantiation_Statement => - Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Generate_Instance (Stmt, Parent_Rti); - Pop_Identifier_Prefix (Mark); - when Iir_Kind_Psl_Default_Clock => - null; - when Iir_Kind_Psl_Declaration => - null; - when Iir_Kind_Psl_Assert_Statement => - Generate_Psl_Directive (Stmt); - when Iir_Kind_Psl_Cover_Statement => - Generate_Psl_Directive (Stmt); - when others => - Error_Kind ("rti.generate_concurrent_statement_chain", Stmt); - end case; - Stmt := Get_Chain (Stmt); - end loop; - end Generate_Concurrent_Statement_Chain; - - procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode) - is - Name : O_Dnode; - Arr : O_Dnode; - List : O_Record_Aggr_List; - - Rti : O_Dnode; - - Kind : O_Cnode; - Res : O_Cnode; - - Prev : Rti_Block; - Info : Ortho_Info_Acc; - - Field_Off : O_Cnode; - Inst : O_Tnode; - begin - -- The type of a generator iterator is elaborated in the parent. - if Get_Kind (Blk) = Iir_Kind_Generate_Statement then - declare - Scheme : Iir; - Iter_Type : Iir; - Type_Info : Type_Info_Acc; - Mark : Id_Mark_Type; - Tmp : O_Dnode; - begin - Scheme := Get_Generation_Scheme (Blk); - if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - Iter_Type := Get_Type (Scheme); - Type_Info := Get_Info (Iter_Type); - if Type_Info.Type_Rti = O_Dnode_Null then - Push_Identifier_Prefix (Mark, "ITERATOR"); - Tmp := Generate_Type_Definition (Iter_Type); - Add_Rti_Node (Tmp); - Pop_Identifier_Prefix (Mark); - end if; - end if; - end; - end if; - - New_Const_Decl (Rti, Create_Identifier ("RTI"), - O_Storage_Public, Ghdl_Rtin_Block); - Push_Rti_Node (Prev); - - Field_Off := O_Cnode_Null; - Inst := O_Tnode_Null; - Info := Get_Info (Blk); - case Get_Kind (Blk) is - when Iir_Kind_Package_Declaration => - Kind := Ghdl_Rtik_Package; - Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - when Iir_Kind_Package_Body => - Kind := Ghdl_Rtik_Package_Body; - -- Required at least for 'image - Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - when Iir_Kind_Architecture_Body => - Kind := Ghdl_Rtik_Architecture; - Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - Generate_Concurrent_Statement_Chain - (Get_Concurrent_Statement_Chain (Blk), Rti); - Inst := Get_Scope_Type (Info.Block_Scope); - Field_Off := New_Offsetof - (Get_Scope_Type (Info.Block_Scope), - Info.Block_Parent_Field, Ghdl_Ptr_Type); - when Iir_Kind_Entity_Declaration => - Kind := Ghdl_Rtik_Entity; - Generate_Declaration_Chain (Get_Generic_Chain (Blk)); - Generate_Declaration_Chain (Get_Port_Chain (Blk)); - Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - Generate_Concurrent_Statement_Chain - (Get_Concurrent_Statement_Chain (Blk), Rti); - Inst := Get_Scope_Type (Info.Block_Scope); - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Kind := Ghdl_Rtik_Process; - Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - Field_Off := - Get_Scope_Offset (Info.Process_Scope, Ghdl_Ptr_Type); - Inst := Get_Scope_Type (Info.Process_Scope); - when Iir_Kind_Block_Statement => - Kind := Ghdl_Rtik_Block; - declare - Guard : constant Iir := Get_Guard_Decl (Blk); - Header : constant Iir := Get_Block_Header (Blk); - Guard_Info : Object_Info_Acc; - begin - if Guard /= Null_Iir then - Guard_Info := Get_Info (Guard); - Generate_Object (Guard, Guard_Info.Object_Rti); - Add_Rti_Node (Guard_Info.Object_Rti); - end if; - if Header /= Null_Iir then - Generate_Declaration_Chain (Get_Generic_Chain (Header)); - Generate_Declaration_Chain (Get_Port_Chain (Header)); - end if; - end; - Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - Generate_Concurrent_Statement_Chain - (Get_Concurrent_Statement_Chain (Blk), Rti); - Field_Off := Get_Scope_Offset (Info.Block_Scope, Ghdl_Ptr_Type); - Inst := Get_Scope_Type (Info.Block_Scope); - when Iir_Kind_Generate_Statement => - declare - Scheme : constant Iir := Get_Generation_Scheme (Blk); - Scheme_Rti : O_Dnode := O_Dnode_Null; - begin - if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - Generate_Object (Scheme, Scheme_Rti); - Add_Rti_Node (Scheme_Rti); - Kind := Ghdl_Rtik_For_Generate; - else - Kind := Ghdl_Rtik_If_Generate; - end if; - end; - Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - Generate_Concurrent_Statement_Chain - (Get_Concurrent_Statement_Chain (Blk), Rti); - Inst := Get_Scope_Type (Info.Block_Scope); - Field_Off := New_Offsetof - (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), - Info.Block_Parent_Field, Ghdl_Ptr_Type); - when others => - Error_Kind ("rti.generate_block", Blk); - end case; - - Name := Generate_Name (Blk); - - Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); - - Start_Const_Value (Rti); - Start_Record_Aggr (List, Ghdl_Rtin_Block); - New_Record_Aggr_El (List, Generate_Common (Kind)); - New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); - if Field_Off = O_Cnode_Null then - Field_Off := Get_Null_Loc; - end if; - New_Record_Aggr_El (List, Field_Off); - if Parent_Rti = O_Dnode_Null then - Res := New_Null_Access (Ghdl_Rti_Access); - else - Res := New_Rti_Address (Parent_Rti); - end if; - New_Record_Aggr_El (List, Res); - if Inst = O_Tnode_Null then - Res := Ghdl_Index_0; - else - Res := New_Sizeof (Inst, Ghdl_Index_Type); - end if; - New_Record_Aggr_El (List, Res); - New_Record_Aggr_El - (List, New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Cur_Block.Nbr))); - New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); - Finish_Record_Aggr (List, Res); - Finish_Const_Value (Rti, Res); - - Pop_Rti_Node (Prev); - - -- Put children in the parent list. - case Get_Kind (Blk) is - when Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement - | Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Add_Rti_Node (Rti); - when others => - null; - end case; - - -- Store the RTI. - case Get_Kind (Blk) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement => - Info.Block_Rti_Const := Rti; - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Info.Process_Rti_Const := Rti; - when Iir_Kind_Package_Declaration => - Info.Package_Rti_Const := Rti; - when Iir_Kind_Package_Body => - -- Replace package declaration RTI with the body one. - Get_Info (Get_Package (Blk)).Package_Rti_Const := Rti; - when others => - Error_Kind ("rti.generate_block", Blk); - end case; - end Generate_Block; - - procedure Generate_Library (Lib : Iir_Library_Declaration; - Public : Boolean) - is - use Name_Table; - Info : Library_Info_Acc; - Id : Name_Id; - Val : O_Cnode; - Aggr : O_Record_Aggr_List; - Name : O_Dnode; - Storage : O_Storage; - begin - Info := Get_Info (Lib); - if Info /= null then - return; - end if; - Info := Add_Info (Lib, Kind_Library); - - if Lib = Libraries.Work_Library then - Id := Libraries.Work_Library_Name; - else - Id := Get_Identifier (Lib); - end if; - - if Public then - Storage := O_Storage_Public; - else - Storage := O_Storage_External; - end if; - - New_Const_Decl (Info.Library_Rti_Const, - Create_Identifier_Without_Prefix (Id, "__RTI"), - Storage, Ghdl_Rtin_Type_Scalar); - - if Public then - Image (Id); - Name := Create_String - (Name_Buffer (1 .. Name_Length), - Create_Identifier_Without_Prefix (Id, "__RTISTR")); - Start_Const_Value (Info.Library_Rti_Const); - Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Scalar); - New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Library)); - New_Record_Aggr_El (Aggr, New_Name_Address (Name)); - Finish_Record_Aggr (Aggr, Val); - Finish_Const_Value (Info.Library_Rti_Const, Val); - end if; - end Generate_Library; - - procedure Generate_Unit (Lib_Unit : Iir) - is - Rti : O_Dnode; - Info : Ortho_Info_Acc; - Mark : Id_Mark_Type; - begin - Info := Get_Info (Lib_Unit); - case Get_Kind (Lib_Unit) is - when Iir_Kind_Configuration_Declaration => - return; - when Iir_Kind_Architecture_Body => - if Info.Block_Rti_Const /= O_Dnode_Null then - return; - end if; - when Iir_Kind_Package_Body => - Push_Identifier_Prefix (Mark, "BODY"); - when others => - null; - end case; - - -- Declare node. - if Global_Storage = O_Storage_External then - New_Const_Decl (Rti, Create_Identifier ("RTI"), - O_Storage_External, Ghdl_Rtin_Block); - case Get_Kind (Lib_Unit) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration => - declare - Prev : Rti_Block; - begin - Push_Rti_Node (Prev); - Generate_Declaration_Chain - (Get_Declaration_Chain (Lib_Unit)); - Pop_Rti_Node (Prev); - end; - when others => - null; - end case; - case Get_Kind (Lib_Unit) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body => - Info.Block_Rti_Const := Rti; - when Iir_Kind_Package_Declaration => - Info.Package_Rti_Const := Rti; - when Iir_Kind_Package_Body => - -- Replace package declaration RTI with the body one. - Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const := Rti; - when others => - null; - end case; - else - case Get_Kind (Lib_Unit) is - when Iir_Kind_Package_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Configuration_Declaration => - declare - Lib : Iir_Library_Declaration; - begin - Lib := Get_Library (Get_Design_File - (Get_Design_Unit (Lib_Unit))); - Generate_Library (Lib, False); - Rti := Get_Info (Lib).Library_Rti_Const; - end; - when Iir_Kind_Package_Body => - Rti := Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const; - when Iir_Kind_Architecture_Body => - Rti := Get_Info (Get_Entity (Lib_Unit)).Block_Rti_Const; - when others => - raise Internal_Error; - end case; - Generate_Block (Lib_Unit, Rti); - end if; - - if Get_Kind (Lib_Unit) = Iir_Kind_Package_Body then - Pop_Identifier_Prefix (Mark); - end if; - end Generate_Unit; - - procedure Generate_Top (Nbr_Pkgs : out Natural) - is - use Configuration; - - Unit : Iir_Design_Unit; - Lib : Iir_Library_Declaration; - Prev : Rti_Block; - begin - Push_Rti_Node (Prev); - - -- Generate RTI for libraries, count number of packages. - Nbr_Pkgs := 1; -- At least std.standard. - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - - -- Generate RTI for the library. - Lib := Get_Library (Get_Design_File (Unit)); - Generate_Library (Lib, True); - - if Get_Kind (Get_Library_Unit (Unit)) - = Iir_Kind_Package_Declaration - then - Nbr_Pkgs := Nbr_Pkgs + 1; - end if; - end loop; - - Pop_Rti_Node (Prev); - end Generate_Top; - - function Get_Context_Rti (Node : Iir) return O_Cnode - is - Node_Info : Ortho_Info_Acc; - - Rti_Const : O_Dnode; - begin - Node_Info := Get_Info (Node); - - case Get_Kind (Node) is - when Iir_Kind_Component_Declaration => - Rti_Const := Node_Info.Comp_Rti_Const; - when Iir_Kind_Component_Instantiation_Statement => - Rti_Const := Node_Info.Block_Rti_Const; - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement => - Rti_Const := Node_Info.Block_Rti_Const; - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body => - Rti_Const := Node_Info.Package_Rti_Const; - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Rti_Const := Node_Info.Process_Rti_Const; - when Iir_Kind_Psl_Assert_Statement - | Iir_Kind_Psl_Cover_Statement => - Rti_Const := Node_Info.Psl_Rti_Const; - when others => - Error_Kind ("get_context_rti", Node); - end case; - return New_Rti_Address (Rti_Const); - end Get_Context_Rti; - - function Get_Context_Addr (Node : Iir) return O_Enode - is - Node_Info : constant Ortho_Info_Acc := Get_Info (Node); - Ref : O_Lnode; - begin - case Get_Kind (Node) is - when Iir_Kind_Component_Declaration => - Ref := Get_Instance_Ref (Node_Info.Comp_Scope); - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement => - Ref := Get_Instance_Ref (Node_Info.Block_Scope); - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body => - return New_Lit (New_Null_Access (Ghdl_Ptr_Type)); - when Iir_Kind_Process_Statement - | Iir_Kind_Sensitized_Process_Statement => - Ref := Get_Instance_Ref (Node_Info.Process_Scope); - when Iir_Kind_Psl_Assert_Statement - | Iir_Kind_Psl_Cover_Statement => - Ref := Get_Instance_Ref (Node_Info.Psl_Scope); - when others => - Error_Kind ("get_context_addr", Node); - end case; - return New_Unchecked_Address (Ref, Ghdl_Ptr_Type); - end Get_Context_Addr; - - procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir) - is - begin - New_Association (Assoc, New_Lit (Get_Context_Rti (Node))); - New_Association (Assoc, Get_Context_Addr (Node)); - end Associate_Rti_Context; - - procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List) is - begin - New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Rti_Access))); - New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); - end Associate_Null_Rti_Context; - end Rtis; - procedure Gen_Filename (Design_File : Iir) is Info : Design_File_Info_Acc; @@ -27216,622 +1987,9 @@ package body Translation is Free_Old_Temp; end Finalize; - package body Chap12 is - -- Create __ghdl_ELABORATE - procedure Gen_Main (Entity : Iir_Entity_Declaration; - Arch : Iir_Architecture_Body; - Config_Subprg : O_Dnode; - Nbr_Pkgs : Natural) - is - Entity_Info : Block_Info_Acc; - Arch_Info : Block_Info_Acc; - Inter_List : O_Inter_List; - Assoc : O_Assoc_List; - Instance : O_Dnode; - Arch_Instance : O_Dnode; - Mark : Id_Mark_Type; - Arr_Type : O_Tnode; - Arr : O_Dnode; - begin - Arch_Info := Get_Info (Arch); - Entity_Info := Get_Info (Entity); - - -- We need to create code. - Set_Global_Storage (O_Storage_Private); - - -- Create the array of RTIs for packages (as a variable, initialized - -- during elaboration). - Arr_Type := New_Constrained_Array_Type - (Rtis.Ghdl_Rti_Array, - New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs))); - New_Var_Decl (Arr, Get_Identifier ("__ghdl_top_RTIARRAY"), - O_Storage_Private, Arr_Type); - - -- The elaboration entry point. - Start_Procedure_Decl (Inter_List, Get_Identifier ("__ghdl_ELABORATE"), - O_Storage_Public); - Finish_Subprogram_Decl (Inter_List, Ghdl_Elaborate); - - Start_Subprogram_Body (Ghdl_Elaborate); - New_Var_Decl (Arch_Instance, Wki_Arch_Instance, - O_Storage_Local, Arch_Info.Block_Decls_Ptr_Type); - - New_Var_Decl (Instance, Wki_Instance, O_Storage_Local, - Entity_Info.Block_Decls_Ptr_Type); - - -- Create instance for the architecture. - New_Assign_Stmt - (New_Obj (Arch_Instance), - Gen_Alloc (Alloc_System, - New_Lit (Get_Scope_Size (Arch_Info.Block_Scope)), - Arch_Info.Block_Decls_Ptr_Type)); - - -- Set the top instance. - New_Assign_Stmt - (New_Obj (Instance), - New_Address (New_Selected_Acc_Value (New_Obj (Arch_Instance), - Arch_Info.Block_Parent_Field), - Entity_Info.Block_Decls_Ptr_Type)); - - -- Clear parent field of entity link. - New_Assign_Stmt - (New_Selected_Element - (New_Selected_Acc_Value (New_Obj (Instance), - Entity_Info.Block_Link_Field), - Rtis.Ghdl_Entity_Link_Parent), - New_Lit (New_Null_Access (Rtis.Ghdl_Component_Link_Acc))); - - -- Set top instances and RTI. - -- Do it before the elaboration code, since it may be used to - -- diagnose errors. - -- Call ghdl_rti_add_top - Start_Association (Assoc, Ghdl_Rti_Add_Top); - New_Association - (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, - Unsigned_64 (Nbr_Pkgs)))); - New_Association - (Assoc, New_Lit (New_Global_Address (Arr, Rtis.Ghdl_Rti_Arr_Acc))); - New_Association - (Assoc, - New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const))); - New_Association - (Assoc, New_Convert_Ov (New_Obj_Value (Arch_Instance), - Ghdl_Ptr_Type)); - New_Procedure_Call (Assoc); - - -- Add std.standard rti - Start_Association (Assoc, Ghdl_Rti_Add_Package); - New_Association - (Assoc, - New_Lit (Rtis.New_Rti_Address - (Get_Info (Standard_Package).Package_Rti_Const))); - New_Procedure_Call (Assoc); - - Gen_Filename (Get_Design_File (Get_Design_Unit (Entity))); - - -- Elab package dependences of top entity (so that default - -- expressions can be evaluated). - Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); - New_Procedure_Call (Assoc); - - -- init instance - Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Instance); - Push_Identifier_Prefix (Mark, ""); - Chap1.Translate_Entity_Init (Entity); - - -- elab instance - Start_Association (Assoc, Arch_Info.Block_Elab_Subprg); - New_Association (Assoc, New_Obj_Value (Instance)); - New_Procedure_Call (Assoc); - - --Chap6.Link_Instance_Name (Null_Iir, Entity); - - -- configure instance. - Start_Association (Assoc, Config_Subprg); - New_Association (Assoc, New_Obj_Value (Arch_Instance)); - New_Procedure_Call (Assoc); - - Pop_Identifier_Prefix (Mark); - Clear_Scope (Entity_Info.Block_Scope); - Finish_Subprogram_Body; - - Current_Filename_Node := O_Dnode_Null; - end Gen_Main; - - procedure Gen_Setup_Info - is - Cst : O_Dnode; - pragma Unreferenced (Cst); - begin - Cst := Create_String (Flags.Flag_String, - Get_Identifier ("__ghdl_flag_string"), - O_Storage_Public); - end Gen_Setup_Info; - - procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration) - is - Entity_Info : Block_Info_Acc; - - Arch : Iir_Architecture_Body; - Arch_Info : Block_Info_Acc; - - Lib : Iir_Library_Declaration; - Lib_Mark, Entity_Mark, Arch_Mark : Id_Mark_Type; - - Config : Iir_Configuration_Declaration; - Config_Info : Config_Info_Acc; - - Const : O_Dnode; - Instance : O_Dnode; - Inter_List : O_Inter_List; - Constr : O_Assoc_List; - Subprg : O_Dnode; - begin - Arch := Libraries.Get_Latest_Architecture (Entity); - if Arch = Null_Iir then - Error_Msg_Elab ("no architecture for " & Disp_Node (Entity)); - end if; - Arch_Info := Get_Info (Arch); - if Arch_Info = null then - -- Nothing to do here, since the architecture is not used. - return; - end if; - Entity_Info := Get_Info (Entity); - - -- Create trampoline for elab, default_architecture - -- re-create instsize. - Reset_Identifier_Prefix; - Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity))); - Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); - Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); - Push_Identifier_Prefix (Arch_Mark, "LASTARCH"); - - -- Instance size. - New_Const_Decl - (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public, - Ghdl_Index_Type); - Start_Const_Value (Const); - Finish_Const_Value (Const, Get_Scope_Size (Arch_Info.Block_Scope)); - - -- Elaborator. - Start_Procedure_Decl - (Inter_List, Create_Identifier ("ELAB"), O_Storage_Public); - New_Interface_Decl - (Inter_List, Instance, Wki_Instance, - Entity_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Subprg); - - Start_Subprogram_Body (Subprg); - Start_Association (Constr, Arch_Info.Block_Elab_Subprg); - New_Association (Constr, New_Obj_Value (Instance)); - New_Procedure_Call (Constr); - Finish_Subprogram_Body; - - -- Default config. - Config := Get_Library_Unit - (Get_Default_Configuration_Declaration (Arch)); - Config_Info := Get_Info (Config); - if Config_Info /= null then - -- Do not create a trampoline for the default_config if it is not - -- used. - Start_Procedure_Decl - (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), - O_Storage_Public); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Arch_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Subprg); - - Start_Subprogram_Body (Subprg); - Start_Association (Constr, Config_Info.Config_Subprg); - New_Association (Constr, New_Obj_Value (Instance)); - New_Procedure_Call (Constr); - Finish_Subprogram_Body; - end if; - - Pop_Identifier_Prefix (Arch_Mark); - Pop_Identifier_Prefix (Entity_Mark); - Pop_Identifier_Prefix (Lib_Mark); - end Gen_Last_Arch; - - procedure Gen_Dummy_Default_Config (Arch : Iir_Architecture_Body) - is - Entity : Iir_Entity_Declaration; - Lib : Iir_Library_Declaration; - Lib_Mark, Entity_Mark, Sep_Mark, Arch_Mark : Id_Mark_Type; - - Inter_List : O_Inter_List; - - Subprg : O_Dnode; - begin - Reset_Identifier_Prefix; - Entity := Get_Entity (Arch); - Lib := Get_Library (Get_Design_File (Get_Design_Unit (Arch))); - Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); - Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); - Push_Identifier_Prefix (Sep_Mark, "ARCH"); - Push_Identifier_Prefix (Arch_Mark, Get_Identifier (Arch)); - - -- Elaborator. - Start_Procedure_Decl - (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), - O_Storage_Public); - Finish_Subprogram_Decl (Inter_List, Subprg); - - Start_Subprogram_Body (Subprg); - Chap6.Gen_Program_Error (Arch, Chap6.Prg_Err_Dummy_Config); - Finish_Subprogram_Body; - - Pop_Identifier_Prefix (Arch_Mark); - Pop_Identifier_Prefix (Sep_Mark); - Pop_Identifier_Prefix (Entity_Mark); - Pop_Identifier_Prefix (Lib_Mark); - end Gen_Dummy_Default_Config; - - procedure Gen_Dummy_Package_Declaration (Unit : Iir_Design_Unit) - is - Pkg : Iir_Package_Declaration; - Lib : Iir_Library_Declaration; - Lib_Mark, Pkg_Mark : Id_Mark_Type; - - Decl : Iir; - begin - Libraries.Load_Design_Unit (Unit, Null_Iir); - Pkg := Get_Library_Unit (Unit); - Reset_Identifier_Prefix; - Lib := Get_Library (Get_Design_File (Get_Design_Unit (Pkg))); - Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); - Push_Identifier_Prefix (Pkg_Mark, Get_Identifier (Pkg)); - - if Get_Need_Body (Pkg) then - Decl := Get_Declaration_Chain (Pkg); - while Decl /= Null_Iir loop - case Get_Kind (Decl) is - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - -- Generate empty body. - - -- Never a second spec, as this is within a package - -- declaration. - pragma Assert - (not Is_Second_Subprogram_Specification (Decl)); - - if not Get_Foreign_Flag (Decl) then - declare - Mark : Id_Mark_Type; - Inter_List : O_Inter_List; - Proc : O_Dnode; - begin - Chap2.Push_Subprg_Identifier (Decl, Mark); - Start_Procedure_Decl - (Inter_List, Create_Identifier, O_Storage_Public); - Finish_Subprogram_Decl (Inter_List, Proc); - Start_Subprogram_Body (Proc); - Finish_Subprogram_Body; - Pop_Identifier_Prefix (Mark); - end; - end if; - when others => - null; - end case; - Decl := Get_Chain (Decl); - end loop; - end if; - - -- Create the body elaborator. - declare - Inter_List : O_Inter_List; - Proc : O_Dnode; - begin - Start_Procedure_Decl - (Inter_List, Create_Identifier ("ELAB_BODY"), O_Storage_Public); - Finish_Subprogram_Decl (Inter_List, Proc); - Start_Subprogram_Body (Proc); - Finish_Subprogram_Body; - end; - - Pop_Identifier_Prefix (Pkg_Mark); - Pop_Identifier_Prefix (Lib_Mark); - end Gen_Dummy_Package_Declaration; - - procedure Write_File_List (Filelist : String) - is - use Interfaces.C_Streams; - use System; - use Configuration; - use Name_Table; - - -- Add all dependences of UNIT. - -- UNIT is not used, but added during link. - procedure Add_Unit_Dependences (Unit : Iir_Design_Unit) - is - Dep_List : Iir_List; - Dep : Iir; - Dep_Unit : Iir_Design_Unit; - Lib_Unit : Iir; - begin - -- Load the unit in memory to compute the dependence list. - Libraries.Load_Design_Unit (Unit, Null_Iir); - Update_Node_Infos; - - Set_Elab_Flag (Unit, True); - Design_Units.Append (Unit); - - if Flag_Rti then - Rtis.Generate_Library - (Get_Library (Get_Design_File (Unit)), True); - end if; - - Lib_Unit := Get_Library_Unit (Unit); - case Get_Kind (Lib_Unit) is - when Iir_Kind_Package_Declaration => - -- The body may be required due to incomplete constant - -- declarations, or to call to a subprogram. - declare - Pack_Body : Iir; - begin - Pack_Body := Libraries.Find_Secondary_Unit - (Unit, Null_Identifier); - if Pack_Body /= Null_Iir then - Add_Unit_Dependences (Pack_Body); - else - Gen_Dummy_Package_Declaration (Unit); - end if; - end; - when Iir_Kind_Architecture_Body => - Gen_Dummy_Default_Config (Lib_Unit); - when others => - null; - end case; - - Dep_List := Get_Dependence_List (Unit); - for I in Natural loop - Dep := Get_Nth_Element (Dep_List, I); - exit when Dep = Null_Iir; - Dep_Unit := Libraries.Find_Design_Unit (Dep); - if Dep_Unit = Null_Iir then - Error_Msg_Elab - ("could not find design unit " & Disp_Node (Dep)); - elsif not Get_Elab_Flag (Dep_Unit) then - Add_Unit_Dependences (Dep_Unit); - end if; - end loop; - end Add_Unit_Dependences; - - -- Add not yet added units of FILE. - procedure Add_File_Units (File : Iir_Design_File) - is - Unit : Iir_Design_Unit; - begin - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - if not Get_Elab_Flag (Unit) then - -- Unit not used. - Add_Unit_Dependences (Unit); - end if; - Unit := Get_Chain (Unit); - end loop; - end Add_File_Units; - - Nul : constant Character := Character'Val (0); - Fname : String := Filelist & Nul; - Mode : constant String := "wt" & Nul; - F : FILEs; - R : int; - S : size_t; - pragma Unreferenced (R, S); -- FIXME - Id : Name_Id; - Lib : Iir_Library_Declaration; - File : Iir_Design_File; - Unit : Iir_Design_Unit; - J : Natural; - begin - F := fopen (Fname'Address, Mode'Address); - if F = NULL_Stream then - Error_Msg_Elab ("cannot open " & Filelist); - end if; - - -- Set elab flags on units, and remove it on design files. - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - Set_Elab_Flag (Unit, True); - File := Get_Design_File (Unit); - Set_Elab_Flag (File, False); - end loop; - - J := Design_Units.First; - while J <= Design_Units.Last loop - Unit := Design_Units.Table (J); - File := Get_Design_File (Unit); - if not Get_Elab_Flag (File) then - Set_Elab_Flag (File, True); - - -- Add dependences of unused design units, otherwise the object - -- link case failed. - Add_File_Units (File); - - Lib := Get_Library (File); - R := fputc (Character'Pos ('>'), F); - Id := Get_Library_Directory (Lib); - S := fwrite (Get_Address (Id), - size_t (Get_Name_Length (Id)), 1, F); - R := fputc (10, F); - - Id := Get_Design_File_Filename (File); - S := fwrite (Get_Address (Id), - size_t (Get_Name_Length (Id)), 1, F); - R := fputc (10, F); - end if; - J := J + 1; - end loop; - end Write_File_List; - - procedure Elaborate - (Primary : String; - Secondary : String; - Filelist : String; - Whole : Boolean) - is - use Name_Table; - use Configuration; - - Primary_Id : Name_Id; - Secondary_Id : Name_Id; - Unit : Iir_Design_Unit; - Lib_Unit : Iir; - Config : Iir_Design_Unit; - Config_Lib : Iir_Configuration_Declaration; - Entity : Iir_Entity_Declaration; - Arch : Iir_Architecture_Body; - Conf_Info : Config_Info_Acc; - Last_Design_Unit : Natural; - Nbr_Pkgs : Natural; - begin - Primary_Id := Get_Identifier (Primary); - if Secondary /= "" then - Secondary_Id := Get_Identifier (Secondary); - else - Secondary_Id := Null_Identifier; - end if; - Config := Configure (Primary_Id, Secondary_Id); - if Config = Null_Iir then - return; - end if; - Config_Lib := Get_Library_Unit (Config); - Entity := Get_Entity (Config_Lib); - Arch := Get_Block_Specification - (Get_Block_Configuration (Config_Lib)); - - -- Be sure the entity can be at the top of a design. - Check_Entity_Declaration_Top (Entity); - - -- If all design units are loaded, late semantic checks can be - -- performed. - if Flag_Load_All_Design_Units then - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - Sem.Sem_Analysis_Checks_List (Unit, False); - -- There cannot be remaining checks to do. - pragma Assert - (Get_Analysis_Checks_List (Unit) = Null_Iir_List); - end loop; - end if; - - -- Return now in case of errors. - if Nbr_Errors /= 0 then - return; - end if; - - if Flags.Verbose then - Ada.Text_IO.Put_Line ("List of units in the hierarchy design:"); - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - Lib_Unit := Get_Library_Unit (Unit); - Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); - end loop; - end if; - - if Whole then - -- In compile-and-elaborate mode, do not generate code for - -- unused subprograms. - -- FIXME: should be improved by creating a span-tree. - Flag_Discard_Unused := True; - Flag_Discard_Unused_Implicit := True; - end if; - - -- Generate_Library add infos, therefore the info array must be - -- adjusted. - Update_Node_Infos; - Rtis.Generate_Library (Libraries.Std_Library, True); - Translate_Standard (Whole); - - -- Translate all configurations needed. - -- Also, set the ELAB_FLAG on package with body. - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - Lib_Unit := Get_Library_Unit (Unit); - - if Whole then - -- In whole compilation mode, force to generate RTIS of - -- libraries. - Rtis.Generate_Library - (Get_Library (Get_Design_File (Unit)), True); - end if; - - case Get_Kind (Lib_Unit) is - when Iir_Kind_Configuration_Declaration => - -- Always generate code for configuration. - -- Because default binding may be changed between analysis - -- and elaboration. - Translate (Unit, True); - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration => - -- For package spec, mark it as 'body is not present', this - -- flag will be set below when the body is translated. - Set_Elab_Flag (Unit, False); - Translate (Unit, Whole); - when Iir_Kind_Package_Body => - -- Mark the spec with 'body is present' flag. - Set_Elab_Flag - (Get_Design_Unit (Get_Package (Lib_Unit)), True); - Translate (Unit, Whole); - when others => - Error_Kind ("elaborate", Lib_Unit); - end case; - end loop; + procedure Elaborate (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean) renames Trans.Chap12.Elaborate; - -- Generate code to elaboration body-less package. - -- - -- When a package is analyzed, we don't know wether there is body - -- or not. Therefore, we assume there is always a body, and will - -- elaborate the body (which elaborates its spec). If a package - -- has no body, create the body elaboration procedure. - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - Lib_Unit := Get_Library_Unit (Unit); - case Get_Kind (Lib_Unit) is - when Iir_Kind_Package_Declaration => - if not Get_Elab_Flag (Unit) then - Chap2.Elab_Package_Body (Lib_Unit, Null_Iir); - end if; - when Iir_Kind_Entity_Declaration => - Gen_Last_Arch (Lib_Unit); - when Iir_Kind_Architecture_Body - | Iir_Kind_Package_Body - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Package_Instantiation_Declaration => - null; - when others => - Error_Kind ("elaborate(2)", Lib_Unit); - end case; - end loop; - - Rtis.Generate_Top (Nbr_Pkgs); - - -- Create main code. - Conf_Info := Get_Info (Config_Lib); - Gen_Main (Entity, Arch, Conf_Info.Config_Subprg, Nbr_Pkgs); - - Gen_Setup_Info; - - -- Index of the last design unit, required by the design. - Last_Design_Unit := Design_Units.Last; - - -- Disp list of files needed. - -- FIXME: extract the link completion part of WRITE_FILE_LIST. - if Filelist /= "" then - Write_File_List (Filelist); - end if; - - if Flags.Verbose then - Ada.Text_IO.Put_Line ("List of units not used:"); - for I in Last_Design_Unit + 1 .. Design_Units.Last loop - Unit := Design_Units.Table (I); - Lib_Unit := Get_Library_Unit (Unit); - Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); - end loop; - end if; - end Elaborate; - end Chap12; end Translation; |