diff options
Diffstat (limited to 'src/simulate/file_operation.adb')
| -rw-r--r-- | src/simulate/file_operation.adb | 341 |
1 files changed, 341 insertions, 0 deletions
diff --git a/src/simulate/file_operation.adb b/src/simulate/file_operation.adb new file mode 100644 index 000000000..33700fd6c --- /dev/null +++ b/src/simulate/file_operation.adb @@ -0,0 +1,341 @@ +-- File operations for interpreter +-- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Annotations; use Annotations; +with Execution; use Execution; +with Debugger; use Debugger; +with Grt.Types; use Grt.Types; +with Grt_Interface; use Grt_Interface; + +package body File_Operation is + -- Open a file. + -- See LRM93 3.4.1 for definition of arguments. + -- IS_TEXT is true if the file format is text. + -- The purpose of the IS_TEXT is to allow a text implementation of file + -- type TEXT, defined in std.textio. + procedure File_Open (Status : out Ghdl_I32; + File : Iir_Value_Literal_Acc; + External_Name : Iir_Value_Literal_Acc; + Mode : Ghdl_I32; + Is_Text : Boolean; + Return_Status : Boolean) + is + Name_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (External_Name.Bounds.D (1).Length); + Name_Str : aliased Std_String_Uncons (1 .. Name_Len); + Name_Bnd : aliased Std_String_Bound := Build_Bound (External_Name); + Name : aliased Std_String := (To_Std_String_Basep (Name_Str'Address), + To_Std_String_Boundp (Name_Bnd'Address)); + begin + -- Convert the string to an Ada string. + for I in External_Name.Val_Array.V'Range loop + Name_Str (Name_Str'First + Ghdl_Index_Type (I - 1)) := + Character'Val (External_Name.Val_Array.V (I).E32); + end loop; + + if Is_Text then + if Return_Status then + Status := Ghdl_Text_File_Open_Status + (File.File, Mode, Name'Unrestricted_Access); + else + Ghdl_Text_File_Open (File.File, Mode, Name'Unrestricted_Access); + Status := Open_Ok; + end if; + else + if Return_Status then + Status := Ghdl_File_Open_Status + (File.File, Mode, Name'Unrestricted_Access); + else + Ghdl_File_Open (File.File, Mode, Name'Unrestricted_Access); + Status := Open_Ok; + end if; + end if; + end File_Open; + + -- Open a file. + procedure File_Open (File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir) + is + pragma Unreferenced (Stmt); + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); + File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E32); + Status : Ghdl_I32; + begin + File_Open (Status, File, Name, File_Mode, Is_Text, False); + if Status /= Open_Ok then + raise Program_Error; + end if; + end File_Open; + + procedure File_Open_Status (Status : Iir_Value_Literal_Acc; + File : Iir_Value_Literal_Acc; + Name : Iir_Value_Literal_Acc; + Mode : Iir_Value_Literal_Acc; + File_Decl : Iir; + Stmt : Iir) + is + pragma Unreferenced (Stmt); + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl)); + File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E32); + R_Status : Ghdl_I32; + begin + File_Open (R_Status, File, Name, File_Mode, Is_Text, True); + Status.E32 := Ghdl_E32 (R_Status); + end File_Open_Status; + + function Elaborate_File_Declaration + (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration) + return Iir_Value_Literal_Acc + is + Def : constant Iir := Get_Type (Decl); + External_Name : Iir; + File_Name: Iir_Value_Literal_Acc; + Is_Text : constant Boolean := Get_Text_File_Flag (Def); + File_Mode : Ghdl_I32; + Res : Iir_Value_Literal_Acc; + Status : Ghdl_I32; + Mode : Iir_Value_Literal_Acc; + begin + if Is_Text then + Res := Create_File_Value (Ghdl_Text_File_Elaborate); + else + declare + Sig : constant String_Acc := Get_Info (Def).File_Signature; + Cstr : Ghdl_C_String; + begin + if Sig = null then + Cstr := null; + else + Cstr := To_Ghdl_C_String (Sig.all'Address); + end if; + Res := Create_File_Value (Ghdl_File_Elaborate (Cstr)); + end; + end if; + + External_Name := Get_File_Logical_Name (Decl); + + -- 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_Iir then + return Res; + end if; + + File_Name := Execute_Expression (Instance, External_Name); + if Get_File_Open_Kind (Decl) /= Null_Iir then + Mode := Execute_Expression (Instance, Get_File_Open_Kind (Decl)); + File_Mode := Ghdl_I32 (Mode.E32); + 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; + File_Open (Status, Res, File_Name, File_Mode, Is_Text, False); + return Res; + end Elaborate_File_Declaration; + + procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir) is + pragma Unreferenced (Stmt); + begin + Ghdl_Text_File_Close (File.File); + end File_Close_Text; + + procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir) is + pragma Unreferenced (Stmt); + begin + Ghdl_File_Close (File.File); + end File_Close_Binary; + + procedure File_Destroy_Text (File : Iir_Value_Literal_Acc) is + begin + Ghdl_Text_File_Finalize (File.File); + end File_Destroy_Text; + + procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Finalize (File.File); + end File_Destroy_Binary; + + + procedure Write_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) is + begin + case Value.Kind is + when Iir_Value_B1 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_E32 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); + when Iir_Value_F64 => + Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); + when Iir_Value_Array => + for I in Value.Bounds.D'Range loop + Ghdl_Write_Scalar + (File.File, Ghdl_Ptr (Value.Bounds.D (I).Length'Address), 4); + end loop; + for I in Value.Val_Array.V'Range loop + Write_Binary (File, Value.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + Write_Binary (File, Value.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Write_Binary; + + procedure Write_Text (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) + is + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Value.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + begin + -- Convert the string to an Ada string. + for I in Value.Val_Array.V'Range loop + Val_Str (Val_Str'First + Ghdl_Index_Type (I - 1)) := + Character'Val (Value.Val_Array.V (I).E32); + end loop; + + Ghdl_Text_Write (File.File, Val'Unrestricted_Access); + end Write_Text; + + function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir) + return Boolean + is + pragma Unreferenced (Stmt); + begin + return Grt.Files.Ghdl_File_Endfile (File.File); + end Endfile; + + procedure Read_Length_Text (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Value.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Value); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + Len : Std_Integer; + begin + Len := Ghdl_Text_Read_Length (File.File, Val'Unrestricted_Access); + for I in 1 .. Len loop + Value.Val_Array.V (Iir_Index32 (I)).E32 := + Character'Pos (Val_Str (Ghdl_Index_Type (I))); + end loop; + Length.I64 := Ghdl_I64 (Len); + end Read_Length_Text; + + procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc; + Str : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Res : Ghdl_Untruncated_Text_Read_Result; + Val_Len : constant Ghdl_Index_Type := + Ghdl_Index_Type (Str.Bounds.D (1).Length); + Val_Str : aliased Std_String_Uncons (1 .. Val_Len); + Val_Bnd : aliased Std_String_Bound := Build_Bound (Str); + Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address), + To_Std_String_Boundp (Val_Bnd'Address)); + begin + Ghdl_Untruncated_Text_Read + (Res'Unrestricted_Access, File.File, Val'Unrestricted_Access); + for I in 1 .. Res.Len loop + Str.Val_Array.V (Iir_Index32 (I)).E32 := + Character'Pos (Val_Str (Ghdl_Index_Type (I))); + end loop; + Length.I64 := Ghdl_I64 (Res.Len); + end Untruncated_Text_Read; + + procedure Read_Binary (File: Iir_Value_Literal_Acc; + Value: Iir_Value_Literal_Acc) + is + begin + case Value.Kind is + when Iir_Value_B1 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1); + when Iir_Value_I64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8); + when Iir_Value_E32 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4); + when Iir_Value_F64 => + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8); + when Iir_Value_Array => + for I in Value.Bounds.D'Range loop + declare + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + if Len /= Value.Bounds.D (I).Length then + Error_Msg_Constraint (Null_Iir); -- FIXME: loc + end if; + end; + end loop; + for I in Value.Val_Array.V'Range loop + Read_Binary (File, Value.Val_Array.V (I)); + end loop; + when Iir_Value_Record => + for I in Value.Val_Record.V'Range loop + Read_Binary (File, Value.Val_Record.V (I)); + end loop; + when others => + raise Internal_Error; + end case; + end Read_Binary; + + procedure Read_Length_Binary (File : Iir_Value_Literal_Acc; + Value : Iir_Value_Literal_Acc; + Length : Iir_Value_Literal_Acc) + is + Len : Iir_Index32; + begin + Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4); + for I in 1 .. Len loop + if I <= Value.Bounds.D (1).Length then + Read_Binary (File, Value.Val_Array.V (I)); + else + -- FIXME: for empty arrays ?? + -- Lose_Binary (File, Value.Val_Array (0)); + raise Internal_Error; + end if; + end loop; + Length.I64 := Ghdl_I64 (Len); + end Read_Length_Binary; + + procedure Flush (File : Iir_Value_Literal_Acc) is + begin + Ghdl_File_Flush (File.File); + end Flush; +end File_Operation; |