-- Iir to ortho translator. -- Copyright (C) 2002 - 2014 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free -- Software Foundation; either version 2, or (at your option) any later -- version. -- -- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -- WARRANTY; without even the implied warranty of MERCHANTABILITY or -- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- for more details. -- -- You should have received a copy of the GNU General Public License -- along with GCC; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Name_Table; with Errorout; use Errorout; with Iirs_Utils; use Iirs_Utils; with Evaluation; use Evaluation; with Trans.Chap2; with Trans.Chap4; with Trans.Chap6; with Trans.Chap7; with Trans.Chap14; with Trans_Decls; use Trans_Decls; with Trans.Helpers2; use Trans.Helpers2; with Translation; package body Trans.Chap3 is use Trans.Helpers; function Create_Static_Type_Definition_Type_Range (Def : Iir) return O_Cnode; procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode); -- For scalar subtypes: creates info from the base type. procedure Create_Subtype_Info_From_Type (Def : Iir; Subtype_Info : Type_Info_Acc; Base_Info : Type_Info_Acc); -- Finish a type definition: declare the type, define and declare a -- pointer to the type. procedure Finish_Type_Definition (Info : Type_Info_Acc; Completion : Boolean := False) is begin -- Declare the type. if not Completion then New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); end if; -- Create an access to the type and declare it. Info.Ortho_Ptr_Type (Mode_Value) := New_Access_Type (Info.Ortho_Type (Mode_Value)); New_Type_Decl (Create_Identifier ("PTR"), Info.Ortho_Ptr_Type (Mode_Value)); -- Signal type. if Info.Type_Mode in Type_Mode_Scalar then Info.Ortho_Type (Mode_Signal) := New_Access_Type (Info.Ortho_Type (Mode_Value)); end if; if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then New_Type_Decl (Create_Identifier ("SIG"), Info.Ortho_Type (Mode_Signal)); end if; -- Signal pointer type. if Info.Type_Mode in Type_Mode_Composite and then Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then Info.Ortho_Ptr_Type (Mode_Signal) := New_Access_Type (Info.Ortho_Type (Mode_Signal)); New_Type_Decl (Create_Identifier ("SIGPTR"), Info.Ortho_Ptr_Type (Mode_Signal)); else Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; end if; end Finish_Type_Definition; procedure Create_Size_Var (Def : Iir) is Info : constant Type_Info_Acc := Get_Info (Def); begin Info.C := new Complex_Type_Arr_Info; Info.C (Mode_Value).Size_Var := Create_Var (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); if Get_Has_Signal_Flag (Def) then Info.C (Mode_Signal).Size_Var := Create_Var (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); end if; end Create_Size_Var; -- A builder set internal fields of object pointed by BASE_PTR, using -- memory from BASE_PTR and returns a pointer to the next memory byte -- to be used. procedure Create_Builder_Subprogram_Decl (Info : Type_Info_Acc; Name : Name_Id; Kind : Object_Kind_Type) is Interface_List : O_Inter_List; Ident : O_Ident; Ptype : O_Tnode; begin case Kind is when Mode_Value => Ident := Create_Identifier (Name, "_BUILDER"); when Mode_Signal => Ident := Create_Identifier (Name, "_SIGBUILDER"); end case; -- FIXME: return the same type as its first parameter ??? Start_Function_Decl (Interface_List, Ident, Global_Storage, Ghdl_Index_Type); Subprgs.Add_Subprg_Instance_Interfaces (Interface_List, Info.C (Kind).Builder_Instance); case Info.Type_Mode is when Type_Mode_Fat_Array => Ptype := Info.T.Base_Ptr_Type (Kind); when Type_Mode_Record => Ptype := Info.Ortho_Ptr_Type (Kind); when others => raise Internal_Error; end case; New_Interface_Decl (Interface_List, Info.C (Kind).Builder_Base_Param, Get_Identifier ("base_ptr"), Ptype); -- Add parameter for array bounds. if Info.Type_Mode = Type_Mode_Fat_Array then New_Interface_Decl (Interface_List, Info.C (Kind).Builder_Bound_Param, Get_Identifier ("bound"), Info.T.Bounds_Ptr_Type); end if; Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func); end Create_Builder_Subprogram_Decl; function Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) return O_Enode is Kind : constant Object_Kind_Type := Get_Object_Kind (Var); 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, M2Addr (Var)); 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, M2Addr (Chap3.Get_Array_Base (Var))); when others => raise Internal_Error; end case; if Tinfo.Type_Mode in Type_Mode_Arrays then New_Association (Assoc, M2Addr (Chap3.Get_Array_Bounds (Var))); 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 (V, Var_Type)); Close_Temp; end Gen_Call_Type_Builder; ------------------ -- Enumeration -- ------------------ function Translate_Enumeration_Literal (Lit : Iir_Enumeration_Literal) return O_Ident is El_Str : String (1 .. 4); Id : Name_Id; N : Integer; C : Character; begin Id := Get_Identifier (Lit); if Name_Table.Is_Character (Id) then C := Name_Table.Get_Character (Id); El_Str (1) := 'C'; case C is when 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' => El_Str (2) := '_'; El_Str (3) := C; when others => N := Character'Pos (Name_Table.Get_Character (Id)); El_Str (2) := N2hex (N / 16); El_Str (3) := N2hex (N mod 16); end case; return Get_Identifier (El_Str (1 .. 3)); else return Create_Identifier_Without_Prefix (Lit); end if; end Translate_Enumeration_Literal; procedure Translate_Enumeration_Type (Def : Iir_Enumeration_Type_Definition) is El_List : Iir_List; El : Iir_Enumeration_Literal; Constr : O_Enum_List; Lit_Name : O_Ident; Val : O_Cnode; Info : Type_Info_Acc; Nbr : Natural; Size : Natural; begin El_List := Get_Enumeration_Literal_List (Def); Nbr := Get_Nbr_Elements (El_List); if Nbr <= 256 then Size := 8; else Size := 32; end if; Start_Enum_Type (Constr, Size); for I in Natural loop El := Get_Nth_Element (El_List, I); exit when El = Null_Iir; Lit_Name := Translate_Enumeration_Literal (El); New_Enum_Literal (Constr, Lit_Name, Val); Set_Ortho_Expr (El, Val); end loop; Info := Get_Info (Def); Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value)); if Nbr <= 256 then Info.Type_Mode := Type_Mode_E8; else Info.Type_Mode := Type_Mode_E32; end if; -- Enumerations are always in their range. Info.T.Nocheck_Low := True; Info.T.Nocheck_Hi := True; Finish_Type_Definition (Info); end Translate_Enumeration_Type; procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition) is Info : Type_Info_Acc; El_List : Iir_List; True_Lit, False_Lit : Iir_Enumeration_Literal; False_Node, True_Node : O_Cnode; begin Info := Get_Info (Def); El_List := Get_Enumeration_Literal_List (Def); if Get_Nbr_Elements (El_List) /= 2 then raise Internal_Error; end if; False_Lit := Get_Nth_Element (El_List, 0); True_Lit := Get_Nth_Element (El_List, 1); New_Boolean_Type (Info.Ortho_Type (Mode_Value), Translate_Enumeration_Literal (False_Lit), False_Node, Translate_Enumeration_Literal (True_Lit), True_Node); Info.Type_Mode := Type_Mode_B1; Set_Ortho_Expr (False_Lit, False_Node); Set_Ortho_Expr (True_Lit, True_Node); Info.T.Nocheck_Low := True; Info.T.Nocheck_Hi := True; Finish_Type_Definition (Info); end Translate_Bool_Type; --------------- -- Integer -- --------------- -- Return the number of bits (32 or 64) required to represent the -- (integer or physical) type definition DEF. type Type_Precision is (Precision_32, Precision_64); function Get_Type_Precision (Def : Iir) return Type_Precision is St : Iir; L, H : Iir; Lv, Hv : Iir_Int64; begin St := Get_Subtype_Definition (Get_Type_Declarator (Def)); Get_Low_High_Limit (Get_Range_Constraint (St), L, H); Lv := Get_Value (L); Hv := Get_Value (H); if Lv >= -(2 ** 31) and then Hv <= (2 ** 31 - 1) then return Precision_32; else if Translation.Flag_Only_32b then Error_Msg_Sem ("range of " & Disp_Node (Get_Type_Declarator (St)) & " is too large", St); return Precision_32; end if; return Precision_64; end if; end Get_Type_Precision; procedure Translate_Integer_Type (Def : Iir_Integer_Type_Definition) is Info : Type_Info_Acc; begin Info := Get_Info (Def); case Get_Type_Precision (Def) is when Precision_32 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); Info.Type_Mode := Type_Mode_I32; when Precision_64 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); Info.Type_Mode := Type_Mode_I64; end case; -- Integers are always in their ranges. Info.T.Nocheck_Low := True; Info.T.Nocheck_Hi := True; Finish_Type_Definition (Info); end Translate_Integer_Type; ---------------------- -- Floating types -- ---------------------- procedure Translate_Floating_Type (Def : Iir_Floating_Type_Definition) is Info : Type_Info_Acc; begin -- FIXME: should check precision Info := Get_Info (Def); Info.Type_Mode := Type_Mode_F64; Info.Ortho_Type (Mode_Value) := New_Float_Type; -- Reals are always in their ranges. Info.T.Nocheck_Low := True; Info.T.Nocheck_Hi := True; Finish_Type_Definition (Info); end Translate_Floating_Type; ---------------- -- Physical -- ---------------- procedure Translate_Physical_Type (Def : Iir_Physical_Type_Definition) is Info : Type_Info_Acc; begin Info := Get_Info (Def); case Get_Type_Precision (Def) is when Precision_32 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); Info.Type_Mode := Type_Mode_P32; when Precision_64 => Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); Info.Type_Mode := Type_Mode_P64; end case; -- Phyiscals are always in their ranges. Info.T.Nocheck_Low := True; Info.T.Nocheck_Hi := True; Finish_Type_Definition (Info); end Translate_Physical_Type; procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition) is Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value); Unit : Iir; Info : Object_Info_Acc; begin Unit := Get_Unit_Chain (Def); while Unit /= Null_Iir loop Info := Add_Info (Unit, Kind_Object); Info.Object_Var := Create_Var (Create_Var_Identifier (Unit), Phy_Type); Unit := Get_Chain (Unit); end loop; end Translate_Physical_Units; ------------ -- File -- ------------ procedure Translate_File_Type (Def : Iir_File_Type_Definition) is Info : Type_Info_Acc; begin Info := Get_Info (Def); Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type; Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type; Info.Type_Mode := Type_Mode_File; end Translate_File_Type; function Get_File_Signature_Length (Def : Iir) return Natural is begin case Get_Kind (Def) is when Iir_Kinds_Scalar_Type_Definition => return 1; when Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition => return 2 + Get_File_Signature_Length (Get_Element_Subtype (Def)); when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => declare El : Iir; Res : Natural; List : Iir_List; begin Res := 2; List := Get_Elements_Declaration_List (Get_Base_Type (Def)); for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; Res := Res + Get_File_Signature_Length (Get_Type (El)); end loop; return Res; end; when others => Error_Kind ("get_file_signature_length", Def); end case; end Get_File_Signature_Length; procedure Get_File_Signature (Def : Iir; Res : in out String; Off : in out Natural) is Scalar_Map : constant array (Type_Mode_Scalar) of Character := "beEiIpPF"; begin case Get_Kind (Def) is when Iir_Kinds_Scalar_Type_Definition => Res (Off) := Scalar_Map (Get_Info (Def).Type_Mode); Off := Off + 1; when Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition => Res (Off) := '['; Off := Off + 1; Get_File_Signature (Get_Element_Subtype (Def), Res, Off); Res (Off) := ']'; Off := Off + 1; when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => declare El : Iir; List : Iir_List; begin Res (Off) := '<'; Off := Off + 1; List := Get_Elements_Declaration_List (Get_Base_Type (Def)); for I in Natural loop El := Get_Nth_Element (List, I); exit when El = Null_Iir; Get_File_Signature (Get_Type (El), Res, Off); end loop; Res (Off) := '>'; Off := Off + 1; end; when others => Error_Kind ("get_file_signature", Def); end case; end Get_File_Signature; procedure Create_File_Type_Var (Def : Iir_File_Type_Definition) is Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); Info : Type_Info_Acc; begin if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition then return; end if; declare Len : constant Natural := Get_File_Signature_Length (Type_Name); Sig : String (1 .. Len + 2); Off : Natural := Sig'First; begin Get_File_Signature (Type_Name, Sig, Off); Sig (Len + 1) := '.'; Sig (Len + 2) := Character'Val (10); Info := Get_Info (Def); Info.T.File_Signature := Create_String (Sig, Create_Identifier ("FILESIG"), Global_Storage); end; end Create_File_Type_Var; ------------- -- Array -- ------------- function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is begin if Get_Has_Signal_Flag (Def) then return Mode_Signal; else return Mode_Value; end if; end Type_To_Last_Object_Kind; procedure Create_Array_Fat_Pointer (Info : Type_Info_Acc; Kind : Object_Kind_Type) is Constr : O_Element_List; begin Start_Record_Type (Constr); New_Record_Field (Constr, Info.T.Base_Field (Kind), Get_Identifier ("BASE"), Info.T.Base_Ptr_Type (Kind)); New_Record_Field (Constr, Info.T.Bounds_Field (Kind), Get_Identifier ("BOUNDS"), Info.T.Bounds_Ptr_Type); Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); end Create_Array_Fat_Pointer; procedure Translate_Incomplete_Array_Type (Def : Iir_Array_Type_Definition) is Arr_Info : Incomplete_Type_Info_Acc; Info : Type_Info_Acc; begin Arr_Info := Get_Info (Def); if Arr_Info.Incomplete_Array /= null then -- This (incomplete) array type was already translated. -- This is the case for a second access type definition to this -- still incomplete array type. return; end if; Info := new Ortho_Info_Type (Kind_Type); Info.Type_Mode := Type_Mode_Fat_Array; Info.Type_Incomplete := True; Arr_Info.Incomplete_Array := Info; Info.T := Ortho_Info_Type_Array_Init; Info.T.Bounds_Type := O_Tnode_Null; Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); New_Type_Decl (Create_Identifier ("BOUNDP"), Info.T.Bounds_Ptr_Type); Info.T.Base_Ptr_Type (Mode_Value) := New_Access_Type (O_Tnode_Null); New_Type_Decl (Create_Identifier ("BASEP"), Info.T.Base_Ptr_Type (Mode_Value)); Create_Array_Fat_Pointer (Info, Mode_Value); New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); end Translate_Incomplete_Array_Type; -- Declare the bounds types for DEF. procedure Translate_Array_Type_Bounds (Def : Iir_Array_Type_Definition; Info : Type_Info_Acc; Complete : Boolean) is Indexes_List : constant Iir_List := Get_Index_Subtype_Definition_List (Def); Constr : O_Element_List; Dim : String (1 .. 8); N : Natural; P : Natural; Index : Iir; Index_Info : Index_Info_Acc; Index_Type_Mark : Iir; begin Start_Record_Type (Constr); for I in Natural loop Index_Type_Mark := Get_Nth_Element (Indexes_List, I); exit when Index_Type_Mark = Null_Iir; Index := Get_Index_Type (Index_Type_Mark); -- Index comes from a type mark. pragma Assert (not Is_Anonymous_Type_Definition (Index)); Index_Info := Add_Info (Index_Type_Mark, Kind_Index); -- Build the name N := I + 1; P := Dim'Last; loop Dim (P) := Character'Val (Character'Pos ('0') + N mod 10); P := P - 1; N := N / 10; exit when N = 0; end loop; P := P - 3; Dim (P .. P + 3) := "dim_"; New_Record_Field (Constr, Index_Info.Index_Field, Get_Identifier (Dim (P .. Dim'Last)), Get_Info (Get_Base_Type (Index)).T.Range_Type); end loop; Finish_Record_Type (Constr, Info.T.Bounds_Type); New_Type_Decl (Create_Identifier ("BOUND"), Info.T.Bounds_Type); if Complete then Finish_Access_Type (Info.T.Bounds_Ptr_Type, Info.T.Bounds_Type); else Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); New_Type_Decl (Create_Identifier ("BOUNDP"), Info.T.Bounds_Ptr_Type); end if; end Translate_Array_Type_Bounds; procedure Translate_Array_Type_Base (Def : Iir_Array_Type_Definition; Info : Type_Info_Acc; Complete : Boolean) is El_Type : Iir; El_Tinfo : Type_Info_Acc; Id, Idptr : O_Ident; begin El_Type := Get_Element_Subtype (Def); Translate_Type_Definition (El_Type, True); El_Tinfo := Get_Info (El_Type); if Is_Complex_Type (El_Tinfo) then if El_Tinfo.Type_Mode = Type_Mode_Array then Info.T.Base_Type := El_Tinfo.T.Base_Ptr_Type; Info.T.Base_Ptr_Type := El_Tinfo.T.Base_Ptr_Type; else Info.T.Base_Type := El_Tinfo.Ortho_Ptr_Type; Info.T.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type; end if; else for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop case Kind is when Mode_Value => -- For the values. Id := Create_Identifier ("BASE"); if not Complete then Idptr := Create_Identifier ("BASEP"); else Idptr := O_Ident_Nul; end if; when Mode_Signal => -- For the signals Id := Create_Identifier ("SIGBASE"); Idptr := Create_Identifier ("SIGBASEP"); end case; Info.T.Base_Type (Kind) := New_Array_Type (El_Tinfo.Ortho_Type (Kind), Ghdl_Index_Type); New_Type_Decl (Id, Info.T.Base_Type (Kind)); if Is_Equal (Idptr, O_Ident_Nul) then Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), Info.T.Base_Type (Kind)); else Info.T.Base_Ptr_Type (Kind) := New_Access_Type (Info.T.Base_Type (Kind)); New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); end if; end loop; end if; end Translate_Array_Type_Base; 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); 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, null, Mode_Value, Baseinfo.T.Bounds_Type, Baseinfo.T.Bounds_Ptr_Type); 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 (Dp2M (D, Index_Info, Mode_Value, Index_Info.T.Range_Type, Index_Info.T.Range_Ptr_Type), 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 (Dp2M (Var_Mem, El_Info, Kind), El_Type))); 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 (Dp2M (Ptr_Var, El_Tinfo, Kind), El_Type))); 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 -- The protected type is represented by an incomplete record, that -- will be completed by the protected type body. Predeclare_Scope_Type (Info.T.Prot_Scope, Create_Identifier); Info.Ortho_Type (Mode_Value) := O_Tnode_Null; -- Create a pointer type to that record. Declare_Scope_Acc (Info.T.Prot_Scope, Create_Identifier ("PTR"), Info.Ortho_Ptr_Type (Mode_Value)); -- A protected type cannot be used for signals. 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 (Get_Scope_Type (Info.T.Prot_Scope), 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 : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def)); begin Chap7.Translate_Range (Lv2M (Target, T_Info, Mode_Value, T_Info.T.Range_Type, T_Info.T.Range_Ptr_Type), Get_Range_Constraint (Def), Def); 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; 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 => Info.T := Ortho_Info_Type_Prot_Init; Translate_Protected_Type (Def); 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, Mode_Value, 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), T_Info, Kind, T_Info.T.Base_Type (Kind), T_Info.T.Base_Ptr_Type (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; Res : Mnode) is Attr_Kind : Iir_Kind; Arr_Rng : Mnode; Iinfo : Type_Info_Acc; 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); -- Length. New_Assign_Stmt (M2Lv (Range_To_Length (Res)), 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; Res : Mnode; 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; Res_Range : Mnode; begin if Get_Kind (Range_Constr) /= Iir_Kind_Range_Expression then Open_Temp; Res_Range := Stabilize (Res); Create_Range_From_Array_Attribute_And_Length (Range_Constr, Length, Res_Range); Close_Temp; return; end if; Start_Declare_Stmt; Open_Local_Temp; Res_Range := Stabilize (Res); New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); New_Assign_Stmt (M2Lv (Range_To_Length (Res_Range)), New_Obj_Value (Length)); New_Assign_Stmt (M2Lv (Range_To_Dir (Res_Range)), 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 (M2Lv (Range_To_Left (Res_Range)), Chap7.Translate_Range_Expression_Right (Range_Constr, Index_Type)); New_Assign_Stmt (M2Lv (Range_To_Right (Res_Range)), Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); New_Else_Stmt (If_Blk); New_Assign_Stmt (M2Lv (Range_To_Left (Res_Range)), 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 (M2Lv (Range_To_Right (Res_Range)), New_Obj_Value (Var_Right)); Finish_If_Stmt (If_Blk); Close_Local_Temp; Finish_Declare_Stmt; end Create_Range_From_Length; end Trans.Chap3;