asis_2019.0.0_3ca32fa2/tools/gnat2xml/gnat2xml-xml.adb

------------------------------------------------------------------------------
--                                                                          --
--                          GNAT2XML COMPONENTS                             --
--                           AVATOX COMPONENTS                              --
--                                                                          --
--                        VATOX (Via Asis To Xml)                           --
--                                                                          --
--                                                                          --
--                Copyright (C) 2006, McKae Technologies.                   --
--                   Copyright (C) 2012-2017, AdaCore                       --
--                                                                          --
-- Avatox is free software; you can redistribute it and/or modify it        --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. Avatox is distributed in the hope  that it will be useful,      --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER-      --
-- CHANTABILITY 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 COPYING. If   --
-- not, write to the Free Software Foundation, 59 Temple Place Suite 330,   --
-- Boston, MA 02111-1307, USA.                                              --
--                                                                          --
-- Avatox is based off the Display_Source software distributed as part of   --
-- the ASIS implementation for GNAT, and therefore inherits its GPL         --
-- licensing.  Ada Core Technologies maintains the Display_Source program   --
-- and its copyright is held by the Free Software Foundation.               --
--                                                                          --
-- Avatox is now maintained by McKae Technologies (http://www.mckae.com)    --
-- The gnat2xml tool was derived from the Avatox sources.                   --
------------------------------------------------------------------------------

pragma Ada_2012;

with Opt;

with Ada.Characters.Conversions; use Ada.Characters.Conversions;
with Ada.Characters.Handling;
with Ada.Directories;
with Ada.Strings.Unbounded;
with Ada.Strings.Wide_Fixed;     use Ada.Strings.Wide_Fixed;

with Asis.Elements;
with Asis.Text;
with Asis.Compilation_Units;

with McKae.Text.Lexicals;
with McKae.XML.EZ_Out;

with Gnat2xml.Command_Line;    use Gnat2xml.Command_Line;
with Gnat2xml.Xml_File_Output; use Gnat2xml.Xml_File_Output;
with Ada_Trees.Asis_To_Tree; use Ada_Trees;
with Pp.Buffers;        use Pp.Buffers;
with Pp.Scanner;

with Text_IO; use Text_IO;
with ASIS_UL.Options;
with Namet;
with A4G.Queries;  use A4G.Queries;

package body Gnat2xml.Xml is

   subtype Structural_Queries is A4G.Queries.Structural_Queries;

   use McKae.Text;

   function St (Id : Namet.Name_Id) return String
     renames Namet.Get_Name_String;

   ----------------------------------------------------------------------------

   function T (S : String; Xml_Casing : Boolean) return String;

   function T (S : String; Xml_Casing : Boolean) return String is
   begin
      if True then -- ???
         declare
            Result : constant String :=
              Lexicals.Transform
                (S,
                 Lexicals.lower,
                 Remove_Underscores => False);

         begin
            return Strip_Article (Result);
         end;
      end if;

      if Xml_Casing then
         return Lexicals.Transform
             (S,
              Lexicals.XML_Common,
              Remove_Underscores => True);

      else
         return S;
      end if;
   end T;

   ----------------------------------------------------------------------------

   function Span_To_Compact_Attributes
     (Element_Span : Asis.Text.Span)
      return         Attributes_List;

   function Span_To_Compact_Attributes
     (Element_Span : Asis.Text.Span)
      return         Attributes_List
   is
      use Ada.Strings;
      use Asis.Text;

   begin
      if Gnat2xml_Options.Compact_XML then
         return
           (0 =>
              "sloc" =
              To_String
                  (Trim
                     (Line_Number_Positive'Wide_Image
                        (Element_Span.First_Line),
                      Left)) &
                ":" &
                To_String
                  (Trim
                     (Character_Position_Positive'Wide_Image
                        (Element_Span.First_Column),
                      Left)));

      else
         return No_Attributes;
      end if;
   end Span_To_Compact_Attributes;

   function Span_To_Verbose_Attributes
     (Element_Span : Asis.Text.Span)
      return         Attributes_List;

   function Span_To_Verbose_Attributes
     (Element_Span : Asis.Text.Span)
      return         Attributes_List
   is
      use Ada.Strings;
      use Asis.Text;

   begin
      --???pragma Assert (not Gnat2xml_Options.Compact_XML);
      return
        (("line" =
          To_String
            (Trim
               (Line_Number_Positive'Wide_Image (Element_Span.First_Line),
                Left))),
         ("col" =
          To_String
            (Trim
               (Character_Position_Positive'Wide_Image
                  (Element_Span.First_Column),
                Left))),
         ("endline" =
          To_String
            (Trim (Line_Number'Wide_Image (Element_Span.Last_Line), Left))),
         ("endcol" =
          To_String
            (Trim
               (Character_Position'Wide_Image (Element_Span.Last_Column),
                Left))));
   end Span_To_Verbose_Attributes;

   ----------------------------------------------------------------------------

   Pp_Off_On_Delimiters : constant Pp.Scanner.Pp_Off_On_Delimiters_Rec
     := (others => <>);

   Skip_Gen : Boolean renames ASIS_UL.Debug.Debug_Flag_3;

   procedure Process_Unit
     (The_Unit : Asis.Compilation_Unit;
      State    : Info_Node)
   is
      --  ???Much of the info in State could be local to here!

      use Compilation_Units;

      procedure Put_Src_Lines (Up_To : Asis.Text.Line_Number);
      --  Print out source lines up to the current Sloc, which is Up_To. This
      --  is for debugging the XML, and is only done in --compact mode.

      procedure Process_Elem
        (Q               : Structural_Queries;
         Tree            : Ada_Tree;
         Is_List_Element : Boolean);

      procedure Process_List
        (Q    : Structural_Queries;
         List : Ada_Tree);

      procedure Pre
        (Q               : Structural_Queries;
         Is_List_Element : Boolean;
         Tree            : Ada_Tree);

      procedure Pre
        (Q               : Structural_Queries;
         Is_List_Element : Boolean;
         Tree            : Ada_Tree)
      is

         function Checks return String;

         function Checks return String is
            use Ada.Strings.Unbounded, Ada.Characters.Handling;
            Result : Unbounded_String;
            First_Time : Boolean := True;
         begin
            for Check in Tree.Checks'Range loop
               if Tree.Checks (Check) then
                  if First_Time then
                     First_Time := False;
                  else
                     Append (Result, ",");
                  end if;
                  Append (Result, To_Lower (Check'Img));
               end if;
            end loop;

            return To_String (Result);
         end Checks;

         Kind : constant Opt_ASIS_Elems := Tree.Kind;

         Def_Name_Attrs : constant Attributes_List :=
           (if Kind in Def_Names then +("def_name" = St (Tree.Def_Name))
            else No_Attributes);

         Def_Attrs : constant Attributes_List :=
           (if Kind in Def_Names then +("def" = St (Tree.Def))
            else No_Attributes);

         Ref_Name_Attrs : constant Attributes_List :=
           (if
              Kind in Flat_Usage_Name_Kinds
            then
              +("ref_name" = St (Tree.Ref_Name))
            else No_Attributes);

         Ref_Attrs : constant Attributes_List :=
           (if
              Kind in Flat_Usage_Name_Kinds
            then
              +("ref" = St (Tree.Ref))
            else No_Attributes);

         Type_Attrs : constant Attributes_List :=
           (if
              Kind in Def_Names | Flat_Expression_Kinds
            then
              +("type" = St (Get_Type (Tree)))
            else No_Attributes);

         Pragma_Name_Attrs : constant Attributes_List :=
           (if
              Kind in Flat_Pragma_Kinds
            then
              +("pragma_name" = St (Tree.Pragma_Name))
            else No_Attributes);

         Lit_Val_Attrs : constant Attributes_List :=
           (if
              Kind in An_Integer_Literal | A_Real_Literal | A_String_Literal
            then
              +("lit_val" = St (Tree.Lit_Val))
            else No_Attributes);

         Mode_Attrs : constant Attributes_List :=
           (if
              Kind in A_Parameter_Specification | A_Formal_Object_Declaration
            then
              +("mode" = Tree.Mode'Img)
            else No_Attributes);

         Text_Attrs : constant Attributes_List :=
           (if
              Kind in A_Comment
            then
              +("text" = St (Tree.Text))
            else No_Attributes);

         Checks_Attrs : constant Attributes_List :=
           (if Kind not in Not_An_Element
            then
              +("checks" = Checks)
            else No_Attributes);

         Attrs : constant Attributes_List :=
           Span_To_Compact_Attributes (Tree.Sloc) &
           Def_Name_Attrs &
           Def_Attrs &
           Ref_Name_Attrs &
           Ref_Attrs &
           Type_Attrs &
           Pragma_Name_Attrs &
           Lit_Val_Attrs &
           Mode_Attrs &
           Text_Attrs &
           Checks_Attrs;

      --  Start of processing for Pre

      begin
         if Gnat2xml_Options.Compact_XML then
            Put_Src_Lines (Up_To => Tree.Sloc.First_Line);
         end if;

         if not Is_List_Element then
            Start_Element
              (State.XML_File.all,
               T (Structural_Queries'Image (Q) & "_q", State.Xml_Style));
         end if;

         if Tree.Subtree_Count = 0 and then Gnat2xml_Options.Compact_XML then
            Output_Tag
              (State.XML_File.all,
               T (ASIS_Elems'Image (Kind), State.Xml_Style),
               Attrs);

         else
            Start_Element
              (State.XML_File.all,
               T (ASIS_Elems'Image (Kind), State.Xml_Style),
               Attrs);
            if not Gnat2xml_Options.Compact_XML then
               Output_Tag
                 (State.XML_File.all,
                  T ("sloc", State.Xml_Style),
                  Span_To_Verbose_Attributes (Tree.Sloc));
            end if;
         end if;
      end Pre;

      procedure Process_Elem
        (Q               : Structural_Queries;
         Tree            : Ada_Tree;
         Is_List_Element : Boolean)
      is

         procedure Process_Children;

         procedure Process_Children is
            Qs : Query_List renames Appropriate_Queries (Tree.Kind).all;

         begin
            for Index in Qs'Range loop
               declare
                  Q     : constant Structural_Queries := Qs (Index);
                  Child : constant Ada_Tree := Tree.Subtrees (Index);
               begin
                  case Child.Kind is
                     when Opt_ASIS_Elems =>
                        Process_Elem (Q, Child, Is_List_Element => False);
                     when Flat_List_Kinds =>
                        Process_List (Q, Child);
                  end case;
               end;
            end loop;
         end Process_Children;

      --  Start of processing for Process_Elem

      begin
         if Debug_Mode then
            Put_Line (Tree.Kind'Img);

            if Tree.Kind in Def_Names then
               Put_Line
                 ("Defining_Name_Image = " & St (Tree.Def_Name));
            end if;

            if Tree.Kind in Flat_Usage_Name_Kinds then
               Put_Line ("Name_Image = " & St (Tree.Ref_Name));
            end if;
         end if;

         Pre (Q, Is_List_Element, Tree);

         Process_Children;

         --  If it's a leaf and we're in compact mode, then we didn't do
         --  Start_Element in Pre_Procedure, but put out the whole element
         --  in short form, so in that case we don't want to End_Element here.

         if Tree.Subtree_Count = 0 and then Gnat2xml_Options.Compact_XML then
            null;

         else
            End_Element (State.XML_File.all);
         end if;

         if not Is_List_Element then
            End_Element (State.XML_File.all);
         end if;
      end Process_Elem;

      -------------------------------------------------------------------------

      procedure Process_List
        (Q    : Structural_Queries;
         List : Ada_Tree)
      is
      begin
         Start_Element
           (State.XML_File.all,
            T (Structural_Queries'Image (Q) & "_ql",
               State.Xml_Style)); --  ???,

         for Subtree of List.Subtrees loop
            Process_Elem (Q, Subtree, Is_List_Element => True);
         end loop;

         End_Element (State.XML_File.all);
      end Process_List;

      Name : constant String := To_String (Unit_Full_Name (The_Unit));
      Src_File_Name : constant String := To_String (Text_Name (The_Unit));
      Src_File_Simple_Name  : constant String :=
        Ada.Directories.Simple_Name (Src_File_Name);
      Unit_Span : constant Asis.Text.Span :=
        Asis.Text.Compilation_Unit_Span
          (Asis.Elements.Unit_Declaration (The_Unit));

      Src_File : aliased Text_IO.File_Type;
      --  Original source file, used to intersperse source text in the compact
      --  XML form.

      Cur_Line : Natural := 0;
      --  Current source file line that has been printed

      procedure Put_Src_Lines (Up_To : Asis.Text.Line_Number) is
      begin
         while not End_Of_File (Src_File) and then Cur_Line < Up_To loop
            Put_Line (State.XML_File.all, Get_Line (Src_File));
            Cur_Line := Cur_Line + 1;
         end loop;
      end Put_Src_Lines;

      Root : Ada_Tree;

      Src_Buf : Buffer;
      --  Buffer containing the text of the original source file

      Src_Tokens : Pp.Scanner.Token_Vector;
      Src_Gen_Regions : aliased Pp.Scanner.Token_Vector;
      Gen_Regions : Pp.Scanner.Token_Vector_Ptr := null;
      --  Set to point to Src_Gen_Regions if necessary.

      Ignored_BOM_Seen : Boolean;

   --  Start of processing for Process_Unit

   begin
      if Gnat2xml_Options.Compact_XML then
         if ASIS_UL.Options.Verbose_Mode then
            Put_Line ("Opening source " & Src_File_Name);
         end if;
         Open (Src_File, In_File, Src_File_Name);
      end if;

      if Skip_Gen then
         Read_Ada_File (Src_Buf, Src_File_Name,
                        Opt.Wide_Character_Encoding_Method, Ignored_BOM_Seen,
                        Expand_Tabs => True);

         Pp.Scanner.Get_Tokens
           (Src_Buf, Src_Tokens, Pp_Off_On_Delimiters,
            Gen_Regions => Src_Gen_Regions'Unchecked_Access);
         Gen_Regions := Src_Gen_Regions'Unchecked_Access;
      end if;

      Root := Asis_To_Tree.Compilation_Unit_To_Tree (The_Unit, Gen_Regions);

      Start_Element
        (State.XML_File.all,
         T ("compilation_unit", State.Xml_Style),
         ("unit_kind" = Capitalize (Root.Unit_Kind'Img),
          "unit_class" = Capitalize (Root.Unit_Class'Img),
          "unit_origin" = Capitalize (Root.Unit_Origin'Img),
          "unit_full_name" = St (Root.Unit_Full_Name),
          "def_name" = Name,
          "source_file" = Src_File_Simple_Name) &
         Span_To_Compact_Attributes (Unit_Span));
      if not Gnat2xml_Options.Compact_XML then
         Output_Tag
           (State.XML_File.all,
            T ("sloc", State.Xml_Style),
            Span_To_Verbose_Attributes (Unit_Span));
      end if;

      declare
         Cont_Clause_Elements : constant Ada_Tree := Root.Subtrees (1);
         Unit_Element : constant Ada_Tree := Root.Subtrees (2);
         Pragmas : constant Ada_Tree := Root.Subtrees (3);

      begin
         Process_List
           (Q    => Context_Clause_Elements,
            List => Cont_Clause_Elements);

         Process_Elem
           (Q               => Unit_Declaration,
            Tree            => Unit_Element,
            Is_List_Element => False);

         Process_List (Q => Pragmas_After, List => Pragmas);
      end;

      End_Element (State.XML_File.all);

      if Gnat2xml_Options.Compact_XML then
         --  Force out the rest of the lines:
         Put_Src_Lines (Up_To => Natural'Last);
         Close (Src_File);
      end if;

      --  Termination, depending on the application
--???      Terminate_Node (The_Control, The_Node_Information);
   end Process_Unit;

   ----------------------------------------------------------------------------

   procedure Start_Representation (State : Info_Node) is
   begin
      if State.Krunch then
         Current_Format := McKae.XML.EZ_Out.Continuous_Stream;
      end if;

      --  XML container for code representation
      Output_XML_Header (State.XML_File.all);
   end Start_Representation;

end Gnat2xml.Xml;