path: root/simulate/file_operation.adb

--  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;