diff options
Diffstat (limited to 'src/translate/grt/grt-files.adb')
| -rw-r--r-- | src/translate/grt/grt-files.adb | 452 |
1 files changed, 0 insertions, 452 deletions
diff --git a/src/translate/grt/grt-files.adb b/src/translate/grt/grt-files.adb deleted file mode 100644 index 30d51cf..0000000 --- a/src/translate/grt/grt-files.adb +++ /dev/null @@ -1,452 +0,0 @@ --- GHDL Run Time (GRT) - VHDL files subprograms. --- 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. --- --- As a special exception, if other files instantiate generics from this --- unit, or you link this unit with other files to produce an executable, --- this unit does not by itself cause the resulting executable to be --- covered by the GNU General Public License. This exception does not --- however invalidate any other reasons why the executable file might be --- covered by the GNU Public License. -with Grt.Errors; use Grt.Errors; -with Grt.Stdio; use Grt.Stdio; -with Grt.C; use Grt.C; -with Grt.Table; -with System; use System; -pragma Elaborate_All (Grt.Table); - -package body Grt.Files is - subtype C_Files is Grt.Stdio.FILEs; - - Auto_Flush : constant Boolean := False; - - type File_Entry_Type is record - Stream : C_Files; - Signature : Ghdl_C_String; - Is_Text : Boolean; - Is_Alive : Boolean; - end record; - - package Files_Table is new Grt.Table - (Table_Component_Type => File_Entry_Type, - Table_Index_Type => Ghdl_File_Index, - Table_Low_Bound => 1, - Table_Initial => 2); - - function Get_File (Index : Ghdl_File_Index) return C_Files - is - begin - if Index not in Files_Table.First .. Files_Table.Last then - Internal_Error ("get_file: bad file index"); - end if; - return Files_Table.Table (Index).Stream; - end Get_File; - - procedure Check_File_Mode (Index : Ghdl_File_Index; Is_Text : Boolean) - is - begin - if Files_Table.Table (Index).Is_Text /= Is_Text then - Internal_Error ("check_file_mode: bad file mode"); - end if; - end Check_File_Mode; - - function Create_File (Is_Text : Boolean; Sig : Ghdl_C_String) - return Ghdl_File_Index is - begin - Files_Table.Append ((Stream => NULL_Stream, - Signature => Sig, - Is_Text => Is_Text, - Is_Alive => True)); - return Files_Table.Last; - end Create_File; - - procedure Destroy_File (Is_Text : Boolean; Index : Ghdl_File_Index) is - begin - if Get_File (Index) /= NULL_Stream then - Internal_Error ("destroy_file"); - end if; - Check_File_Mode (Index, Is_Text); - Files_Table.Table (Index).Is_Alive := False; - if Index = Files_Table.Last then - while Files_Table.Last >= Files_Table.First - and then Files_Table.Table (Files_Table.Last).Is_Alive = False - loop - Files_Table.Decrement_Last; - end loop; - end if; - end Destroy_File; - - procedure File_Error (File : Ghdl_File_Index) - is - pragma Unreferenced (File); - begin - Internal_Error ("file: IO error"); - end File_Error; - - function Ghdl_Text_File_Elaborate return Ghdl_File_Index is - begin - return Create_File (True, null); - end Ghdl_Text_File_Elaborate; - - function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index - is - begin - return Create_File (False, Sig); - end Ghdl_File_Elaborate; - - procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index) is - begin - Destroy_File (True, File); - end Ghdl_Text_File_Finalize; - - procedure Ghdl_File_Finalize (File : Ghdl_File_Index) is - begin - Destroy_File (False, File); - end Ghdl_File_Finalize; - - function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean - is - Stream : C_Files; - C : int; - begin - Stream := Get_File (File); - if feof (Stream) /= 0 then - return True; - end if; - C := fgetc (Stream); - if C < 0 then - return True; - end if; - if ungetc (C, Stream) /= C then - Error ("internal error: ungetc"); - end if; - return False; - end Ghdl_File_Endfile; - - Sig_Header : constant String := "#GHDL-BINARY-FILE-0.0" & Nl; - - function File_Open (File : Ghdl_File_Index; - Mode : Ghdl_I32; - Str : Std_String_Ptr) - return Ghdl_I32 - is - Name : String (1 .. Integer (Str.Bounds.Dim_1.Length) + 1); - Str_Mode : String (1 .. 3); - F : C_Files; - Sig : Ghdl_C_String; - Sig_Len : Natural; - begin - F := Get_File (File); - - if F /= NULL_Stream then - -- File was already open. - return Status_Error; - end if; - - -- Copy file name and convert it to a C string (NUL terminated). - for I in 1 .. Str.Bounds.Dim_1.Length loop - Name (Natural (I)) := Str.Base (I - 1); - end loop; - Name (Name'Last) := NUL; - - if Name = "STD_INPUT" & NUL then - if Mode /= Read_Mode then - return Mode_Error; - end if; - F := stdin; - elsif Name = "STD_OUTPUT" & NUL then - if Mode /= Write_Mode then - return Mode_Error; - end if; - F := stdout; - else - case Mode is - when Read_Mode => - Str_Mode (1) := 'r'; - when Write_Mode => - Str_Mode (1) := 'w'; - when Append_Mode => - Str_Mode (1) := 'a'; - when others => - -- Bad mode, cannot happen. - Internal_Error ("file_open: bad open mode"); - end case; - if Files_Table.Table (File).Is_Text then - Str_Mode (2) := NUL; - else - Str_Mode (2) := 'b'; - Str_Mode (3) := NUL; - end if; - F := fopen (Name'Address, Str_Mode'Address); - if F = NULL_Stream then - return Name_Error; - end if; - end if; - Sig := Files_Table.Table (File).Signature; - if Sig /= null then - Sig_Len := strlen (Sig); - case Mode is - when Write_Mode => - if fwrite (Sig_Header'Address, 1, Sig_Header'Length, F) - /= Sig_Header'Length - then - File_Error (File); - end if; - if fwrite (Sig (1)'Address, 1, size_t (Sig_Len), F) - /= size_t (Sig_Len) - then - File_Error (File); - end if; - when Read_Mode => - declare - Hdr : String (1 .. Sig_Header'Length); - Sig_Buf : String (1 .. Sig_Len); - begin - if fread (Hdr'Address, 1, Hdr'Length, F) /= Hdr'Length then - File_Error (File); - end if; - if Hdr /= Sig_Header then - File_Error (File); - end if; - if fread (Sig_Buf'Address, 1, Sig_Buf'Length, F) - /= Sig_Buf'Length - then - File_Error (File); - end if; - if Sig_Buf /= Sig (1 .. Sig_Len) then - File_Error (File); - end if; - end; - when Append_Mode => - null; - when others => - null; - end case; - end if; - Files_Table.Table (File).Stream := F; - return Open_Ok; - end File_Open; - - procedure Ghdl_Text_File_Open - (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) - is - Res : Ghdl_I32; - begin - Check_File_Mode (File, True); - - Res := File_Open (File, Mode, Str); - - if Res /= Open_Ok then - Error_C ("open: cannot open text file "); - Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); - Error_E; - end if; - end Ghdl_Text_File_Open; - - procedure Ghdl_File_Open - (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) - is - Res : Ghdl_I32; - begin - Check_File_Mode (File, False); - - Res := File_Open (File, Mode, Str); - - if Res /= Open_Ok then - Error_C ("open: cannot open file "); - Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); - Error_E; - end if; - end Ghdl_File_Open; - - function Ghdl_Text_File_Open_Status - (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) - return Ghdl_I32 - is - begin - Check_File_Mode (File, True); - return File_Open (File, Mode, Str); - end Ghdl_Text_File_Open_Status; - - function Ghdl_File_Open_Status - (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) - return Ghdl_I32 - is - begin - Check_File_Mode (File, False); - return File_Open (File, Mode, Str); - end Ghdl_File_Open_Status; - - procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr) - is - Res : C_Files; - R : size_t; - R1 : int; - pragma Unreferenced (R, R1); - begin - Res := Get_File (File); - Check_File_Mode (File, True); - if Res = NULL_Stream then - Error ("write to a non-opened file"); - end if; - -- FIXME: check mode. - R := fwrite (Str.Base (0)'Address, - size_t (Str.Bounds.Dim_1.Length), 1, Res); - -- FIXME: check r - -- Write '\n'. - R1 := fputc (Character'Pos (Nl), Res); - if Auto_Flush then - fflush (Res); - end if; - end Ghdl_Text_Write; - - procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; - Ptr : Ghdl_Ptr; - Length : Ghdl_Index_Type) - is - Res : C_Files; - R : size_t; - begin - Res := Get_File (File); - Check_File_Mode (File, False); - if Res = NULL_Stream then - Error ("write to a non-opened file"); - end if; - -- FIXME: check mode. - R := fwrite (System.Address (Ptr), size_t (Length), 1, Res); - if R /= 1 then - Error ("write_scalar failed"); - end if; - if Auto_Flush then - fflush (Res); - end if; - end Ghdl_Write_Scalar; - - procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; - Ptr : Ghdl_Ptr; - Length : Ghdl_Index_Type) - is - Res : C_Files; - R : size_t; - begin - Res := Get_File (File); - Check_File_Mode (File, False); - if Res = NULL_Stream then - Error ("write to a non-opened file"); - end if; - -- FIXME: check mode. - R := fread (System.Address (Ptr), size_t (Length), 1, Res); - if R /= 1 then - Error ("read_scalar failed"); - end if; - end Ghdl_Read_Scalar; - - function Ghdl_Text_Read_Length (File : Ghdl_File_Index; - Str : Std_String_Ptr) - return Std_Integer - is - Stream : C_Files; - C : int; - Len : Ghdl_Index_Type; - begin - Stream := Get_File (File); - Check_File_Mode (File, True); - Len := Str.Bounds.Dim_1.Length; - -- Read until EOL (or EOF). - -- Store as much as possible. - for I in Ghdl_Index_Type loop - C := fgetc (Stream); - if C < 0 then - Error ("read: end of file reached"); - return Std_Integer (I); - end if; - if I < Len then - Str.Base (I) := Character'Val (C); - end if; - -- End of line is '\n' or LF or character # 10. - if C = 10 then - return Std_Integer (I + 1); - end if; - end loop; - return 0; - end Ghdl_Text_Read_Length; - - procedure Ghdl_Untruncated_Text_Read - (Res : Ghdl_Untruncated_Text_Read_Result_Acc; - File : Ghdl_File_Index; - Str : Std_String_Ptr) - is - Stream : C_Files; - Len : int; - Idx : Ghdl_Index_Type; - begin - Stream := Get_File (File); - Check_File_Mode (File, True); - Len := int (Str.Bounds.Dim_1.Length); - if fgets (Str.Base (0)'Address, Len, Stream) = Null_Address then - Internal_Error ("ghdl_untruncated_text_read: end of file"); - end if; - -- Compute the length. - for I in Ghdl_Index_Type loop - if Str.Base (I) = NUL then - Idx := I; - exit; - end if; - end loop; - Res.Len := Std_Integer (Idx); - end Ghdl_Untruncated_Text_Read; - - procedure File_Close (File : Ghdl_File_Index; Is_Text : Boolean) - is - Stream : C_Files; - begin - Stream := Get_File (File); - Check_File_Mode (File, Is_Text); - -- LRM 3.4.1 File Operations - -- If F is not associated with an external file, then FILE_CLOSE has - -- no effect. - if Stream = NULL_Stream then - return; - end if; - if fclose (Stream) /= 0 then - Internal_Error ("file_close: fclose error"); - end if; - Files_Table.Table (File).Stream := NULL_Stream; - end File_Close; - - procedure Ghdl_Text_File_Close (File : Ghdl_File_Index) is - begin - File_Close (File, True); - end Ghdl_Text_File_Close; - - procedure Ghdl_File_Close (File : Ghdl_File_Index) is - begin - File_Close (File, False); - end Ghdl_File_Close; - - procedure Ghdl_File_Flush (File : Ghdl_File_Index) - is - Stream : C_Files; - begin - Stream := Get_File (File); - if Stream = NULL_Stream then - return; - end if; - fflush (Stream); - end Ghdl_File_Flush; -end Grt.Files; - |