diff options
| -rw-r--r-- | src/grt/grt-files_operations.adb | 633 | ||||
| -rw-r--r-- | src/grt/grt-files_operations.ads | 142 | ||||
| -rw-r--r-- | src/synth/synth-decls.adb | 7 | ||||
| -rw-r--r-- | src/synth/synth-decls.ads | 1 | ||||
| -rw-r--r-- | src/synth/synth-files_operations.adb | 159 | ||||
| -rw-r--r-- | src/synth/synth-files_operations.ads | 29 | ||||
| -rw-r--r-- | src/synth/synth-values.ads | 4 |
7 files changed, 973 insertions, 2 deletions
diff --git a/src/grt/grt-files_operations.adb b/src/grt/grt-files_operations.adb new file mode 100644 index 000000000..a9af35ade --- /dev/null +++ b/src/grt/grt-files_operations.adb @@ -0,0 +1,633 @@ +-- 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 Grt.Options; +with System; use System; +pragma Elaborate_All (Grt.Table); + +package body Grt.Files_Operations is + subtype C_Files is Grt.Stdio.FILEs; + + Auto_Flush : constant Boolean := False; + + type File_Entry_Type is record + -- The corresponding C stream. + Stream : C_Files; + + Signature : Ghdl_C_String; + + -- Open kind: r, a or w. + Kind : Character; + + Is_Text : Boolean; + + -- True if the file entry is used. + 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); + + -- Get the C stream for INDEX. + procedure Get_File + (Index : Ghdl_File_Index; Res : out C_Files; Status : out Op_Status) is + begin + if Index not in Files_Table.First .. Files_Table.Last then + Status := Op_Bad_Index; + else + Status := Op_Ok; + Res := Files_Table.Table (Index).Stream; + end if; + end Get_File; + + -- Assume INDEX is correct. + function Is_Open (Index : Ghdl_File_Index) return Boolean is + begin + return Files_Table.Table (Index).Stream /= NULL_Stream; + end Is_Open; + + -- Assume INDEX is correct. + function Get_Kind (Index : Ghdl_File_Index) return Character is + begin + return Files_Table.Table (Index).Kind; + end Get_Kind; + + procedure Check_File_Mode + (Index : Ghdl_File_Index; Is_Text : Boolean; Status : out Op_Status) is + begin + if Files_Table.Table (Index).Is_Text /= Is_Text then + Status := Op_Bad_Mode; + else + Status := Op_Ok; + end if; + end Check_File_Mode; + + procedure Check_Read + (Index : Ghdl_File_Index; Is_Text : Boolean; Status : out Op_Status) is + begin + Check_File_Mode (Index, Is_Text, Status); + if Status /= Op_Ok then + return; + end if; + + -- LRM08 5.5.2 File operations + -- It is an error if the access mode of the file object is write-only + -- or if the file object is not open. + if not Is_Open (Index) then + Status := Op_Not_Open; + return; + end if; + if Get_Kind (Index) /= 'r' then + Status := Op_Read_Write_File; + return; + end if; + + Status := Op_Ok; + end Check_Read; + + procedure Check_Write + (Index : Ghdl_File_Index; Is_Text : Boolean; Status : out Op_Status) is + begin + Check_File_Mode (Index, Is_Text, Status); + if Status /= Op_Ok then + return; + end if; + + -- LRM08 5.5.2 File operations + -- It is an error if the access mode of the file object is read-only + -- or if the file object is not open. + if not Is_Open (Index) then + Status := Op_Not_Open; + return; + end if; + if Get_Kind (Index) = 'r' then + Status := Op_Write_Read_File; + return; + end if; + + Status := Op_Ok; + end Check_Write; + + function Create_File + (Is_Text : Boolean; Kind : Character; Sig : Ghdl_C_String) + return Ghdl_File_Index is + begin + Files_Table.Append ((Stream => NULL_Stream, + Signature => Sig, + Kind => Kind, + Is_Text => Is_Text, + Is_Alive => True)); + return Files_Table.Last; + end Create_File; + + procedure Destroy_File + (Is_Text : Boolean; Index : Ghdl_File_Index; Status : out Op_Status) + is + Cstream : C_Files; + begin + Get_File (Index, Cstream, Status); + if Status /= Op_Ok then + return; + end if; + if Cstream /= NULL_Stream then + Status := Op_Not_Closed; + return; + end if; + Check_File_Mode (Index, Is_Text, Status); + if Status /= Op_Ok then + return; + end if; + + -- Cleanup. + 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; Status : out Op_Status) is + begin + Destroy_File (True, File, Status); + end Ghdl_Text_File_Finalize; + + procedure Ghdl_File_Finalize + (File : Ghdl_File_Index; Status : out Op_Status) is + begin + Destroy_File (False, File, Status); + end Ghdl_File_Finalize; + + procedure Ghdl_File_Endfile + (File : Ghdl_File_Index; Status : out Op_Status) + is + Stream : C_Files; + C : int; + begin + Get_File (File, Stream, Status); + if Status /= Op_Ok then + return; + end if; + + -- LRM93 3.4.1 File Operations + -- LRM08 5.5.2 File Operations + -- It is an error if ENDFILE is called on a file object that is not + -- open. + if Stream = NULL_Stream then + Status := Op_Not_Open; + return; + end if; + + -- Default: returns True. + Status := Op_End_Of_File; + + -- LRM93 3.4.1 File Operations + -- LRM08 5.5.2 File Operations + -- Function ENDFILE always returns TRUE for an open file object whose + -- access mode is write-only. + if Get_Kind (File) /= 'r' then + return; + end if; + + if feof (Stream) /= 0 then + return; + end if; + C := fgetc (Stream); + if C < 0 then + return; + end if; + if ungetc (C, Stream) /= C then + Status := Op_Ungetc_Error; + return; + end if; + + Status := Op_Ok; + return; + end Ghdl_File_Endfile; + + Sig_Header : constant String := "#GHDL-BINARY-FILE-0.0" & Nl; + + Std_Output_Name : constant String := "STD_OUTPUT" & NUL; + Std_Input_Name : constant String := "STD_INPUT" & NUL; + + procedure File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Name : Ghdl_C_String; + Status : out Op_Status) + is + Str_Mode : String (1 .. 3); + F : C_Files; + Sig : Ghdl_C_String; + Sig_Len : Natural; + Kind : Character; + begin + Get_File (File, F, Status); + if Status /= Op_Ok then + return; + end if; + + if F /= NULL_Stream then + -- File was already open. + Status := Op_Not_Closed; + return; + end if; + + case Mode is + when Read_Mode => + Kind := 'r'; + when Write_Mode => + Kind := 'w'; + when Append_Mode => + Kind := 'a'; + when others => + -- Bad mode, cannot happen. + Status := Op_Bad_Mode; + return; + end case; + + if Strcmp (Name, To_Ghdl_C_String (Std_Input_Name'Address)) = 0 then + if Mode /= Read_Mode then + Status := Op_Mode_Error; + return; + end if; + F := stdin; + elsif Strcmp (Name, To_Ghdl_C_String (Std_Output_Name'Address)) = 0 then + if Mode /= Write_Mode then + Status := Op_Mode_Error; + return; + end if; + F := stdout; + else + Str_Mode (1) := Kind; + 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 (To_Address (Name), Str_Mode'Address); + if F = NULL_Stream then + Status := Op_Name_Error; + return; + end if; + if Grt.Options.Unbuffered_Writes and Mode /= Read_Mode then + setbuf (F, NULL_voids); + 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; + Files_Table.Table (File).Kind := Kind; + + Status := Op_Ok; + end File_Open; + + procedure Ghdl_Text_File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Name : Ghdl_C_String; + Status : out Op_Status) is + begin + Check_File_Mode (File, True, Status); + if Status /= Op_Ok then + return; + end if; + + File_Open (File, Mode, Name, Status); + end Ghdl_Text_File_Open; + + procedure Ghdl_File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Name : Ghdl_C_String; + Status : out Op_Status) is + begin + Check_File_Mode (File, False, Status); + if Status /= Op_Ok then + return; + end if; + + File_Open (File, Mode, Name, Status); + end Ghdl_File_Open; + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr; + Status : out Op_Status) + is + Res : C_Files; + Len : size_t; + R : size_t; + begin + Get_File (File, Res, Status); + if Status /= Op_Ok then + return; + end if; + Check_Write (File, True, Status); + if Status /= Op_Ok then + return; + end if; + + Len := size_t (Str.Bounds.Dim_1.Length); + if Len = 0 then + Status := Op_Ok; + return; + end if; + + R := fwrite (Str.Base (0)'Address, Len, 1, Res); + if R /= 1 then + Status := Op_Write_Error; + return; + end if; + + if Auto_Flush then + fflush (Res); + end if; + + Status := Op_Ok; + end Ghdl_Text_Write; + + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type; + Status : out Op_Status) + is + Res : C_Files; + R : size_t; + begin + Get_File (File, Res, Status); + if Status /= Op_Ok then + return; + end if; + Check_Write (File, False, Status); + if Status /= Op_Ok then + return; + end if; + + R := fwrite (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Status := Op_Write_Error; + return; + end if; + if Auto_Flush then + fflush (Res); + end if; + + Status := Op_Ok; + end Ghdl_Write_Scalar; + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type; + Status : out Op_Status) + is + Res : C_Files; + R : size_t; + begin + Get_File (File, Res, Status); + if Status /= Op_Ok then + return; + end if; + Check_Read (File, False, Status); + if Status /= Op_Ok then + return; + end if; + + R := fread (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Status := Op_Read_Error; + return; + end if; + + Status := Op_Ok; + end Ghdl_Read_Scalar; + + procedure Ghdl_Text_Read_Length (File : Ghdl_File_Index; + Str : Std_String_Ptr; + Status : out Op_Status; + Length : out Std_Integer) + is + Stream : C_Files; + C : int; + Len : Ghdl_Index_Type; + begin + Length := 0; + Get_File (File, Stream, Status); + if Status /= Op_Ok then + return; + end if; + Check_Read (File, True, Status); + if Status /= Op_Ok then + return; + end if; + + 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 + Length := Std_Integer (I); + Status := Op_End_Of_File; + return; + 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 + Length := Std_Integer (I + 1); + Status := Op_Ok; + return; + end if; + end loop; + Length := 0; + Status := Op_Ok; + end Ghdl_Text_Read_Length; + + procedure Ghdl_Untruncated_Text_Read + (File : Ghdl_File_Index; Str : Std_String_Ptr; Len : out Std_Integer; + Status : out Op_Status) + is + Stream : C_Files; + Max_Len : int; + begin + Len := 0; + Get_File (File, Stream, Status); + if Status /= Op_Ok then + return; + end if; + Check_Read (File, True, Status); + if Status /= Op_Ok then + return; + end if; + + Max_Len := int (Str.Bounds.Dim_1.Length); + if fgets (Str.Base (0)'Address, Max_Len, Stream) = Null_Address then + Status := Op_End_Of_File; + return; + end if; + + -- Compute the length. + for I in Ghdl_Index_Type loop + if Str.Base (I) = NUL then + Len := Std_Integer (I); + exit; + end if; + end loop; + Status := Op_Ok; + end Ghdl_Untruncated_Text_Read; + + procedure File_Close + (File : Ghdl_File_Index; Is_Text : Boolean; Status : out Op_Status) + is + Stream : C_Files; + begin + Get_File (File, Stream, Status); + if Status /= Op_Ok then + return; + end if; + Check_File_Mode (File, Is_Text, Status); + if Status /= Op_Ok then + return; + end if; + + -- 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 + Status := Op_Ok; + return; + end if; + + if fclose (Stream) /= 0 then + Status := Op_Close_Error; + return; + end if; + Files_Table.Table (File).Stream := NULL_Stream; + Status := Op_Ok; + end File_Close; + + procedure Ghdl_Text_File_Close + (File : Ghdl_File_Index; Status : out Op_Status) is + begin + File_Close (File, True, Status); + end Ghdl_Text_File_Close; + + procedure Ghdl_File_Close + (File : Ghdl_File_Index; Status : out Op_Status) is + begin + File_Close (File, False, Status); + end Ghdl_File_Close; + + procedure Ghdl_File_Flush (File : Ghdl_File_Index; Status : out Op_Status) + is + Stream : C_Files; + begin + Get_File (File, Stream, Status); + if Status /= Op_Ok then + return; + end if; + + -- LRM08 5.5.2 File Operations + -- For the WRITE and FLUSH procedures, it is an error if the access + -- mode of the file object is read-only or if the file is not open. + if Stream = NULL_Stream then + Status := Op_Not_Open; + return; + end if; + if Get_Kind (File) = 'r' then + Status := Op_Write_Read_File; + return; + end if; + + fflush (Stream); + Status := Op_Ok; + end Ghdl_File_Flush; +end Grt.Files_Operations; diff --git a/src/grt/grt-files_operations.ads b/src/grt/grt-files_operations.ads new file mode 100644 index 000000000..ab3f70ef2 --- /dev/null +++ b/src/grt/grt-files_operations.ads @@ -0,0 +1,142 @@ +-- 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.Types; use Grt.Types; +with Interfaces; + +package Grt.Files_Operations is + type Ghdl_File_Index is new Interfaces.Integer_32; + + -- File open mode. + Read_Mode : constant Ghdl_I32 := 0; + Write_Mode : constant Ghdl_I32 := 1; + Append_Mode : constant Ghdl_I32 := 2; + + -- file_open_status. + Open_Ok : constant Ghdl_I32 := 0; + Status_Error : constant Ghdl_I32 := 1; + Name_Error : constant Ghdl_I32 := 2; + Mode_Error : constant Ghdl_I32 := 3; + + type Op_Status is + ( + Op_Ok, + + -- Correspond to file_open_status. + Op_Status_Error, + Op_Name_Error, + Op_Mode_Error, + + -- For endfile: end of file reached (as if endfile returns True). + Op_End_Of_File, + + -- Failed to call ungetc in endfile. + Op_Ungetc_Error, + + -- Operation on a non-open file. + Op_Not_Open, + + -- Try to read from a write-only file. + Op_Read_Write_File, + + -- Try to write to a read-only file. + Op_Write_Read_File, + + -- Internal error: incorrect file index. + Op_Bad_Index, + + -- Internal error: binary operation on text file, or text operation + -- on binary file. + Op_Bad_Mode, + + -- Internal error: destroy a file that is still open. + Op_Not_Closed, + + -- System error during write. + Op_Write_Error, + + -- System error during read. + Op_Read_Error, + + -- System error during close. + Op_Close_Error, + + -- Incorrect file name (too long). + Op_Filename_Error + ); + + -- General files. + procedure Ghdl_File_Endfile + (File : Ghdl_File_Index; Status : out Op_Status); + + -- Elaboration. + function Ghdl_Text_File_Elaborate return Ghdl_File_Index; + function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index; + + -- Finalization. + procedure Ghdl_Text_File_Finalize + (File : Ghdl_File_Index; Status : out Op_Status); + procedure Ghdl_File_Finalize + (File : Ghdl_File_Index; Status : out Op_Status); + + -- Subprograms. + procedure Ghdl_Text_File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Name : Ghdl_C_String; + Status : out Op_Status); + procedure Ghdl_File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Name : Ghdl_C_String; + Status : out Op_Status); + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; + Str : Std_String_Ptr; + Status : out Op_Status); + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type; + Status : out Op_Status); + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type; + Status : out Op_Status); + + procedure Ghdl_Text_Read_Length (File : Ghdl_File_Index; + Str : Std_String_Ptr; + Status : out Op_Status; + Length : out Std_Integer); + + procedure Ghdl_Untruncated_Text_Read (File : Ghdl_File_Index; + Str : Std_String_Ptr; + Len : out Std_Integer; + Status : out Op_Status); + + procedure Ghdl_Text_File_Close (File : Ghdl_File_Index; + Status : out Op_Status); + procedure Ghdl_File_Close (File : Ghdl_File_Index; + Status : out Op_Status); + + procedure Ghdl_File_Flush (File : Ghdl_File_Index; Status : out Op_Status); +end Grt.Files_Operations; diff --git a/src/synth/synth-decls.adb b/src/synth/synth-decls.adb index 834aef561..774bebd06 100644 --- a/src/synth/synth-decls.adb +++ b/src/synth/synth-decls.adb @@ -20,6 +20,7 @@ with Types; use Types; with Mutils; use Mutils; + with Netlists; use Netlists; with Netlists.Builders; use Netlists.Builders; with Netlists.Folds; use Netlists.Folds; @@ -36,6 +37,7 @@ with Synth.Expr; use Synth.Expr; with Synth.Stmts; with Synth.Source; use Synth.Source; with Synth.Errors; use Synth.Errors; +with Synth.Files_Operations; package body Synth.Decls is procedure Synth_Anonymous_Subtype_Indication @@ -697,11 +699,14 @@ package body Synth.Decls is null; when Iir_Kind_File_Declaration => declare + F : File_Index; Res : Value_Acc; Obj_Typ : Type_Acc; begin + F := Synth.Files_Operations.Elaborate_File_Declaration + (Syn_Inst, Decl); Obj_Typ := Get_Value_Type (Syn_Inst, Get_Type (Decl)); - Res := Create_Value_File (Obj_Typ, 0); + Res := Create_Value_File (Obj_Typ, F); Create_Object (Syn_Inst, Decl, Res); end; when Iir_Kind_Psl_Default_Clock => diff --git a/src/synth/synth-decls.ads b/src/synth/synth-decls.ads index 02bf5c865..08a548bc5 100644 --- a/src/synth/synth-decls.ads +++ b/src/synth/synth-decls.ads @@ -19,6 +19,7 @@ -- MA 02110-1301, USA. with Vhdl.Nodes; use Vhdl.Nodes; + with Synth.Context; use Synth.Context; with Synth.Values; use Synth.Values; diff --git a/src/synth/synth-files_operations.adb b/src/synth/synth-files_operations.adb new file mode 100644 index 000000000..4b188e157 --- /dev/null +++ b/src/synth/synth-files_operations.adb @@ -0,0 +1,159 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Types; use Types; + +with Grt.Types; +with Grt.Files_Operations; use Grt.Files_Operations; + +with Vhdl.Annotations; + +with Synth.Expr; use Synth.Expr; +with Synth.Source; use Synth.Source; +with Synth.Errors; use Synth.Errors; + +package body Synth.Files_Operations is + + -- 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) is + begin + pragma Assert (Status /= Op_Ok); + Error_Msg_Synth (+Loc, "file operation failed"); + raise Internal_Error; + end File_Error; + + -- VAL represents a string, so an array of characters. + procedure Convert_String (Val : Value_Acc; Res : out String) + is + Vtyp : constant Type_Acc := Val.Typ; + 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.Abounds.Len = 1); + pragma Assert (Vtyp.Abounds.D (1).Len = Res'Length); + + for I in Val.Arr.V'Range loop + Res (Res'First + Natural (I - 1)) := + Character'Val (Val.Arr.V (I).Scal); + end loop; + end Convert_String; + + -- Convert filename VAL to RES + LEN. + procedure Convert_File_Name (Val : Value_Acc; + Res : out C_File_Name; + Len : out Natural; + Status : out Op_Status) is + begin + Len := Natural (Val.Arr.Len); + + if Len >= Res'Length - 1 then + Status := Op_Filename_Error; + return; + end if; + + Convert_String (Val, Res (1 .. Len)); + Res (Len + 1) := Grt.Types.NUL; + + Status := Op_Ok; + end Convert_File_Name; + + function Elaborate_File_Declaration + (Syn_Inst : Synth_Instance_Acc; Decl : Node) return File_Index + is + use Grt.Types; + 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 : Value_Acc; + C_Name : C_File_Name; + C_Name_Len : Natural; + Mode : Value_Acc; + F : File_Index; + File_Mode : Ghdl_I32; + Status : Op_Status; + begin + if Get_Text_File_Flag (File_Type) then + F := Ghdl_Text_File_Elaborate; + else + declare + Sig : constant String_Acc := + Vhdl.Annotations.Get_Info (File_Type).File_Signature; + Cstr : Ghdl_C_String; + begin + if Sig = null then + Cstr := null; + else + Cstr := To_Ghdl_C_String (Sig.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 := Synth_Expression_With_Basetype (Syn_Inst, External_Name); + + if Open_Kind /= Null_Node then + Mode := Synth_Expression (Syn_Inst, Open_Kind); + File_Mode := Ghdl_I32 (Mode.Scal); + 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_Synth + (+Decl, "cannot open file: " & C_Name (1 .. C_Name_Len)); + raise Internal_Error; + else + File_Error (Decl, Status); + end if; + end if; + + return F; + end Elaborate_File_Declaration; +end Synth.Files_Operations; diff --git a/src/synth/synth-files_operations.ads b/src/synth/synth-files_operations.ads new file mode 100644 index 000000000..81dee4a91 --- /dev/null +++ b/src/synth/synth-files_operations.ads @@ -0,0 +1,29 @@ +-- 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, write to the Free Software +-- Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, +-- MA 02110-1301, USA. + +with Vhdl.Nodes; use Vhdl.Nodes; + +with Synth.Values; use Synth.Values; +with Synth.Context; use Synth.Context; + +package Synth.Files_Operations is + function Elaborate_File_Declaration + (Syn_Inst : Synth_Instance_Acc; Decl : Node) return File_Index; +end Synth.Files_Operations; diff --git a/src/synth/synth-values.ads b/src/synth/synth-values.ads index 4712eb2b7..03fa9d52e 100644 --- a/src/synth/synth-values.ads +++ b/src/synth/synth-values.ads @@ -21,6 +21,8 @@ with Types; use Types; with Areapools; use Areapools; +with Grt.Files_Operations; + with Netlists; use Netlists; with Vhdl.Nodes; use Vhdl.Nodes; @@ -201,7 +203,7 @@ package Synth.Values is type Heap_Index is new Uns32; Null_Heap_Index : constant Heap_Index := 0; - type File_Index is new Nat32; + subtype File_Index is Grt.Files_Operations.Ghdl_File_Index; type Value_Type (Kind : Value_Kind) is record Typ : Type_Acc; |