-- 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
Len : Std_Integer;
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
(File.File, Val'Unrestricted_Access, Len'Unrestricted_Access);
for I in 1 .. Len loop
Str.Val_Array.V (Iir_Index32 (I)).E32 :=
Character'Pos (Val_Str (Ghdl_Index_Type (I)));
end loop;
Length.I64 := Ghdl_I64 (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;