diff options
Diffstat (limited to 'simulate/file_operation.adb')
| -rw-r--r-- | simulate/file_operation.adb | 341 |
1 files changed, 0 insertions, 341 deletions
diff --git a/simulate/file_operation.adb b/simulate/file_operation.adb deleted file mode 100644 index 33700fd..0000000 --- a/simulate/file_operation.adb +++ /dev/null @@ -1,341 +0,0 @@ --- 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; |