------------------------------------------------------------------------------
--                                                                          --
--                            GNAT2XML COMPONENTS                           --
--                                                                          --
--                    G N A T 2 X M L . A D A _ T R E E S                   --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                     Copyright (C) 2012-2018, AdaCore                     --
--                                                                          --
-- Gnat2xml 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. Gnat2xml 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.                                              --
-- The gnat2xml tool was derived from the Avatox sources.                   --
------------------------------------------------------------------------------

pragma Ada_2012;

--  This package provides a data structure Ada_Tree for representing Ada syntax
--  trees. An Ada_Tree has basically the same structure as the ASIS tree, but
--  represented as a data type rather than various query functions. Unlike an
--  ASIS tree, an Ada_Tree can be created and modified, as well as queried.

with Unchecked_Deallocation;
with Ada.Containers.Hashed_Maps;

with Namet; use Namet;

with A4G.Queries; use A4G;

with Asis.Text;
with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds;

with ASIS_UL.Debug;
with ASIS_UL.Utilities;
with ASIS_UL.Vectors;
with ASIS_UL.String_Utilities; use ASIS_UL.String_Utilities;

pragma Warnings (Off); -- imported for children
with ASIS_UL.Dbg_Out;
with Ada.Wide_Characters.Handling; use Ada.Wide_Characters.Handling;
use Ada;
with Pp; use Pp;
pragma Warnings (On);

package Ada_Trees is

   use ASIS_UL;

   subtype Classes is
     Flat_Element_Kinds'Base range Not_An_Element .. A_Statement_Class;
   --  All classes, including the abstract ones, the lists, and the singleton
   --  element kinds

   subtype Opt_ASIS_Elems is
     Flat_Element_Kinds'Base range Not_An_Element .. A_Compilation_Unit;

   function Ekind (Element : Asis.Element) return Opt_ASIS_Elems;

   use type A4G.Queries.Query_Index;

   function Span (Element : Asis.Element) return Asis.Text.Span;
   --  Return Nil_Element for gnat2xml-specific kinds

   subtype ASIS_Elems is Opt_ASIS_Elems with
        Predicate => ASIS_Elems /= Not_An_Element;

   subtype Def_Names is Flat_Defining_Name_Kinds;
   --  Defining occurences, such as A_Defining_Identifier

   subtype Usage_Names is Flat_Usage_Name_Kinds;
   --  References to defining occurrences, such as An_Identifier

   subtype Name_Elems is ASIS_Elems with
        Predicate => Name_Elems in Def_Names | Usage_Names;

   subtype Boolean_Elems is
     ASIS_Elems'Base range An_Aliased .. An_Is_Prefix_Notation;

   subtype Other_Elems is ASIS_Elems with
        Predicate => Other_Elems not in Name_Elems | Boolean_Elems;

   subtype Unit_Kinds is Asis.Unit_Kinds;
   subtype Unit_Classes is Asis.Unit_Classes;
   subtype Unit_Origins is Asis.Unit_Origins;
   use all type Unit_Kinds, Unit_Classes, Unit_Origins;

   Main_Done : Boolean renames ASIS_UL.Utilities.Main_Done;

   Debug_Mode : Boolean renames ASIS_UL.Debug.Debug_Flag_9;

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

   use A4G.Queries;

   type Ada_Tree_Rec;

   type Ada_Tree_Base is access all Ada_Tree_Rec;
   subtype Ada_Tree is Ada_Tree_Base with
     Predicate => Ada_Tree_Rec_OK (Ada_Tree.all);

   type Ada_Tree_Array is array (Query_Index range <>) of Ada_Tree; --??? with
--     Predicate => Ada_Tree_Array'First = 1;

   function Image (X : Query_Count) return String is (Image (Integer (X)));

   subtype Ada_Tree_Kind is
     ASIS_Elems'Base range ASIS_Elems'Base'First .. A_Variant_List;

   function Image
     (Kind : Ada_Tree_Kind)
      return String is
     (Capitalize (Kind'Img));

   function Is_Null (Tree : Ada_Tree_Base) return Boolean is (Tree = null);
   function T_Img (Tree : Ada_Tree_Base) return String;

   type Ada_Tree_Rec
     (Kind          : Ada_Tree_Kind;
      Subtree_Count : Query_Count)
   is record
      Sloc     : Asis.Text.Span := Asis.Text.Nil_Span;
      Checks   : Asis.Extensions.Run_Time_Check_Set :=
        Asis.Extensions.Empty_Check_Set;
      Subtrees : Ada_Tree_Array (1 .. Subtree_Count);

      --  Changes to node kinds and subtrees are typically benign here; handled
      --  automatically by tables in asis. However when the following variant
      --  part changes, various corresponding changes need to be done by hand.
      --  In particular, the following files generally need to be visited:
      --
      --     tools/tool_utils/ada_trees-asis_to_tree.adb
      --     tools/tool_utils/ada_trees-formatting-tree_to_ada.adb
      --     tools/tool_utils/ada_trees-generate_factory.adb
      --     tools/tool_utils/ada_trees-self_rep.adb
      --     tools/gnat2xml/gnat2xml-xsd.adb
      --     tools/gnat2xml/gnat2xml-xml.adb
      --     tools/gnat2xml/gnat2xml-xml2tree.adb

      case Kind is
         when A_Compilation_Unit | Def_Names =>
            Def_Name : Name_Id;

            case Kind is
               when A_Compilation_Unit =>
                  Unit_Kind      : Unit_Kinds;
                  Unit_Class     : Unit_Classes;
                  Unit_Origin    : Unit_Origins;
                  Unit_Full_Name : Name_Id;
                  Source_File    : Name_Id;

               when Def_Names =>
                  Def       : Name_Id;
                  Decl_Type : Name_Id;
               --  Type of declared name; corresponds to "type" attribute

               when others =>
                  null;
            end case;

         when Flat_Expression_Kinds =>
            Expr_Type : Name_Id;
            --  Type of expression; also corresponds to "type" attribute

            case Kind is
               when Usage_Names =>
                  Ref_Name, Ref : Name_Id;
                  Decl_Kind     : Opt_ASIS_Elems := Not_An_Element;
                  --  If this node denotes a declaration, this is the kind of
                  --  declaration node. If this is an attribute name, this is
                  --  An_Unknown_Attribute. (We don't care which attribute it
                  --  is.) Otherwise nil.
                  Is_Predef : Boolean := False;
               --  True if this node denotes a declaration in the predefined
               --  environment (either standard Ada, or GNAT). Decl_Kind and
               --  Is_Predef are used in gnatpp, but not in gnat2xml.

               when An_Integer_Literal | A_Real_Literal | A_String_Literal =>
                  Lit_Val : Name_Id;

               when others =>
                  null;
            end case;

         when Flat_Pragma_Kinds =>
            Pragma_Name : Name_Id;

         when A_Parameter_Specification | A_Formal_Object_Declaration =>
            Mode : Asis.Mode_Kinds;

         when A_Comment =>
            Text : Name_Id;
            --  Text of the comment, including the leading "--"

         when others =>
            null;
      end case;
   end record; --??? with -- Ada_Tree_Rec
--         Predicate => Ada_Tree_Rec_OK (Ada_Tree_Rec);

   function Ada_Tree_Rec_OK (X : Ada_Tree_Rec) return Boolean;

   function Empty
     (Kind : Flat_List_Kinds;
      Sloc : Asis.Text.Span := Asis.Text.Nil_Span)
      return Ada_Tree;

   Empty_Tree_Array : constant Ada_Tree_Array := (1 .. 0 => <>);

   The_Nil : aliased Ada_Tree_Rec :=
     (Not_An_Element,
      Subtree_Count => 0,
      Sloc          => Asis.Text.Nil_Span,
      Checks        => Asis.Extensions.Empty_Check_Set,
      Subtrees      => Empty_Tree_Array);

   function Nil
     (Ignored_Sloc : Asis.Text.Span := Asis.Text.Nil_Span)
      return Ada_Tree is
     (The_Nil'Access);
--   is (new Ada_Tree_Rec'(The_Nil));

   function Is_Nil
     (Tree : Ada_Tree)
      return Boolean is
     (Tree.Kind = Not_An_Element);

   function Ref (T : Ada_Tree) return Name_Id;
   --  For a name that statically denotes something, returns the unique id of
   --  that thing. This means taking apart selected components, so for X.Y.Z,
   --  we return the unique id of Z.

   type Ada_Tree_Array_Ref is access Ada_Tree_Array;

   procedure Free_Tree_Rec is new Unchecked_Deallocation
     (Ada_Tree_Rec, Ada_Tree_Base);
   --  Free a single tree node
   procedure Free_Tree (T : Ada_Tree_Base);
   --  Free the tree along with all subtrees
   procedure Free_Tree_Array is new Unchecked_Deallocation
     (Ada_Tree_Array, Ada_Tree_Array_Ref);
   --  Free a single array
   procedure Free_Subtrees (A : Ada_Tree_Array_Ref);
   --  Free the array along with all subtrees

   function Get_Type (T : Ada_Tree) return Name_Id is
      (case T.Kind is
         when Def_Names => T.Decl_Type,
         when Flat_Expression_Kinds => T.Expr_Type,
         when others => raise Program_Error);
   --  Returns the "type" attribute

   package Ada_Tree_Vectors is new ASIS_UL.Vectors
     (Query_Index, Ada_Tree, Ada_Tree_Array);
   subtype Ada_Tree_Vector is Ada_Tree_Vectors.Vector;

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

   type Kind_Set is array (Ada_Tree_Kind) of Boolean with
        Pack => True;

   function Kinds_In_Class (Class : Flat_Element_Kinds'Base) return Kind_Set;

   function Cardinality (Kinds : Kind_Set) return Natural;
   --  Number of elements in Kinds

   procedure Put_Kinds (Kinds : Kind_Set);
   --  Print something like "This | That | The_Other" to standard output

   function Kind_In_Class
     (Kind  : Opt_ASIS_Elems;
      Class : Flat_Abstract_Classes)
      return  Boolean;
   --  True if Kind is in the Class

   function Get (Tree : Ada_Tree; Q : Structural_Queries) return Ada_Tree;
   procedure Set (Tree : Ada_Tree; Q : Structural_Queries; Subtree : Ada_Tree);
   --  Getters and setters

   generic
      Query : Structural_Queries;
      type Result_Type is new Ada_Tree;
   function Generic_Getter (Tree : Ada_Tree) return Result_Type;
   --  An instance will return Get (Tree, Query), returning the appropriate
   --  subtype. For example, instantiate like this:
   --     function Discriminant_Part is new Generic_Getter
   --       (Discriminant_Part, Definition_Class);
   --  to get an instance like this:
   --     function Discriminant_Part (Tree : Ada_Tree) return Definition_Class;

   generic
      Query : Structural_Queries;
      type Result_Type is new Ada_Tree;
   procedure Generic_Setter (Tree : Ada_Tree; Subtree : Result_Type);
   --  An instance will do Set (Tree, Query, Subtree).

   type Assoc is record
      Query   : Structural_Queries;
      Subtree : Ada_Tree;
   end record;

   type Assoc_List is array (Query_Index range <>) of Assoc;

   function Make
     (Kind     : Opt_ASIS_Elems;
      Subtrees : Assoc_List     := (1 .. 0 => <>);
      Sloc     : Asis.Text.Span := Asis.Text.Nil_Span)
      return     Ada_Tree with
      Pre => Subtrees'First = 1 and then Subtrees'Last = Num_Queries (Kind);
      --  Make a new Ada_Tree with the given Kind, Subtrees, and Sloc. Other
      --  components (the ones in the variant part) are not filled in.

   function Make_List
     (Kind     : Flat_List_Kinds;
      Subtrees : Ada_Tree_Array := Empty_Tree_Array;
      Sloc     : Asis.Text.Span := Asis.Text.Nil_Span)
      return     Ada_Tree;
   --  Make a new list with the given Kind, Subtrees, and Sloc.

   function Clone (Tree : Ada_Tree) return Ada_Tree;
   --  Returns a deep copy of Tree

   function Q_Name
     (Q    : Structural_Queries)
      return String is
     (Capitalize (Strip_Article (Q'Img)));
   --  Name of the Query function in the Factory child package

   function Constructor_Name
     (Class : Ada_Tree_Kind)
      return  String is
     ((if Class in Boolean_Elems then "Make_" else "") &
      Capitalize (Strip_Article (Class'Img)));
   --  Name of the constructor function in the Factory child package. We
   --  prepend a "Make_" prefix for the booleans, because some of those
   --  are reserved words.

   List_Component_Type : constant array (Flat_List_Kinds) of Classes :=
   --  Mapping from list kinds to their component kinds. For example a
   --  A_Declarative_Item_List is a list of A_Declarative_Item_Class elements.

     (An_Element_List                   => An_Element_Class,
      An_Association_List               => An_Association_Class,
      A_Component_Clause_List           => A_Component_Clause,
      A_Context_Clause_List             => A_Context_Clause_Class,
      A_Declaration_List                => A_Declaration_Class,
      A_Declarative_Item_List           => A_Declarative_Item_Class,
      A_Definition_List                 => A_Definition_Class,
      A_Discrete_Range_List             => A_Discrete_Range_Class,
      A_Discriminant_Association_List   => A_Discriminant_Association,
      A_Discriminant_Specification_List => A_Discriminant_Specification,
      A_Defining_Name_List              => A_Defining_Name_Class,
      An_Exception_Handler_List         => An_Exception_Handler,
      An_Expression_List                => An_Expression_Class,
      A_Name_List                       => A_Name_Class,
      A_Parameter_Specification_List    => A_Parameter_Specification,
      A_Path_List                       => A_Path_Class,
      A_Record_Component_List           => A_Record_Component_Class,
      A_Statement_List                  => A_Statement_Class,
      A_Variant_List                    => A_Variant);

   function Hash (Key : Name_Id) return Ada.Containers.Hash_Type;

   --  Symbol_Table is a mapping from Def to Symbol_Table_Entry. For now, this
   --  only works within a single unit. The Def_Id is the defining name that
   --  has that Def_Name, and Decl is the declaration that declares it (i.e.
   --  the innermost enclosing declaration).

   type Symbol_Table_Entry is record
      Decl   : Ada_Tree;
      Def_Id : Ada_Tree;
   end record;

   package Symbol_Tables is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Id,
      Element_Type    => Symbol_Table_Entry,
      Hash            => Hash,
      Equivalent_Keys => "=",
      "="             => "=");

   use Symbol_Tables;
   subtype Symbol_Table is Symbol_Tables.Map;

   Symtab : Symbol_Table;

   procedure Resolve_Symbols (Tree : Ada_Tree);
   --  Insert entries for Tree into Symtab

   function Decl_Of_Def
     (Symtab : Symbol_Table; Def_Id : Ada_Tree) return Ada_Tree with
       Pre => Def_Id.Kind in Def_Names;
   --  Returns the declaration containing the given defining name. So for
   --  "package P is..." this takes you from P to the package declaration.

   function Decl_Of_Def_Kind
     (Symtab : Symbol_Table;
      Def_Id : Ada_Tree)
      return   Opt_ASIS_Elems with
      Post => Decl_Of_Def_Kind'Result in
        Flat_Declaration_Kinds | Not_An_Element;
      --  Same as "Decl_Of_Def (Symtab, Def_Id)", except Nil if there is none.

   function Spec_Of_Body
     (Symtab : Symbol_Table; Body_Def : Ada_Tree) return Ada_Tree with
       Pre => Body_Def.Kind in Def_Names;
   --  Given the defining name of a body, returns the defining name of the
   --  corresponding first declaration.

end Ada_Trees;