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
|
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A 4 G . E N C L _ E L --
-- --
-- B o d y --
-- --
-- Copyright (c) 1995-1999, Free Software Foundation, Inc. --
-- --
-- ASIS-for-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 --
-- Software Foundation; either version 2, or (at your option) any later --
-- version. ASIS-for-GNAT is distributed in the hope that it will be use- --
-- ful, 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 ASIS-for-GNAT; see file --
-- COPYING. If not, write to the Free Software Foundation, 59 Temple Place --
-- - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the --
-- Software Engineering Laboratory of the Swiss Federal Institute of --
-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the --
-- Scientific Research Computer Center of Moscow State University (SRCC --
-- MSU), Russia, with funding partially provided by grants from the Swiss --
-- National Science Foundation and the Swiss Academy of Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Assertions;
with Asis; use Asis;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Set_Get; use Asis.Set_Get;
with A4G.A_Types; use A4G.A_Types;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Mapping; use A4G.Mapping;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.Encl_El_Old; use A4G.Encl_El_Old;
with Types; use Types;
with Atree; use Atree;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
with Nlists; use Nlists;
package body A4G.Encl_El is
Package_Name : constant String := "A4G.Encl_El.";
------------------------------------------------
-- The general approach to the implementation --
-- of the Enclosing_Element query --
------------------------------------------------
-- There are special cases and regular cases in obtaining an enclosing
-- element. The case is considered as regular when obtaining the
-- enclosing element consists in going one step up the ASIS "tree".
-- The special cases includes enclosing element for implicit
-- declarations subprogram declarations (but not for their components!),
-- when enclosing element is an explicit type declaration being the
-- cause for appearing this implicit declaration in the program text;
-- or expanded generic declarations, when enclosing element is the
-- corresponding generic instantiation etc.
--
-- Special cases are processed by special functions, and the
-- Get_Enclosing function covers all the regular cases.
--
-- Get_Enclosing is implemented on top of the switch which
--
-- The following situations are distinguished in the implementation
-- of Get_Enclosing:
--
-- 1. One step up the ASIS tree corresponds to one step up the GNAT
-- tree, and auto kind determination is possible for the
-- enclosing element
---------------------------------
-- Corresponding_Instantiation --
---------------------------------
function Corresponding_Instantiation
(Element : Asis.Element)
return Asis.Element
is
Argument_Node : Node_Id := Node (Element);
Argument_Kind : Internal_Element_Kinds := Int_Kind (Element);
Result_Node : Node_Id := Argument_Node;
Result_Kind : Internal_Element_Kinds;
Result_Unit : Asis.Compilation_Unit := Encl_Unit (Element);
begin
if Argument_Kind = A_Package_Declaration or else
Argument_Kind = A_Package_Body_Declaration
then
Argument_Node := Parent (Argument_Node);
if Nkind (Argument_Node) in N_Generic_Declaration and then
Is_List_Member (Result_Node) and then
List_Containing (Result_Node) =
Generic_Formal_Declarations (Argument_Node)
then
Result_Kind := A_Formal_Package_Declaration;
else
Result_Kind := A_Package_Instantiation;
end if;
else
if Argument_Kind = A_Procedure_Declaration or else
Argument_Kind = A_Procedure_Body_Declaration
then
Result_Kind := A_Procedure_Instantiation;
else
Result_Kind := A_Function_Instantiation;
end if;
-- we have to go the N_Package_Decalaration node of an
-- artificial package created by the compiler for a subprogram
-- instantiation - two steps up the tree are needed:
Result_Node := Parent (Result_Node);
if Argument_Kind = A_Procedure_Declaration or else
Argument_Kind = A_Function_Declaration
then
Result_Node := Parent (Result_Node);
end if;
end if;
if Nkind (Parent (Result_Node)) = N_Compilation_Unit then
-- library-level instantiation, therefore:
-- Result_Node := Original_Node (Result_Node); ????????
null; -- ???
-- ??? may not work for procedure instantiations, but let's
-- ??? see it first
else
-- "local" instantiation, therefore - one or two steps down the
-- declaration list to get in the instantiation node:
Result_Node := Next_Non_Pragma (Result_Node);
if Nkind (Result_Node) = N_Package_Body then
-- This is an expanded generic body
Result_Node := Next_Non_Pragma (Result_Node);
end if;
end if;
return Node_To_Element_New
(Node => Result_Node,
Internal_Kind => Result_Kind,
In_Unit => Result_Unit);
exception
when ASIS_Failed =>
Add_Call_Information (
Argument => Element,
Outer_Call => Package_Name & "Corresponding_Instantiation");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => Package_Name & "Corresponding_Instantiation");
end Corresponding_Instantiation;
-----------------------------------------------
-- Enclosing_For_Explicit_Instance_Component --
-----------------------------------------------
-- TEMPORARY SOLUTION! REQUIRES REVISING --
function Enclosing_For_Explicit_Instance_Component
(Element : Asis.Element)
return Asis.Element
is
Result_Element : Asis.Element;
Result_Node : Node_Id;
Result_Node_Kind : Node_Kind;
Res_Spec_Case : Special_Cases;
begin
Result_Element := Enclosing_Element_For_Explicit (Element);
-- and now we have to check if we are in the whole expanded
-- declaration
Result_Node := R_Node (Result_Element);
Result_Node_Kind := Nkind (Result_Node);
if (not Comes_From_Source (Result_Node) and then
not (Result_Node_Kind = N_Subtype_Declaration or else
Result_Node_Kind = N_Object_Declaration or else
Result_Node_Kind = N_Object_Renaming_Declaration))
or else
Is_Rewrite_Insertion (Result_Node) or else
(Nkind (Parent (Result_Node)) = N_Package_Body and then
not Comes_From_Source (Parent (Result_Node)))
or else
(Is_Rewrite_Substitution (Result_Node) and then
Nkind (Original_Node (Result_Node)) = N_Package_Instantiation)
-- Library-level package instantiation
then
-- this is an artificial package or subprogram declaration
-- created by the compiler as an expanded generic declaration
if Nkind (Result_Node) = N_Package_Declaration or else
Nkind (Result_Node) = N_Package_Body
then
Res_Spec_Case := Expanded_Package_Instantiation;
-- and here we have to correct the result:
Set_Node (Result_Element, R_Node (Result_Element));
if Nkind (Result_Node) = N_Package_Declaration then
Set_Int_Kind (Result_Element, A_Package_Declaration);
else
Set_Int_Kind (Result_Element, A_Package_Body_Declaration);
end if;
else
Res_Spec_Case := Expanded_Subprogram_Instantiation;
end if;
Set_Special_Case (Result_Element, Res_Spec_Case);
end if;
-- and we have to correct Is_Part_Of_Instance field of the result -
-- just in case. May be, it will not be necessary, if (and when)
-- Enclosing_Element_For_Explicit takes the corresponding fields
-- from its argument
Set_From_Instance (Result_Element, True);
return Result_Element;
end Enclosing_For_Explicit_Instance_Component;
------------------------------------
-- Enclosing_Element_For_Explicit --
------------------------------------
function Enclosing_Element_For_Explicit
(Element : Asis.Element)
return Asis.Element
renames A4G.Encl_El_Old.Enclosing_Element_For_Explicits_Old;
------------------------------------
-- Enclosing_Element_For_Implicit --
------------------------------------
function Enclosing_Element_For_Implicit
(Element : Asis.Element)
return Asis.Element
is
-- Argument-related objects:
Arg_Kind : Internal_Element_Kinds := Int_Kind (Element);
Arg_Node : Node_Id := Node (Element);
Arg_Ekind : Entity_Kind;
-- Result-related objects:
Result_Node : Node_Id;
Result_Element : Asis.Element;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
begin
case Arg_Kind is
when Internal_Defining_Name_Kinds =>
case Internal_Defining_Name_Kinds (Arg_Kind) is
when A_Defining_Identifier =>
Arg_Ekind := Ekind (Arg_Node);
if Arg_Ekind = E_Procedure then
Result_Kind := A_Procedure_Declaration;
elsif Arg_Ekind = E_Function then
Result_Kind := A_Function_Declaration;
elsif Arg_Ekind = E_Component then
Result_Kind := A_Component_Declaration;
elsif Arg_Ekind = E_Discriminant then
Result_Kind := A_Discriminant_Specification;
else
Not_Implemented_Yet (Diagnosis =>
"Asis.Elements.Enclosing_Element: not implemented yet "
& "for an implicit defining identifier representing "
& Entity_Kind'Image (Arg_Ekind));
end if;
when Internal_Defining_Operator_Kinds =>
Result_Kind := A_Function_Declaration;
when A_Defining_Character_Literal |
A_Defining_Enumeration_Literal =>
-- ??? just the same as for explicit elements.
-- ??? some aggregation needed???
Result_Kind := An_Enumeration_Literal_Specification;
when A_Defining_Expanded_Name =>
-- impossible, therefore:
pragma Assert (False);
null;
end case;
case Result_Kind is
when A_Procedure_Declaration |
A_Function_Declaration |
An_Enumeration_Literal_Specification =>
-- the result will be based on the same node,
-- and the same node should be kept for Node_Field_1 as the
-- associated type:
Result_Element := Element;
Set_Int_Kind (Result_Element, Result_Kind);
when A_Component_Declaration | A_Discriminant_Specification =>
-- this is the case of a component declaration of a derived
-- type. ASIS does not clearly say, what is Enclosing
-- Element in this case. What we are returning now is an
-- explicit component declaration/discriminant specification
-- of the parent type (see also Asis.Expressions, 17.6)
Result_Node := Parent (Arg_Node);
Result_Element := Node_To_Element_New (
Node => Result_Node,
Starting_Element => Element,
Internal_Kind => Result_Kind,
Inherited => True); -- ???
Set_Node_Field_1 (Result_Element, Node_Field_1 (Element));
when others =>
null;
-- just in case:
pragma Assert (False);
end case;
when A_Component_Declaration |
A_Discriminant_Specification |
An_Enumeration_Literal_Specification =>
Result_Node := Node_Field_1 (Element);
Result_Element := Node_To_Element_New (
Node => Result_Node,
Starting_Element => Element);
Set_From_Implicit (Result_Element, False);
Set_From_Inherited (Result_Element, False);
when A_Procedure_Declaration | A_Function_Declaration =>
Result_Node := Parent (Node_Field_1 (Element));
Result_Element := Node_To_Element_New (
Node => Result_Node,
Starting_Element => Element);
Set_From_Implicit (Result_Element, False);
Set_From_Inherited (Result_Element, False);
when others =>
Not_Implemented_Yet (Diagnosis =>
"Asis.Elements.Enclosing_Element: not implemented yet for "
& "Implicit Constructs of "
& Internal_Element_Kinds'Image (Arg_Kind)
& " kind");
end case;
return Result_Element;
exception
when System.Assertions.Assert_Failure | ASIS_Failed =>
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => Package_Name & "Enclosing_Element_For_Implicit");
end Enclosing_Element_For_Implicit;
end A4G.Encl_El;
|