path: root/src/vhdl/translate/trans-helpers2.adb

--  Iir to ortho translator.
--  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.

with Name_Table;
with Trans.Chap3;
with Trans.Chap6;
with Trans_Decls; use Trans_Decls;
with Files_Map;
with Trans.Foreach_Non_Composite;

package body Trans.Helpers2 is
   use Trans.Helpers;

   procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) is
   begin
      New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)),
                       M2Addr (Chap3.Get_Array_Base (S)));
      New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (D)),
                       M2Addr (Chap3.Get_Array_Bounds (S)));
   end Copy_Fat_Pointer;

   --  Convert NAME into a STRING_CST.
   --  Append a NUL terminator (to make interfaces with C easier).
   function Create_String_Type (Str : String) return O_Tnode is
   begin
      return New_Constrained_Array_Type
        (Chararray_Type,
         New_Unsigned_Literal (Ghdl_Index_Type,
           Unsigned_64 (Str'Length + 1)));
   end Create_String_Type;

   procedure Create_String_Value
     (Const : in out O_Dnode; Const_Type : O_Tnode; Str : String)
   is
      Res  : O_Cnode;
      List : O_Array_Aggr_List;
   begin
      Start_Const_Value (Const);
      Start_Array_Aggr (List, Const_Type);
      for I in Str'Range loop
         New_Array_Aggr_El
           (List,
            New_Unsigned_Literal (Char_Type_Node, Character'Pos (Str (I))));
      end loop;
      New_Array_Aggr_El (List, New_Unsigned_Literal (Char_Type_Node, 0));
      Finish_Array_Aggr (List, Res);
      Finish_Const_Value (Const, Res);
   end Create_String_Value;

   function Create_String (Str : String; Id : O_Ident) return O_Dnode
   is
      Atype : O_Tnode;
      Const : O_Dnode;
   begin
      Atype := Create_String_Type (Str);
      New_Const_Decl (Const, Id, O_Storage_Private, Atype);
      Create_String_Value (Const, Atype, Str);
      return Const;
   end Create_String;

   function Create_String (Str : String; Id : O_Ident; Storage : O_Storage)
                              return O_Dnode
   is
      Atype : O_Tnode;
      Const : O_Dnode;
   begin
      Atype := Create_String_Type (Str);
      New_Const_Decl (Const, Id, Storage, Atype);
      if Storage /= O_Storage_External then
         Create_String_Value (Const, Atype, Str);
      end if;
      return Const;
   end Create_String;

   function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage)
                              return O_Dnode
   is
      use Name_Table;
   begin
      if Name_Table.Is_Character (Str) then
         raise Internal_Error;
      end if;
      Image (Str);
      return Create_String (Nam_Buffer (1 .. Nam_Length), Id, Storage);
   end Create_String;

   function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode
   is
      Str_Cst : O_Dnode;
      Str_Len : O_Cnode;
      List    : O_Record_Aggr_List;
      Res     : O_Cnode;
   begin
      Str_Cst := Create_String (Str, Id);
      Str_Len := New_Unsigned_Literal (Ghdl_Index_Type,
                                       Unsigned_64 (Str'Length));
      Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node);
      New_Record_Aggr_El (List, Str_Len);
      New_Record_Aggr_El (List, New_Global_Address (Str_Cst,
                          Char_Ptr_Type));
      Finish_Record_Aggr (List, Res);
      return Res;
   end Create_String_Len;

   procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode)
   is
      Constr : O_Assoc_List;
   begin
      Start_Association (Constr, Ghdl_Memcpy);
      New_Association (Constr, New_Convert_Ov (Dest, Ghdl_Ptr_Type));
      New_Association (Constr, New_Convert_Ov (Src, Ghdl_Ptr_Type));
      New_Association (Constr, Length);
      New_Procedure_Call (Constr);
   end Gen_Memcpy;

   --  function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode
   --  is
   --     Constr : O_Assoc_List;
   --  begin
   --     Start_Association (Constr, Ghdl_Malloc);
   --     New_Association (Constr, Length);
   --     return New_Convert_Ov (New_Function_Call (Constr), Ptype);
   --  end Gen_Malloc;

   function Gen_Alloc
     (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode)
         return O_Enode
   is
      Constr : O_Assoc_List;
   begin
      case Kind is
         when Alloc_Heap =>
            Start_Association (Constr, Ghdl_Malloc);
            New_Association (Constr, Size);
            return New_Convert_Ov (New_Function_Call (Constr), Ptype);
         when Alloc_System =>
            Start_Association (Constr, Ghdl_Malloc0);
            New_Association (Constr, Size);
            return New_Convert_Ov (New_Function_Call (Constr), Ptype);
         when Alloc_Stack =>
            return New_Alloca (Ptype, Size);
         when Alloc_Return =>
            Start_Association (Constr, Ghdl_Stack2_Allocate);
            New_Association (Constr, Size);
            return New_Convert_Ov (New_Function_Call (Constr), Ptype);
      end case;
   end Gen_Alloc;

   procedure Register_Non_Composite_Signal (Targ      : Mnode;
                                            Targ_Type : Iir;
                                            Proc      : O_Dnode)
   is
      pragma Unreferenced (Targ_Type);
      Constr : O_Assoc_List;
   begin
      Start_Association (Constr, Proc);
      New_Association
        (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr));
      New_Procedure_Call (Constr);
   end Register_Non_Composite_Signal;

   function Register_Update_Data_Array
     (Data : O_Dnode; Targ_Type : Iir; Index : O_Dnode)
         return O_Dnode
   is
      pragma Unreferenced (Targ_Type);
      pragma Unreferenced (Index);
   begin
      return Data;
   end Register_Update_Data_Array;

   function Register_Prepare_Data_Composite (Targ      : Mnode;
                                             Targ_Type : Iir;
                                             Data      : O_Dnode)
                                                return O_Dnode
   is
      pragma Unreferenced (Targ);
      pragma Unreferenced (Targ_Type);
   begin
      return Data;
   end Register_Prepare_Data_Composite;

   function Register_Update_Data_Record
     (Data : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration)
         return O_Dnode
   is
      pragma Unreferenced (Targ_Type);
      pragma Unreferenced (El);
   begin
      return Data;
   end Register_Update_Data_Record;

   procedure Register_Finish_Data_Composite (D : in out O_Dnode)
   is
      pragma Unreferenced (D);
   begin
      null;
   end Register_Finish_Data_Composite;

   procedure Register_Signal_1 is new Foreach_Non_Composite
     (Data_Type => O_Dnode,
      Composite_Data_Type => O_Dnode,
      Do_Non_Composite => Register_Non_Composite_Signal,
      Prepare_Data_Array => Register_Prepare_Data_Composite,
      Update_Data_Array => Register_Update_Data_Array,
      Finish_Data_Array => Register_Finish_Data_Composite,
      Prepare_Data_Record => Register_Prepare_Data_Composite,
      Update_Data_Record => Register_Update_Data_Record,
      Finish_Data_Record => Register_Finish_Data_Composite);

   procedure Register_Signal (Targ      : Mnode;
                              Targ_Type : Iir;
                              Proc      : O_Dnode)
                                 renames Register_Signal_1;

   procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode)
   is
      El  : Iir;
      Sig : Mnode;
   begin
      if List = Null_Iir_List then
         return;
      end if;
      for I in Natural loop
         El := Get_Nth_Element (List, I);
         exit when El = Null_Iir;
         Open_Temp;
         Sig := Chap6.Translate_Name (El, Mode_Signal);
         Register_Signal (Sig, Get_Type (El), Proc);
         Close_Temp;
      end loop;
   end Register_Signal_List;

   function Gen_Oenode_Prepare_Data_Composite
     (Targ : Mnode; Targ_Type : Iir; Val : O_Enode)
         return Mnode
   is
      pragma Unreferenced (Targ);
      Res       : Mnode;
      Type_Info : Type_Info_Acc;
   begin
      Type_Info := Get_Info (Targ_Type);
      Res := E2M (Val, Type_Info, Mode_Value);
      case Type_Info.Type_Mode is
         when Type_Mode_Array
            | Type_Mode_Fat_Array =>
            Res := Chap3.Get_Array_Base (Res);
         when Type_Mode_Record =>
            Res := Stabilize (Res);
         when others =>
            --  Not a composite type!
            raise Internal_Error;
      end case;
      return Res;
   end Gen_Oenode_Prepare_Data_Composite;

   function Gen_Oenode_Update_Data_Array (Val       : Mnode;
                                          Targ_Type : Iir;
                                          Index     : O_Dnode)
                                             return O_Enode
   is
   begin
      return M2E (Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index)));
   end Gen_Oenode_Update_Data_Array;

   function Gen_Oenode_Update_Data_Record
     (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration)
         return O_Enode
   is
      pragma Unreferenced (Targ_Type);
   begin
      return M2E (Chap6.Translate_Selected_Element (Val, El));
   end Gen_Oenode_Update_Data_Record;

   procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode)
   is
      pragma Unreferenced (Data);
   begin
      null;
   end Gen_Oenode_Finish_Data_Composite;

   function Get_Line_Number (Target: Iir) return Natural
   is
      Line, Col: Natural;
      Name     : Name_Id;
   begin
      Files_Map.Location_To_Position
        (Get_Location (Target), Name, Line, Col);
      return Line;
   end Get_Line_Number;

   procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List;
                                  Line  : Natural) is
   begin
      New_Association (Assoc,
                       New_Lit (New_Global_Address (Current_Filename_Node,
                                                    Char_Ptr_Type)));
      New_Association (Assoc, New_Lit (New_Signed_Literal
                       (Ghdl_I32_Type, Integer_64 (Line))));
   end Assoc_Filename_Line;
end Trans.Helpers2;