1------------------------------------------------------------------------------ 2-- -- 3-- GNAT2XML COMPONENTS -- 4-- -- 5-- G N A T 2 X M L . A D A _ T R E E S -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 2012-2015, AdaCore -- 10-- -- 11-- Gnat2xml is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 2, or (at your option) any later -- 14-- version. Gnat2xml is distributed in the hope that it will be useful, -- 15-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- 16-- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- 17-- Public License for more details. You should have received a copy of the -- 18-- GNU General Public License distributed with GNAT; see file COPYING. If -- 19-- not, write to the Free Software Foundation, 59 Temple Place Suite 330, -- 20-- Boston, MA 02111-1307, USA. -- 21-- The gnat2xml tool was derived from the Avatox sources. -- 22------------------------------------------------------------------------------ 23 24pragma Ada_2012; 25 26-- This package provides a data structure Ada_Tree for representing Ada syntax 27-- trees. An Ada_Tree has basically the same structure as the ASIS tree, but 28-- represented as a data type rather than various query functions. Unlike an 29-- ASIS tree, an Ada_Tree can be created and modified, as well as queried. 30 31with Unchecked_Deallocation; 32with Ada.Containers.Hashed_Maps; 33 34with Namet; use Namet; 35 36with A4G.Queries; use A4G; 37 38with Asis.Text; 39with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; 40 41with ASIS_UL.Debug; 42with ASIS_UL.Utilities; 43with ASIS_UL.Vectors; 44with ASIS_UL.String_Utilities; use ASIS_UL.String_Utilities; 45 46pragma Warnings (Off); -- imported for children 47with ASIS_UL.Dbg_Out; 48with Ada.Wide_Characters.Handling; use Ada.Wide_Characters.Handling; 49use Ada; 50pragma Warnings (On); 51 52package Ada_Trees is 53 54 use ASIS_UL; 55 56 subtype Classes is 57 Flat_Element_Kinds'Base range Not_An_Element .. A_Statement_Class; 58 -- All classes, including the abstract ones, the lists, and the singleton 59 -- element kinds 60 61 subtype Opt_ASIS_Elems is 62 Flat_Element_Kinds'Base range Not_An_Element .. A_Compilation_Unit; 63 64 function Ekind (Element : Asis.Element) return Opt_ASIS_Elems; 65 66 use type A4G.Queries.Query_Index; 67 68 function Span (Element : Asis.Element) return Asis.Text.Span; 69 -- Return Nil_Element for gnat2xml-specific kinds 70 71 subtype ASIS_Elems is Opt_ASIS_Elems with 72 Predicate => ASIS_Elems /= Not_An_Element; 73 74 subtype Def_Names is Flat_Defining_Name_Kinds; 75 -- Defining occurences, such as A_Defining_Identifier 76 77 subtype Usage_Names is Flat_Usage_Name_Kinds; 78 -- References to defining occurrences, such as An_Identifier 79 80 subtype Name_Elems is ASIS_Elems with 81 Predicate => Name_Elems in Def_Names | Usage_Names; 82 83 subtype Boolean_Elems is 84 ASIS_Elems'Base range An_Aliased .. An_Is_Prefix_Notation; 85 86 subtype Other_Elems is ASIS_Elems with 87 Predicate => Other_Elems not in Name_Elems | Boolean_Elems; 88 89 subtype Unit_Kinds is Asis.Unit_Kinds; 90 subtype Unit_Classes is Asis.Unit_Classes; 91 subtype Unit_Origins is Asis.Unit_Origins; 92 use all type Unit_Kinds, Unit_Classes, Unit_Origins; 93 94 Main_Done : Boolean renames ASIS_UL.Utilities.Main_Done; 95 96 Debug_Mode : Boolean renames ASIS_UL.Debug.Debug_Flag_9; 97 98 ---------------- 99 100 use A4G.Queries; 101 102 type Ada_Tree_Rec; 103 104 type Ada_Tree_Base is access all Ada_Tree_Rec; 105 subtype Ada_Tree is Ada_Tree_Base with 106 Predicate => Ada_Tree_Rec_OK (Ada_Tree.all); 107 108 type Ada_Tree_Array is array (Query_Index range <>) of Ada_Tree; --??? with 109-- Predicate => Ada_Tree_Array'First = 1; 110 111 function Image (X : Query_Count) return String is (Image (Integer (X))); 112 113 subtype Ada_Tree_Kind is 114 ASIS_Elems'Base range ASIS_Elems'Base'First .. A_Variant_List; 115 116 function Image 117 (Kind : Ada_Tree_Kind) 118 return String is 119 (Capitalize (Kind'Img)); 120 121 function T_Img (Tree : Ada_Tree_Base) return String; 122 123 type Ada_Tree_Rec 124 (Kind : Ada_Tree_Kind; 125 Subtree_Count : Query_Count) 126 is record 127 Sloc : Asis.Text.Span := Asis.Text.Nil_Span; 128 Subtrees : Ada_Tree_Array (1 .. Subtree_Count); 129 Checks : Asis.Extensions.Run_Time_Check_Set := 130 Asis.Extensions.Empty_Check_Set; 131 132 -- Changes to node kinds and subtrees are typically benign here; handled 133 -- automatically by tables in asis. However when the following variant 134 -- part changes, various corresponding changes need to be done by hand. 135 -- In particular, the following files generally need to be visited: 136 -- 137 -- tools/tool_utils/ada_trees-asis_to_tree.adb 138 -- tools/tool_utils/ada_trees-formatting-tree_to_ada.adb 139 -- tools/tool_utils/ada_trees-generate_factory.adb 140 -- tools/tool_utils/ada_trees-self_rep.adb 141 -- tools/gnat2xml/gnat2xml-xsd.adb 142 -- tools/gnat2xml/gnat2xml-xml.adb 143 -- tools/gnat2xml/gnat2xml-xml2tree.adb 144 145 case Kind is 146 when A_Compilation_Unit | Def_Names => 147 Def_Name : Name_Id; 148 149 case Kind is 150 when A_Compilation_Unit => 151 Unit_Kind : Unit_Kinds; 152 Unit_Class : Unit_Classes; 153 Unit_Origin : Unit_Origins; 154 Unit_Full_Name : Name_Id; 155 Source_File : Name_Id; 156 157 when Def_Names => 158 Def : Name_Id; 159 Decl_Type : Name_Id; 160 -- Type of declared name; corresponds to "type" attribute 161 162 when others => 163 null; 164 end case; 165 166 when Flat_Expression_Kinds => 167 Expr_Type : Name_Id; 168 -- Type of expression; also corresponds to "type" attribute 169 170 case Kind is 171 when Usage_Names => 172 Ref_Name, Ref : Name_Id; 173 Decl_Kind : Opt_ASIS_Elems := Not_An_Element; 174 -- If this node denotes a declaration, this is the kind of 175 -- declaration node. If this is an attribute name, this is 176 -- An_Unknown_Attribute. (We don't care which attribute it 177 -- is.) Otherwise nil. 178 Is_Predef : Boolean := False; 179 -- True if this node denotes a declaration in the predefined 180 -- environment (either standard Ada, or GNAT). Decl_Kind and 181 -- Is_Predef are used in gnatpp, but not in gnat2xml. 182 183 when An_Integer_Literal | A_Real_Literal | A_String_Literal => 184 Lit_Val : Name_Id; 185 186 when others => 187 null; 188 end case; 189 190 when Flat_Pragma_Kinds => 191 Pragma_Name : Name_Id; 192 193 when A_Parameter_Specification | A_Formal_Object_Declaration => 194 Mode : Asis.Mode_Kinds; 195 196 when A_Comment => 197 Text : Name_Id; 198 -- Text of the comment, including the leading "--" 199 200 when others => 201 null; 202 end case; 203 end record; --??? with -- Ada_Tree_Rec 204-- Predicate => Ada_Tree_Rec_OK (Ada_Tree_Rec); 205 206 function Ada_Tree_Rec_OK (X : Ada_Tree_Rec) return Boolean; 207 208 function Empty 209 (Kind : Flat_List_Kinds; 210 Sloc : Asis.Text.Span := Asis.Text.Nil_Span) 211 return Ada_Tree; 212 213 Empty_Tree_Array : constant Ada_Tree_Array := (1 .. 0 => <>); 214 215 The_Nil : aliased Ada_Tree_Rec := 216 (Not_An_Element, 217 Subtree_Count => 0, 218 Sloc => Asis.Text.Nil_Span, 219 Checks => Asis.Extensions.Empty_Check_Set, 220 Subtrees => Empty_Tree_Array); 221 222 function Nil 223 (Sloc : Asis.Text.Span := Asis.Text.Nil_Span) 224 return Ada_Tree is 225 (The_Nil'Access); 226-- is (new Ada_Tree_Rec'(The_Nil)); 227 228 function Is_Nil 229 (Tree : Ada_Tree) 230 return Boolean is 231 (Tree.Kind = Not_An_Element); 232 233 function Ref (T : Ada_Tree) return Name_Id; 234 -- For a name that statically denotes something, returns the unique id of 235 -- that thing. This means taking apart selected components, so for X.Y.Z, 236 -- we return the unique id of Z. 237 238 type Ada_Tree_Array_Ref is access Ada_Tree_Array; 239 240 procedure Free_Tree_Rec is new Unchecked_Deallocation 241 (Ada_Tree_Rec, Ada_Tree_Base); 242 -- Free a single tree node 243 procedure Free_Tree (T : Ada_Tree_Base); 244 -- Free the tree along with all subtrees 245 procedure Free_Tree_Array is new Unchecked_Deallocation 246 (Ada_Tree_Array, Ada_Tree_Array_Ref); 247 -- Free a single array 248 procedure Free_Subtrees (A : Ada_Tree_Array_Ref); 249 -- Free the array along with all subtrees 250 251 function Get_Type (T : Ada_Tree) return Name_Id is 252 (case T.Kind is 253 when Def_Names => T.Decl_Type, 254 when Flat_Expression_Kinds => T.Expr_Type, 255 when others => raise Program_Error); 256 -- Returns the "type" attribute 257 258 package Ada_Tree_Vectors is new ASIS_UL.Vectors 259 (Query_Index, Ada_Tree, Ada_Tree_Array); 260 subtype Ada_Tree_Vector is Ada_Tree_Vectors.Vector; 261 use Ada_Tree_Vectors; 262 263 ---------------- 264 265 type Kind_Set is array (Ada_Tree_Kind) of Boolean with 266 Pack => True; 267 268 function Kinds_In_Class (Class : Flat_Element_Kinds'Base) return Kind_Set; 269 270 function Cardinality (Kinds : Kind_Set) return Natural; 271 -- Number of elements in Kinds 272 273 procedure Put_Kinds (Kinds : Kind_Set); 274 -- Print something like "This | That | The_Other" to standard output 275 276 function Kind_In_Class 277 (Kind : Opt_ASIS_Elems; 278 Class : Flat_Abstract_Classes) 279 return Boolean; 280 -- True if Kind is in the Class 281 282 function Get (Tree : Ada_Tree; Q : Structural_Queries) return Ada_Tree; 283 procedure Set (Tree : Ada_Tree; Q : Structural_Queries; Subtree : Ada_Tree); 284 -- Getters and setters 285 286 generic 287 Query : Structural_Queries; 288 type Result_Type is new Ada_Tree; 289 function Generic_Getter (Tree : Ada_Tree) return Result_Type; 290 -- An instance will return Get (Tree, Query), returning the appropriate 291 -- subtype. For example, instantiate like this: 292 -- function Discriminant_Part is new Generic_Getter 293 -- (Discriminant_Part, Definition_Class); 294 -- to get an instance like this: 295 -- function Discriminant_Part (Tree : Ada_Tree) return Definition_Class; 296 297 generic 298 Query : Structural_Queries; 299 type Result_Type is new Ada_Tree; 300 procedure Generic_Setter (Tree : Ada_Tree; Subtree : Result_Type); 301 -- An instance will do Set (Tree, Query, Subtree). 302 303 type Assoc is record 304 Query : Structural_Queries; 305 Subtree : Ada_Tree; 306 end record; 307 308 type Assoc_List is array (Query_Index range <>) of Assoc; 309 310 function Make 311 (Kind : Opt_ASIS_Elems; 312 Subtrees : Assoc_List := (1 .. 0 => <>); 313 Sloc : Asis.Text.Span := Asis.Text.Nil_Span) 314 return Ada_Tree with 315 Pre => Subtrees'First = 1 and then Subtrees'Last = Num_Queries (Kind); 316 -- Make a new Ada_Tree with the given Kind, Subtrees, and Sloc. Other 317 -- components (the ones in the variant part) are not filled in. 318 319 function Make_List 320 (Kind : Flat_List_Kinds; 321 Subtrees : Ada_Tree_Array := Empty_Tree_Array; 322 Sloc : Asis.Text.Span := Asis.Text.Nil_Span) 323 return Ada_Tree; 324 -- Make a new list with the given Kind, Subtrees, and Sloc. 325 326 function Clone (Tree : Ada_Tree) return Ada_Tree; 327 -- Returns a deep copy of Tree 328 329 function Q_Name 330 (Q : Structural_Queries) 331 return String is 332 (Capitalize (Strip_Article (Q'Img))); 333 -- Name of the Query function in the Factory child package 334 335 function Constructor_Name 336 (Class : Ada_Tree_Kind) 337 return String is 338 ((if Class in Boolean_Elems then "Make_" else "") & 339 Capitalize (Strip_Article (Class'Img))); 340 -- Name of the constructor function in the Factory child package. We 341 -- prepend a "Make_" prefix for the booleans, because some of those 342 -- are reserved words. 343 344 List_Component_Type : constant array (Flat_List_Kinds) of Classes := 345 -- Mapping from list kinds to their component kinds. For example a 346 -- A_Declarative_Item_List is a list of A_Declarative_Item_Class elements. 347 348 (An_Element_List => An_Element_Class, 349 An_Association_List => An_Association_Class, 350 A_Component_Clause_List => A_Component_Clause, 351 A_Context_Clause_List => A_Context_Clause_Class, 352 A_Declaration_List => A_Declaration_Class, 353 A_Declarative_Item_List => A_Declarative_Item_Class, 354 A_Definition_List => A_Definition_Class, 355 A_Discrete_Range_List => A_Discrete_Range_Class, 356 A_Discriminant_Association_List => A_Discriminant_Association, 357 A_Discriminant_Specification_List => A_Discriminant_Specification, 358 A_Defining_Name_List => A_Defining_Name_Class, 359 An_Exception_Handler_List => An_Exception_Handler, 360 An_Expression_List => An_Expression_Class, 361 A_Name_List => A_Name_Class, 362 A_Parameter_Specification_List => A_Parameter_Specification, 363 A_Path_List => A_Path_Class, 364 A_Record_Component_List => A_Record_Component_Class, 365 A_Statement_List => A_Statement_Class, 366 A_Variant_List => A_Variant); 367 368 function Hash (Key : Name_Id) return Ada.Containers.Hash_Type; 369 370 -- Symbol_Table is a mapping from Def to Symbol_Table_Entry. For now, this 371 -- only works within a single unit. The Def_Id is the defining name that 372 -- has that Def_Name, and Decl is the declaration that declares it (i.e. 373 -- the innermost enclosing declaration). 374 375 type Symbol_Table_Entry is record 376 Decl : Ada_Tree; 377 Def_Id : Ada_Tree; 378 end record; 379 380 package Symbol_Tables is new Ada.Containers.Hashed_Maps 381 (Key_Type => Name_Id, 382 Element_Type => Symbol_Table_Entry, 383 Hash => Hash, 384 Equivalent_Keys => "=", 385 "=" => "="); 386 387 use Symbol_Tables; 388 subtype Symbol_Table is Symbol_Tables.Map; 389 390 Symtab : Symbol_Table; 391 392 procedure Resolve_Symbols (Tree : Ada_Tree); 393 -- Insert entries for Tree into Symtab 394 395 function Decl_Of_Def 396 (Symtab : Symbol_Table; Def_Id : Ada_Tree) return Ada_Tree with 397 Pre => Def_Id.Kind in Def_Names; 398 -- Returns the declaration containing the given defining name. So for 399 -- "package P is..." this takes you from P to the package declaration. 400 401 function Decl_Of_Def_Kind 402 (Symtab : Symbol_Table; 403 Def_Id : Ada_Tree) 404 return Opt_ASIS_Elems with 405 Post => Decl_Of_Def_Kind'Result in 406 Flat_Declaration_Kinds | Not_An_Element; 407 -- Same as "Decl_Of_Def (Symtab, Def_Id)", except Nil if there is none. 408 409 function Spec_Of_Body 410 (Symtab : Symbol_Table; Body_Def : Ada_Tree) return Ada_Tree with 411 Pre => Body_Def.Kind in Def_Names; 412 -- Given the defining name of a body, returns the defining name of the 413 -- corresponding first declaration. 414 415 Assert_Enabled : Boolean := False; 416 -- Set to True in body if assertions are enabled. This should really be a 417 -- constant, but there's no easy mechanism for that. 418 419end Ada_Trees; 420