asis_2019.0.0_3ca32fa2/tools/tool_utils/ada_trees.ads

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
------------------------------------------------------------------------------
--                                                                          --
--                            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;