diff options
Diffstat (limited to 'translate/translation.adb')
| -rw-r--r-- | translate/translation.adb | 208 |
1 files changed, 171 insertions, 37 deletions
diff --git a/translate/translation.adb b/translate/translation.adb index ff38401..37a1074 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -2897,15 +2897,13 @@ package body Translation is end if; end Create_Temp; - function Translate_Foreign_Id (Decl : Iir; Extract_Name : Boolean) - return Foreign_Info_Type + function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type is use Name_Table; Attr : Iir_Attribute_Value; Spec : Iir_Attribute_Specification; Attr_Decl : Iir; Expr : Iir; - P : Natural; begin -- Look for 'FOREIGN. Attr := Get_Attribute_Value_Chain (Decl); @@ -2972,27 +2970,60 @@ package body Translation is if Name_Length >= 10 and then Name_Buffer (1 .. 10) = "VHPIDIRECT" then - P := 11; + declare + P : Natural; + Sf, Sl : Natural; + Lf, Ll : Natural; + begin + P := 11; - -- Skip spaces. - while P <= Name_Length and then Name_Buffer (P) = ' ' loop + -- Skip spaces. + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + if P > Name_Length then + Error_Msg_Sem + ("missing subprogram/library name after VHPIDIRECT", Spec); + end if; + -- Extract library. + Lf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Ll := P; + -- Extract subprogram. P := P + 1; - end loop; - if Extract_Name then + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + Sf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Sl := P; + if P < Name_Length then + Error_Msg_Sem ("garbage at end of VHPIDIRECT", Spec); + end if; + + -- Accept empty library. + if Sf > Name_Length then + Sf := Lf; + Sl := Ll; + Lf := 0; + Ll := 0; + end if; + return Foreign_Info_Type' (Kind => Foreign_Vhpidirect, - Subprg => Get_Identifier (Name_Buffer (P .. Name_Length)), - Lib => Null_Identifier); - else - return Foreign_Info_Type'(Kind => Foreign_Vhpidirect, - Subprg => O_Ident_Nul, - Lib => Null_Identifier); - end if; + Lib_First => Lf, + Lib_Last => Ll, + Subprg_First => Sf, + Subprg_Last => Sl); + end; elsif Name_Length = 14 and then Name_Buffer (1 .. 14) = "GHDL intrinsic" then - return Foreign_Info_Type'(Kind => Foreign_Intrinsic, - Subprg => Create_Identifier); + return Foreign_Info_Type'(Kind => Foreign_Intrinsic); else Error_Msg_Sem ("value of 'FOREIGN attribute does not begin with VHPIDIRECT", @@ -4640,6 +4671,7 @@ package body Translation is Rtype : Iir; Id : O_Ident; Storage : O_Storage; + Foreign : Foreign_Info_Type := Foreign_Bad; begin Info := Get_Info (Spec); Info.Res_Interface := O_Dnode_Null; @@ -4650,20 +4682,18 @@ package body Translation is Push_Subprg_Identifier (Spec, Mark); if Get_Foreign_Flag (Spec) then - declare - Fi : Foreign_Info_Type; - begin - Fi := Translate_Foreign_Id (Spec, True); - case Fi.Kind is - when Foreign_Unknown => - Id := Create_Identifier; - when Foreign_Intrinsic => - Id := Fi.Subprg; - when Foreign_Vhpidirect => - Id := Fi.Subprg; - end case; - Storage := O_Storage_External; - end; + 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; @@ -4778,6 +4808,10 @@ package body Translation is end loop; Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); + 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; @@ -4804,7 +4838,7 @@ package body Translation is Old_Subprogram : Iir; Mark : Id_Mark_Type; Final : Boolean; - Is_Func : Boolean; + Is_Ortho_Func : Boolean; -- Set for a public method. In this case, the lock must be acquired -- and retained. @@ -4877,8 +4911,8 @@ package body Translation is Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), Ghdl_Protected_Enter); end if; - Is_Func := Is_Subprogram_Ortho_Function (Spec); - if Is_Func then + 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, @@ -4906,7 +4940,7 @@ package body Translation is Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), Ghdl_Protected_Leave); end if; - if Is_Func then + if Is_Ortho_Func then New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); end if; end if; @@ -13218,6 +13252,7 @@ package body Translation is Res : O_Cnode; begin Lit_Type := Get_Type (Str); + Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); @@ -13230,6 +13265,86 @@ package body Translation is return Res; end Translate_Static_String_Literal; + -- 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_Static_Unconstrained_String_Literal (Str : Iir) + return O_Cnode + is + use Name_Table; + + Lit_Type : Iir; + Element_Type : Iir; + Index_Type : Iir; + Val_Aggr : O_Array_Aggr_List; + Bound_Aggr : O_Record_Aggr_List; + Index_Aggr : O_Record_Aggr_List; + Res_Aggr : O_Record_Aggr_List; + Res : O_Cnode; + Str_Type : O_Tnode; + Type_Info : Type_Info_Acc; + Index_Type_Info : Type_Info_Acc; + Len : Int32; + Val : Var_Acc; + Bound : Var_Acc; + begin + Lit_Type := Get_Type (Str); + Type_Info := Get_Info (Get_Base_Type (Lit_Type)); + + -- Create the string value. + Len := Get_String_Length (Str); + Str_Type := New_Constrained_Array_Type + (Type_Info.T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + + Start_Array_Aggr (Val_Aggr, Str_Type); + Element_Type := Get_Element_Subtype (Lit_Type); + Translate_Static_String_Literal_Inner (Val_Aggr, Str, Element_Type); + Finish_Array_Aggr (Val_Aggr, Res); + + Val := Create_Global_Const + (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res); + + -- Create the string bound. + Index_Type := Get_First_Element (Get_Index_Subtype_List (Lit_Type)); + Index_Type_Info := Get_Info (Index_Type); + 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); + Free_Var (Val); + Free_Var (Bound); + return Res; + end Translate_Static_Unconstrained_String_Literal; + -- Only for Strings of STD.Character. function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id) return O_Cnode @@ -13284,7 +13399,13 @@ package body Translation is begin case Get_Kind (Str) is when Iir_Kind_String_Literal => - Res := Translate_Static_String_Literal (Str); + if Get_Kind (Get_Type (Str)) + = Iir_Kind_Array_Subtype_Definition + then + Res := Translate_Static_String_Literal (Str); + else + Res := Translate_Static_Unconstrained_String_Literal (Str); + end if; when Iir_Kind_Bit_String_Literal => Res := Translate_Static_Bit_String_Literal (Str); when Iir_Kind_Simple_Aggregate => @@ -25325,9 +25446,22 @@ package body Translation is 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_Signal_Interface_Declaration - | Iir_Kind_Constant_Declaration | Iir_Kind_Constant_Interface_Declaration | Iir_Kind_Variable_Declaration | Iir_Kind_File_Declaration |