------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                          V X L I N K . B I N D                           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2018, AdaCore                          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT 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  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Text_IO;       use Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Fixed;

with GNAT.Regpat;       use GNAT.Regpat;

package body VxLink.Bind is

   function Split_Lines (S : String) return Strings_List.Vector;

   function Split (S : String; C : Character) return Strings_List.Vector;

   function Parse_Nm_Output (S : String) return Symbol_Sets.Set;

   procedure Emit_Module_Dtor
     (FP : File_Type);

   procedure Emit_CDtor
     (FP  : File_Type;
      Var : String;
      Set : Symbol_Sets.Set);

   -----------------
   -- Split_Lines --
   -----------------

   function Split_Lines (S : String) return Strings_List.Vector
   is
      Last : Natural := S'First;
      Ret  : Strings_List.Vector;
   begin
      for J in S'Range loop
         if S (J) = ASCII.CR
           and then J < S'Last
           and then S (J + 1) = ASCII.LF
         then
            Ret.Append (S (Last .. J - 1));
            Last := J + 2;
         elsif S (J) = ASCII.LF then
            Ret.Append (S (Last .. J - 1));
            Last := J + 1;
         end if;
      end loop;

      if Last <= S'Last then
         Ret.Append (S (Last .. S'Last));
      end if;

      return Ret;
   end Split_Lines;

   -----------
   -- Split --
   -----------

   function Split (S : String; C : Character) return Strings_List.Vector
   is
      Last : Natural := S'First;
      Ret  : Strings_List.Vector;
   begin
      for J in S'Range loop
         if S (J) = C then
            if J > Last then
               Ret.Append (S (Last .. J - 1));
            end if;

            Last := J + 1;
         end if;
      end loop;

      if Last <= S'Last then
         Ret.Append (S (Last .. S'Last));
      end if;

      return Ret;
   end Split;

   ---------------------
   -- Parse_Nm_Output --
   ---------------------

   function Parse_Nm_Output (S : String) return Symbol_Sets.Set
   is
      Nm_Regexp        : constant Pattern_Matcher :=
                           Compile ("^[0-9A-Za-z]* ([a-zA-Z]) (.*)$");
      type CDTor_Type is
        (CTOR_Diab,
         CTOR_Gcc,
         DTOR_Diab,
         DTOR_Gcc);
      subtype CTOR_Type is CDTor_Type range CTOR_Diab .. CTOR_Gcc;
      CTOR_DIAB_Regexp : aliased constant Pattern_Matcher :=
                           Compile ("^__?STI__*([0-9]+)_");
      CTOR_GCC_Regexp  : aliased constant Pattern_Matcher :=
                           Compile ("^__?GLOBAL_.I._*([0-9]+)_");
      DTOR_DIAB_Regexp : aliased constant Pattern_Matcher :=
                           Compile ("^__?STD__*([0-9]+)_");
      DTOR_GCC_Regexp  : aliased constant Pattern_Matcher :=
                           Compile ("^__?GLOBAL_.D._*([0-9]+)_");
      type Regexp_Access is access constant Pattern_Matcher;
      CDTor_Regexps    : constant array (CDTor_Type) of Regexp_Access :=
                           (CTOR_Diab => CTOR_DIAB_Regexp'Access,
                            CTOR_Gcc  => CTOR_GCC_Regexp'Access,
                            DTOR_Diab => DTOR_DIAB_Regexp'Access,
                            DTOR_Gcc  => DTOR_GCC_Regexp'Access);
      Result           : Symbol_Sets.Set;

   begin
      for Line of Split_Lines (S) loop
         declare
            Sym     : Symbol;
            Nm_Grps : Match_Array (0 .. 2);
            Ctor_Grps : Match_Array (0 .. 1);
         begin
            Match (Nm_Regexp, Line, Nm_Grps);

            if Nm_Grps (0) /= No_Match then
               declare
                  Sym_Type : constant Character :=
                               Line (Nm_Grps (1).First);
                  Sym_Name : constant String :=
                               Line (Nm_Grps (2).First .. Nm_Grps (2).Last);
               begin
                  Sym :=
                    (Name     => To_Unbounded_String (Sym_Name),
                     Cat      => Sym_Type,
                     Internal => False,
                     Kind     => Sym_Other,
                     Priority => -1);

                  for J in CDTor_Regexps'Range loop
                     Match (CDTor_Regexps (J).all, Sym_Name, Ctor_Grps);

                     if Ctor_Grps (0) /= No_Match then
                        if J in CTOR_Type then
                           Sym.Kind := Sym_Ctor;
                        else
                           Sym.Kind := Sym_Dtor;
                        end if;

                        Sym.Priority := Integer'Value
                          (Line (Ctor_Grps (1).First .. Ctor_Grps (1).Last));

                        exit;
                     end if;
                  end loop;

                  Result.Include (Sym);
               end;
            end if;
         end;
      end loop;

      return Result;
   end Parse_Nm_Output;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize
     (Binder      : out VxLink_Binder;
      Object_File : String)
   is
      Args                   : Arguments_List;
      Module_Dtor_Not_Needed : Boolean := False;
      Module_Dtor_Needed     : Boolean := False;

   begin
      Args.Append (Nm);
      Args.Append (Object_File);

      declare
         Output  : constant String := Run (Args);
         Symbols : Symbol_Sets.Set;
      begin
         if Is_Error_State then
            return;
         end if;

         Symbols := Parse_Nm_Output (Output);

         for Sym of Symbols loop
            if Sym.Kind = Sym_Ctor then
               Binder.Constructors.Insert (Sym);
            elsif Sym.Kind = Sym_Dtor then
               Binder.Destructors.Insert (Sym);
            elsif Match ("_?__.*_atexit$", To_String (Sym.Name)) then
               if Sym.Cat = 'T' then
                  Module_Dtor_Not_Needed := True;
               elsif Sym.Cat = 'U' then
                  Module_Dtor_Needed := True;
               end if;
            end if;
         end loop;

         Binder.Module_Dtor_Needed :=
           not Module_Dtor_Not_Needed and then Module_Dtor_Needed;
      end;
   end Initialize;

   --------------------
   -- Parse_Tag_File --
   --------------------

   procedure Parse_Tag_File
     (Binder : in out VxLink_Binder;
      File   : String)
   is
      FP   : Ada.Text_IO.File_Type;

   begin
      Open
        (FP,
         Mode => In_File,
         Name => File);
      loop
         declare
            Line   : constant String :=
                      Ada.Strings.Fixed.Trim
                        (Get_Line (FP), Ada.Strings.Both);
            Tokens : Strings_List.Vector;

         begin
            if Line'Length = 0 then
               --  Skip empty lines
               null;

            elsif Line (Line'First) = '#' then
               --  Skip comment
               null;

            else
               Tokens := Split (Line, ' ');
               if Tokens.First_Element = "section" then
                  --  Sections are not used for tags, only when building
                  --  kernels. So skip for now
                  null;
               else
                  Binder.Tags_List.Append (Line);
               end if;
            end if;
         end;
      end loop;

   exception
      when Ada.IO_Exceptions.End_Error =>
         Close (FP);
      when others =>
         Log_Error ("Cannot open file " & File &
                      ". DKM tags won't be generated");
   end Parse_Tag_File;

   ----------------------
   -- Emit_Module_Dtor --
   ----------------------

   procedure Emit_Module_Dtor
     (FP : File_Type)
   is
      Dtor_Name : constant String := "_GLOBAL__D_65536_0_cxa_finalize";
   begin
      Put_Line (FP, "extern void __cxa_finalize(void *);");
      Put_Line (FP, "static void " & Dtor_Name & "()");
      Put_Line (FP, "{");
      Put_Line (FP, "  __cxa_finalize(&__dso_handle);");
      Put_Line (FP, "}");
      Put_Line (FP, "");
   end Emit_Module_Dtor;

   ----------------
   -- Emit_CDtor --
   ----------------

   procedure Emit_CDtor
     (FP  : File_Type;
      Var : String;
      Set : Symbol_Sets.Set)
   is
   begin
      for Sym of Set loop
         if not Sym.Internal then
            Put_Line (FP, "extern void " & To_String (Sym.Name) & "();");
         end if;
      end loop;

      New_Line (FP);

      Put_Line (FP, "extern void (*" & Var & "[])();");
      Put_Line (FP, "void (*" & Var & "[])() =");
      Put_Line (FP, "  {");
      for Sym of Set loop
         Put_Line (FP, "  " & To_String (Sym.Name) & ",");
      end loop;
      Put_Line (FP, "  0};");
      New_Line (FP);
   end Emit_CDtor;

   ---------------
   -- Emit_CTDT --
   ---------------

   procedure Emit_CTDT
     (Binder    : in out VxLink_Binder;
      Namespace : String)
   is
      FP         : Ada.Text_IO.File_Type;
      CDtor_File : constant String := Namespace & "-cdtor.c";
   begin
      Binder.CTDT_File := To_Unbounded_String (CDtor_File);
      Create
        (File => FP,
         Name => CDtor_File);
      Put_Line (FP, "#if defined(_HAVE_TOOL_XTORS)");
      Put_Line (FP, "#include <vxWorks.h>");
      if Binder.Module_Dtor_Needed then
         Put_Line (FP, "#define _WRS_NEED_CALL_CXA_FINALIZE");
      end if;
      Put_Line (FP, "#include TOOL_HEADER (toolXtors.h)");
      Put_Line (FP, "#else");
      Put_Line (FP, "");

      if Binder.Module_Dtor_Needed then
         Emit_Module_Dtor (FP);
      end if;

      Emit_CDtor (FP, "_ctors", Binder.Constructors);
      Emit_CDtor (FP, "_dtors", Binder.Destructors);

      Put_Line (FP, "#endif");

      if not Binder.Tags_List.Is_Empty then
         New_Line (FP);
         Put_Line (FP, "/* build variables */");
         Put_Line (FP, "__asm(""  .section \"".wrs_build_vars\"",\""a\"""");");
         for Tag of Binder.Tags_List loop
            Put_Line (FP, "__asm(""  .ascii \""" & Tag & "\"""");");
            Put_Line (FP, "__asm(""  .byte 0"");");
         end loop;
         Put_Line (FP, "__asm(""  .ascii \""end\"""");");
         Put_Line (FP, "__asm(""  .byte 0"");");
      end if;

      Close (FP);

   exception
      when others =>
         Close (FP);
         Set_Error_State ("Internal error");
         raise;
   end Emit_CTDT;

   ---------------
   -- CTDT_File --
   ---------------

   function CTDT_File (Binder : VxLink_Binder) return String
   is
   begin
      return To_String (Binder.CTDT_File);
   end CTDT_File;

end VxLink.Bind;