-- Create declarations for synthesis. -- Copyright (C) 2017 Tristan Gingold -- -- This file is part of GHDL. -- -- This program 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 of the License, or -- (at your option) any later version. -- -- This program 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 this program. If not, see . with Types; use Types; with Files_Map; with Name_Table; with Vhdl.Errors; use Vhdl.Errors; with Grt.Types; use Grt.Types; with Grt.Vhdl_Types; use Grt.Vhdl_Types; with Grt.Files_Operations; use Grt.Files_Operations; with Grt.Stdio; with Elab.Memtype; use Elab.Memtype; with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes; with Elab.Vhdl_Expr; use Elab.Vhdl_Expr; with Elab.Vhdl_Errors; use Elab.Vhdl_Errors; package body Elab.Vhdl_Files is -- Variables to store the search path. Current_Unit : Node := Null_Node; Current_Pfx_Len : Integer := -1; Current_Pfx_Id : Name_Id := No_Name_Id; -- Representation of file name compatible with C (so NUL terminated). subtype C_File_Name is String (1 .. 1025); procedure File_Error (Loc : Node; Status : Op_Status); pragma No_Return (File_Error); procedure File_Error (Loc : Node; Status : Op_Status) is begin pragma Assert (Status /= Op_Ok); Error_Msg_Elab (+Loc, "file operation failed"); raise File_Execution_Error; end File_Error; -- VAL represents a string, so an array of characters. procedure Convert_String (Val : Valtyp; Res : out String) is Vtyp : constant Type_Acc := Val.Typ; Vlen : constant Uns32 := Vtyp.Abound.Len; begin pragma Assert (Vtyp.Kind = Type_Array); pragma Assert (Vtyp.Arr_El.Kind = Type_Discrete); pragma Assert (Vtyp.Arr_El.W in 7 .. 8); -- Could be 7 in vhdl87 pragma Assert (Vtyp.Alast); pragma Assert (Vtyp.Abound.Len = Res'Length); for I in 1 .. Vlen loop Res (Res'First + Natural (I - 1)) := Character'Val (Read_U8 (Val.Val.Mem + Size_Type (I - 1))); end loop; end Convert_String; -- Convert filename VAL to RES + LEN. procedure Convert_File_Name (Val : Valtyp; Res : out C_File_Name; Len : out Natural; Status : out Op_Status) is Name : constant Valtyp := Strip_Alias_Const (Val); pragma Unreferenced (Val); begin Len := Natural (Name.Typ.Abound.Len); if Len >= Res'Length - 1 then Status := Op_Filename_Error; return; end if; Convert_String (Name, Res (1 .. Len)); Res (Len + 1) := Grt.Types.NUL; Status := Op_Ok; end Convert_File_Name; procedure Set_Design_Unit (Unit : Node) is begin Current_Unit := Unit; Current_Pfx_Id := No_Name_Id; end Set_Design_Unit; function Synth_Open (Name : Ghdl_C_String; Mode : Ghdl_C_String) return Grt.Stdio.FILEs is use Grt.Stdio; Res : FILEs; begin -- Try to open the file using the name given. Res := fopen (To_Address (Name), To_Address (Mode)); if Res /= NULL_Stream then -- File found. return Res; end if; -- Return now if the search path is not used: -- mode is not read, or -- no search path given. if Mode (1) /= 'r' then return Res; end if; if Current_Unit = Null_Node then return NULL_Stream; end if; -- The search path is given by the current unit. Extract it from the -- filename (and cache the result). if Current_Pfx_Id = No_Name_Id then declare use Files_Map; use Name_Table; Loc : Location_Type; Sfe : Source_File_Entry; Name_Len : Natural; Name_Ptr : Thin_String_Ptr; begin Loc := Get_Location (Current_Unit); Sfe := Location_To_File (Loc); Current_Pfx_Id := Get_File_Name (Sfe); Name_Len := Get_Name_Length (Current_Pfx_Id); Name_Ptr := Get_Name_Ptr (Current_Pfx_Id); Current_Pfx_Len := 0; for I in reverse 1 .. Name_Len loop if Name_Ptr (I) = '/' or else Name_Ptr (I) = '\' then Current_Pfx_Len := I; exit; end if; end loop; end; end if; -- No prefix. if Current_Pfx_Len = 0 then return NULL_Stream; end if; -- Try with prefix + name. declare use Name_Table; Name_Len : constant Natural := strlen (Name); Pfx : constant Thin_String_Ptr := Get_Name_Ptr (Current_Pfx_Id); Name2 : String (1 .. Name_Len + Current_Pfx_Len + 1); begin Name2 (1 .. Current_Pfx_Len) := Pfx (1 .. Current_Pfx_Len); Name2 (Current_Pfx_Len + 1 .. Current_Pfx_Len + Name_Len) := Name (1 .. Name_Len); Name2 (Name2'Last) := NUL; Res := fopen (Name2'Address, To_Address (Mode)); end; return Res; end Synth_Open; function Elaborate_File_Declaration (Syn_Inst : Synth_Instance_Acc; Decl : Node) return File_Index is File_Type : constant Node := Get_Type (Decl); External_Name : constant Node := Get_File_Logical_Name (Decl); Open_Kind : constant Node := Get_File_Open_Kind (Decl); File_Name : Valtyp; C_Name : C_File_Name; C_Name_Len : Natural; Mode : Valtyp; F : File_Index; File_Mode : Ghdl_I32; Status : Op_Status; begin -- Use our own handler to open a file. -- We need to do this assignment only once, but it is simpler to do it -- here. Open_Handler := Synth_Open'Access; if Get_Text_File_Flag (File_Type) then F := Ghdl_Text_File_Elaborate; else declare File_Typ : Type_Acc; Cstr : Ghdl_C_String; begin File_Typ := Get_Subtype_Object (Syn_Inst, File_Type); if File_Typ.File_Signature = null then Cstr := null; else Cstr := To_Ghdl_C_String (File_Typ.File_Signature.all'Address); end if; F := Ghdl_File_Elaborate (Cstr); end; end if; -- LRM93 4.3.1.4 -- If file open information is not included in a given file declaration, -- then the file declared by the declaration is not opened when the file -- declaration is elaborated. if External_Name = Null_Node then return F; end if; File_Name := Exec_Expression_With_Basetype (Syn_Inst, External_Name); if Open_Kind /= Null_Node then Mode := Exec_Expression (Syn_Inst, Open_Kind); File_Mode := Ghdl_I32 (Read_Discrete (Mode)); else case Get_Mode (Decl) is when Iir_In_Mode => File_Mode := Read_Mode; when Iir_Out_Mode => File_Mode := Write_Mode; when others => raise Internal_Error; end case; end if; Convert_File_Name (File_Name, C_Name, C_Name_Len, Status); if Status = Op_Ok then if Get_Text_File_Flag (File_Type) then Ghdl_Text_File_Open (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); else Ghdl_File_Open (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); end if; end if; if Status /= Op_Ok then if Status = Op_Name_Error then Error_Msg_Elab (+Decl, "cannot open file: " & C_Name (1 .. C_Name_Len)); Set_Error (Syn_Inst); else File_Error (Decl, Status); end if; end if; return F; end Elaborate_File_Declaration; function Endfile (F : File_Index; Loc : Node) return Boolean is Status : Op_Status; begin Ghdl_File_Endfile (F, Status); if Status = Op_Ok then return False; elsif Status = Op_End_Of_File then return True; else File_Error (Loc, Status); end if; end Endfile; -- Declaration -- procedure FILE_OPEN (file F : FT; -- External_Name : String; -- Open_Kind : File_Open_Kind); procedure Synth_File_Open (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) is Inters : constant Node := Get_Interface_Declaration_Chain (Imp); F : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; Param2 : constant Node := Get_Chain (Inters); File_Name : constant Valtyp := Get_Value (Syn_Inst, Param2); Param3 : constant Node := Get_Chain (Param2); Open_Kind : constant Valtyp := Get_Value (Syn_Inst, Param3); C_Name : C_File_Name; C_Name_Len : Natural; File_Mode : Ghdl_I32; Status : Op_Status; begin Convert_File_Name (File_Name, C_Name, C_Name_Len, Status); if Status = Op_Ok then File_Mode := Ghdl_I32 (Read_Discrete (Open_Kind)); if Get_Text_File_Flag (Get_Type (Inters)) then Ghdl_Text_File_Open (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); else Ghdl_File_Open (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); end if; end if; if Status /= Op_Ok then if Status = Op_Name_Error then Error_Msg_Elab (+Loc, "cannot open file: " & C_Name (1 .. C_Name_Len)); raise File_Execution_Error; else File_Error (Loc, Status); end if; end if; end Synth_File_Open; -- Declaration -- procedure FILE_OPEN (Status : out FILE_OPEN_STATUS; -- file F : FT; -- External_Name : String; -- Open_Kind : File_Open_Kind); procedure Synth_File_Open_Status (Syn_Inst : Synth_Instance_Acc; Imp : Node) is Inters : constant Node := Get_Interface_Declaration_Chain (Imp); Ostatus : constant Valtyp := Get_Value (Syn_Inst, Inters); Param2 : constant Node := Get_Chain (Inters); F : constant File_Index := Get_Value (Syn_Inst, Param2).Val.File; Param3 : constant Node := Get_Chain (Param2); File_Name : constant Valtyp := Get_Value (Syn_Inst, Param3); Param4 : constant Node := Get_Chain (Param3); Open_Kind : constant Valtyp := Get_Value (Syn_Inst, Param4); C_Name : C_File_Name; C_Name_Len : Natural; File_Mode : Ghdl_I32; Status : Op_Status; Vstatus : Ghdl_I32; begin Convert_File_Name (File_Name, C_Name, C_Name_Len, Status); if Status = Op_Ok then File_Mode := Ghdl_I32 (Read_Discrete (Open_Kind)); if Get_Text_File_Flag (Get_Type (Param2)) then Ghdl_Text_File_Open (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); else Ghdl_File_Open (F, File_Mode, To_Ghdl_C_String (C_Name'Address), Status); end if; end if; case Status is when Op_Ok => Vstatus := Open_Ok; when Op_Status_Error => Vstatus := Status_Error; when Op_Mode_Error => Vstatus := Mode_Error; when Op_Name_Error | Op_Signature_Error | Op_Filename_Error => Vstatus := Name_Error; when Op_End_Of_File | Op_Ungetc_Error | Op_Not_Open | Op_Close_Error | Op_Read_Write_File | Op_Write_Read_File | Op_Read_Error | Op_Write_Error | Op_Bad_Index | Op_Bad_Mode | Op_Not_Closed => raise File_Execution_Error; end case; if Is_Static (Ostatus.Val) then -- Avoid error storm. Write_Discrete (Ostatus, Int64 (Vstatus)); end if; end Synth_File_Open_Status; -- Declaration -- procedure FILE_CLOSE (file F : FT); procedure Synth_File_Close (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) is Inters : constant Node := Get_Interface_Declaration_Chain (Imp); F : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; Status : Op_Status; begin if Get_Text_File_Flag (Get_Type (Inters)) then Ghdl_Text_File_Close (F, Status); else Ghdl_File_Close (F, Status); end if; if Status /= Op_Ok then File_Error (Loc, Status); end if; end Synth_File_Close; procedure Synth_File_Flush (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) is Inters : constant Node := Get_Interface_Declaration_Chain (Imp); F : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; Status : Op_Status; begin Ghdl_File_Flush (F, Status); if Status /= Op_Ok then File_Error (Loc, Status); end if; end Synth_File_Flush; -- Declaration: -- procedure untruncated_text_read --!V87 -- (file f : text; str : out string; len : out natural); --!V87 procedure Synth_Untruncated_Text_Read (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) is Inters : constant Node := Get_Interface_Declaration_Chain (Imp); File : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; Param2 : constant Node := Get_Chain (Inters); Str : constant Valtyp := Get_Value (Syn_Inst, Param2); Param3 : constant Node := Get_Chain (Param2); Param_Len : constant Valtyp := Get_Value (Syn_Inst, Param3); Buf : String (1 .. Natural (Str.Typ.Abound.Len)); Len : Std_Integer; Status : Op_Status; begin Len := Std_Integer (Buf'Last); Ghdl_Untruncated_Text_Read (File, To_Ghdl_C_String (Buf'Address), Len, Status); if Status /= Op_Ok then File_Error (Loc, Status); end if; for I in 1 .. Natural (Len) loop Write_U8 (Str.Val.Mem + Size_Type (I - 1), Character'Pos (Buf (I))); end loop; Write_Discrete (Param_Len, Int64 (Len)); end Synth_Untruncated_Text_Read; procedure File_Read_Value (File : File_Index; Val : Memtyp; Loc : Node) is Status : Op_Status; begin case Val.Typ.Kind is when Type_Discrete | Type_Bit | Type_Logic | Type_Float => Ghdl_Read_Scalar (File, Ghdl_Ptr (Val.Mem.all'Address), Ghdl_Index_Type (Val.Typ.Sz), Status); if Status /= Op_Ok then File_Error (Loc, Status); end if; when Type_Vector | Type_Array => declare El_Typ : constant Type_Acc := Get_Array_Element (Val.Typ); Off : Size_Type; begin Off := 0; for I in 1 .. Get_Bound_Length (Val.Typ) loop File_Read_Value (File, (El_Typ, Val.Mem + Off), Loc); Off := Off + El_Typ.Sz; end loop; end; when Type_Record => for I in Val.Typ.Rec.E'Range loop File_Read_Value (File, (Val.Typ.Rec.E (I).Typ, Val.Mem + Val.Typ.Rec.E (I).Offs.Mem_Off), Loc); end loop; when Type_Unbounded_Record | Type_Unbounded_Array | Type_Unbounded_Vector | Type_Protected | Type_Slice | Type_File | Type_Access => raise Internal_Error; end case; end File_Read_Value; procedure Synth_File_Read (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) is Inters : constant Node := Get_Interface_Declaration_Chain (Imp); File : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; Param2 : constant Node := Get_Chain (Inters); Value : constant Valtyp := Get_Value (Syn_Inst, Param2); begin File_Read_Value (File, (Value.Typ, Value.Val.Mem), Loc); end Synth_File_Read; procedure File_Write_Value (File : File_Index; Val : Memtyp; Loc : Node) is Status : Op_Status; begin case Val.Typ.Kind is when Type_Discrete | Type_Bit | Type_Logic | Type_Float => Ghdl_Write_Scalar (File, Ghdl_Ptr (Val.Mem.all'Address), Ghdl_Index_Type (Val.Typ.Sz), Status); if Status /= Op_Ok then File_Error (Loc, Status); end if; when Type_Vector | Type_Array => declare El_Typ : constant Type_Acc := Get_Array_Element (Val.Typ); Off : Size_Type; begin Off := 0; for I in 1 .. Get_Bound_Length (Val.Typ) loop File_Write_Value (File, (El_Typ, Val.Mem + Off), Loc); Off := Off + El_Typ.Sz; end loop; end; when Type_Record => for I in Val.Typ.Rec.E'Range loop File_Write_Value (File, (Val.Typ.Rec.E (I).Typ, Val.Mem + Val.Typ.Rec.E (I).Offs.Mem_Off), Loc); end loop; when Type_Unbounded_Record | Type_Unbounded_Array | Type_Unbounded_Vector | Type_Protected | Type_Slice | Type_File | Type_Access => raise Internal_Error; end case; end File_Write_Value; function Dir_To_Dir (Dir : Direction_Type) return Ghdl_Dir_Type is begin case Dir is when Dir_To => return Grt.Vhdl_Types.Dir_To; when Dir_Downto => return Grt.Vhdl_Types.Dir_Downto; end case; end Dir_To_Dir; procedure File_Write_Text (File : File_Index; Val : Memtyp; Loc : Node) is B : Bound_Type; Status : Op_Status; Str : Std_String; Bnd : Std_String_Bound; begin B := Val.Typ.Abound; Bnd.Dim_1 := (Left => Ghdl_I32 (B.Left), Right => Ghdl_I32 (B.Right), Dir => Dir_To_Dir (B.Dir), Length => Ghdl_Index_Type (B.Len)); Str := (Base => To_Std_String_Basep (Val.Mem.all'Address), Bounds => To_Std_String_Boundp (Bnd'Address)); Ghdl_Text_Write (File, To_Std_String_Ptr (Str'Address), Status); if Status /= Op_Ok then File_Error (Loc, Status); end if; end File_Write_Text; procedure Synth_File_Write (Syn_Inst : Synth_Instance_Acc; Imp : Node; Loc : Node) is Inters : constant Node := Get_Interface_Declaration_Chain (Imp); Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (Inters)); File : constant File_Index := Get_Value (Syn_Inst, Inters).Val.File; Param2 : constant Node := Get_Chain (Inters); Value : constant Valtyp := Get_Value (Syn_Inst, Param2); begin if Is_Text then File_Write_Text (File, (Value.Typ, Value.Val.Mem), Loc); else File_Write_Value (File, (Value.Typ, Value.Val.Mem), Loc); end if; end Synth_File_Write; end Elab.Vhdl_Files;