← Back to branch summary

~ubuntu-branches/ubuntu/karmic/asis/karmic

« back to all changes in this revision

Viewing changes to asis/a4g-nencl_el.adb

  • Committer: Bazaar Package Importer
  • Author(s): Thomas Quinot
  • Date: 2002-03-03 19:55:58 UTC
  • Revision ID: james.westby@ubuntu.com-20020303195558-g7dp4vaq1zdkf814
Tags: upstream-3.14p
Import upstream version 3.14p

Show diffs side-by-side

added added

removed removed

Lines of Context:
asis/a4g-nencl_el.adb
 
1
------------------------------------------------------------------------------
 
2
--                                                                          --
 
3
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
 
4
--                                                                          --
 
5
--                         A 4 G . N E N C L _ E L                          --
 
6
--                                                                          --
 
7
--                                 B o d y                                  --
 
8
--                                                                          --
 
9
--            Copyright (c) 1995-1999, Free Software Foundation, Inc.       --
 
10
--                                                                          --
 
11
-- ASIS-for-GNAT 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. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
 
15
-- ful, 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 ASIS-for-GNAT; see file     --
 
19
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
 
20
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
 
21
--                                                                          --
 
22
-- As a special exception,  if other files  instantiate  generics from this --
 
23
-- unit, or you link  this unit with other files  to produce an executable, --
 
24
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
 
25
-- covered  by the  GNU  General  Public  License.  This exception does not --
 
26
-- however invalidate  any other reasons why  the executable file  might be --
 
27
-- covered by the  GNU Public License.                                      --
 
28
--                                                                          --
 
29
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
 
30
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
 
31
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
 
32
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
 
33
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
 
34
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
 
35
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
 
36
-- (http://www.gnat.com).                                                   --
 
37
--                                                                          --
 
38
------------------------------------------------------------------------------
 
39
 
 
40
with System.Assertions;
 
41
with Ada.Exceptions;
 
42
 
 
43
with Asis.Exceptions; use Asis.Exceptions;
 
44
with Asis.Elements;   use Asis.Elements;
 
45
 
 
46
with Asis.Set_Get;    use Asis.Set_Get;
 
47
with A4G.Int_Knds;    use A4G.Int_Knds;
 
48
with A4G.Queries;     use A4G.Queries;
 
49
with A4G.A_Types;     use A4G.A_Types;
 
50
with A4G.Mapping;     use A4G.Mapping;
 
51
with A4G.Vcheck;      use A4G.Vcheck;
 
52
with A4G.Encl_El;     use A4G.Encl_El;
 
53
 
 
54
with Types;           use Types;
 
55
with Atree;           use Atree;
 
56
with Sinfo;           use Sinfo;
 
57
with Nlists;          use Nlists;
 
58
with Stand;           use Stand;
 
59
 
 
60
package body A4G.Nencl_El is
 
61
 
 
62
   LT : String renames ASIS_Line_Terminator;
 
63
   Package_Name : String := "A4G.Nencl_El.";
 
64
 
 
65
   -----------------------------
 
66
   -- An_Expression_Enclosing --
 
67
   -----------------------------
 
68
 
 
69
   function An_Expression_Enclosing
 
70
     (Element : Asis.Element)
 
71
      return Asis.Element
 
72
   is
 
73
      Start_Elem           : Asis.Element := Element;
 
74
      Rough_Result_Node    : Node_Id;
 
75
      Rough_Result_Element : Asis.Element;
 
76
      Rough_Res_Spec_Case  : Special_Cases;
 
77
      Result_Element       : Asis.Element;
 
78
   begin
 
79
      Rough_Result_Node    := Get_Rough_Enclosing_Node (Element);
 
80
 
 
81
      if not (Sloc (Node (Start_Elem)) <= Standard_Location) then
 
82
         Set_Special_Case (Start_Elem, Not_A_Special_Case);
 
83
      end if;
 
84
 
 
85
      Rough_Result_Element := Node_To_Element_New
 
86
                                (Node             => Rough_Result_Node,
 
87
                                 Starting_Element => Start_Elem);
 
88
 
 
89
      if Is_Top_Of_Expanded_Generic (Rough_Result_Node) and then
 
90
         Is_From_Instance (Element)
 
91
      then
 
92
         --  ??? The content of this if statement is just a slightly edited
 
93
         --  ??? fragment of Enclosing_For_Explicit_Instance_Component
 
94
 
 
95
         if Nkind (Rough_Result_Node) = N_Package_Declaration or else
 
96
            Nkind (Rough_Result_Node) = N_Package_Body
 
97
         then
 
98
            Rough_Res_Spec_Case := Expanded_Package_Instantiation;
 
99
            --  and here we have to correct the result:
 
100
            Set_Node (Rough_Result_Element, R_Node (Rough_Result_Element));
 
101
 
 
102
            if Nkind (Rough_Result_Node) = N_Package_Declaration then
 
103
               Set_Int_Kind (Rough_Result_Element, A_Package_Declaration);
 
104
            else
 
105
               Set_Int_Kind (Rough_Result_Element, A_Package_Body_Declaration);
 
106
            end if;
 
107
 
 
108
         else
 
109
            Rough_Res_Spec_Case := Expanded_Subprogram_Instantiation;
 
110
         end if;
 
111
 
 
112
         Set_Special_Case (Rough_Result_Element, Rough_Res_Spec_Case);
 
113
 
 
114
      end if;
 
115
 
 
116
      Result_Element       :=  Get_Enclosing
 
117
                                 (Approximation => Rough_Result_Element,
 
118
                                  Element       => Element);
 
119
      return Result_Element;
 
120
   exception
 
121
      when ASIS_Failed =>
 
122
         Add_Call_Information (
 
123
            Argument   => Element,
 
124
            Outer_Call => Package_Name & "An_Expression_Enclosing");
 
125
         raise;
 
126
      when others =>
 
127
         Raise_ASIS_Failed (
 
128
            Argument  => Element,
 
129
            Diagnosis => Package_Name & "An_Expression_Enclosing");
 
130
   end An_Expression_Enclosing;
 
131
 
 
132
   ------------------------------
 
133
   -- Get_Rough_Enclosing_Node --
 
134
   ------------------------------
 
135
 
 
136
   function Get_Rough_Enclosing_Node (Element : Asis.Element) return Node_Id
 
137
   is
 
138
      Arg_Node    : Node_Id := R_Node (Element);
 
139
      Result_Node : Node_Id;
 
140
      Res_Nkind   : Node_Kind;
 
141
 
 
142
      function Is_Acceptable_As_Rough_Enclosing_Node
 
143
        (N : Node_Id)
 
144
         return Boolean;
 
145
      --  this function encapsulates the condition for choosing
 
146
      --  the rough enclosing node
 
147
 
 
148
      function Is_Acceptable_As_Rough_Enclosing_Node
 
149
        (N : Node_Id)
 
150
         return Boolean
 
151
      is
 
152
         N_K    : Node_Kind := Nkind (N);
 
153
         Result : Boolean   := True;
 
154
      begin
 
155
 
 
156
         if not (Is_List_Member (N)
 
157
              or else
 
158
                (Nkind (Parent (N)) = N_Compilation_Unit or else
 
159
                 Nkind (Parent (N)) = N_Subunit))
 
160
         then
 
161
 
 
162
            Result := False;
 
163
 
 
164
         elsif N_K = N_Range                 or else
 
165
               N_K = N_Component_Association or else
 
166
               N_K = N_Subtype_Indication
 
167
         then
 
168
            Result := False;
 
169
 
 
170
         elsif N_K = N_Procedure_Call_Statement and then
 
171
               Nkind (Parent (N)) = N_Pragma
 
172
         then
 
173
            Result := False;
 
174
 
 
175
         elsif not Comes_From_Source (N) and then
 
176
               Sloc (N) > Standard_Location
 
177
         then
 
178
 
 
179
            if not (Is_From_Instance (Element)
 
180
                and then
 
181
                    Is_Top_Of_Expanded_Generic (N))
 
182
            then
 
183
               Result := False;
 
184
            end if;
 
185
 
 
186
         end if;
 
187
 
 
188
         return Result;
 
189
 
 
190
      end Is_Acceptable_As_Rough_Enclosing_Node;
 
191
 
 
192
   begin
 
193
      Result_Node := Parent (Arg_Node);
 
194
 
 
195
      while Present (Result_Node) and then
 
196
            not Is_Acceptable_As_Rough_Enclosing_Node (Result_Node)
 
197
      loop
 
198
         Result_Node := Parent (Result_Node);
 
199
 
 
200
         if Nkind (Result_Node) = N_Compilation_Unit then
 
201
            --  this means that there is no node list on the way up
 
202
            --  the tree, and we have to go back to the node
 
203
            --  for the unit declaration:
 
204
            if Is_Standard (Encl_Unit (Element)) then
 
205
               Result_Node := Standard_Package_Node;
 
206
            else
 
207
               Result_Node := Unit (Result_Node);
 
208
            end if;
 
209
 
 
210
            if Nkind (Result_Node) = N_Subunit then
 
211
               Result_Node := Proper_Body (Result_Node);
 
212
            end if;
 
213
 
 
214
            exit;
 
215
         end if;
 
216
 
 
217
      end loop;
 
218
 
 
219
      --  and here we have to take into account possible normalization
 
220
      --  of multi-identifier declarations:
 
221
      Res_Nkind := Nkind (Result_Node);
 
222
 
 
223
      if Res_Nkind = N_Object_Declaration         or else
 
224
         Res_Nkind = N_Number_Declaration         or else
 
225
         Res_Nkind = N_Discriminant_Specification or else
 
226
         Res_Nkind = N_Component_Declaration      or else
 
227
         Res_Nkind = N_Parameter_Specification    or else
 
228
         Res_Nkind = N_Exception_Declaration      or else
 
229
         Res_Nkind = N_Formal_Object_Declaration  or else
 
230
         Res_Nkind = N_With_Clause
 
231
      then
 
232
         Skip_Normalized_Declarations_Back (Result_Node);
 
233
      end if;
 
234
 
 
235
      return Result_Node;
 
236
 
 
237
   end Get_Rough_Enclosing_Node;
 
238
 
 
239
   -------------------
 
240
   -- Get_Enclosing --
 
241
   -------------------
 
242
 
 
243
   function Get_Enclosing
 
244
     (Approximation : Asis.Element;
 
245
      Element       : Asis.Element)
 
246
      return Asis.Element
 
247
   is
 
248
      --  we need two-level traversiong for searching for Enclosing Element:
 
249
      --  first, we go through the direct children of an approximate
 
250
      --  result, and none of them Is_Identical to Element, we repeat
 
251
      --  the search process for each direct child. We may implement
 
252
      --  this on top of Traverse_Element, but we prefer to code
 
253
      --  it manually on top ofA4G.Queries
 
254
 
 
255
      Result_Element : Asis.Element;
 
256
      Result_Found   : Boolean := False;
 
257
      --  needed to simulate the effect of Terminate_Immediatelly
 
258
 
 
259
      procedure Check_Possible_Enclosing
 
260
        (Appr_Enclosing : in Asis.Element);
 
261
      --  implements the first level of the search. Appr_Enclosing is
 
262
      --  the "approximate" Enclosing Element, and this procedure
 
263
      --  checks if some of its componets Is_Identical to Element
 
264
      --  (Element here is the parameter of Get_Enclosing function,
 
265
      --  as a global constant value inside Get_Enclosing, it is the
 
266
      --  same for all the (recursive) calls of Check_Possible_Enclosing
 
267
 
 
268
      ------------------------------
 
269
      -- Check_Possible_Enclosing --
 
270
      -------------------------------
 
271
      procedure Check_Possible_Enclosing
 
272
        (Appr_Enclosing : in Asis.Element)
 
273
      is
 
274
         Child_Access : Query_Array  := Appropriate_Queries (Appr_Enclosing);
 
275
         --  this is the way to traverse the direct childs
 
276
         Next_Child : Asis.Element;
 
277
 
 
278
         procedure Check_List (L : Asis.Element_List);
 
279
         --  checks if L contains a component which Is_Identical
 
280
         --  to (global) Element. Sets Result_Found ON if such a
 
281
         --  component is found
 
282
 
 
283
         procedure Check_List_Down (L : Asis.Element_List);
 
284
         --  calls Get_Enclosing for every component of L, by
 
285
         --  this the recursion and the second level of the search
 
286
         --  is implemented
 
287
 
 
288
         procedure Check_List (L : Asis.Element_List) is
 
289
         begin
 
290
            for L_El_Index in L'Range loop
 
291
               if Is_Identical (Element, L (L_El_Index)) then
 
292
                  Result_Found := True;
 
293
                  return;
 
294
               end if;
 
295
            end loop;
 
296
         end Check_List;
 
297
 
 
298
         procedure Check_List_Down (L : Asis.Element_List) is
 
299
         begin
 
300
            if Result_Found then
 
301
               return;
 
302
               --  it seems that we do not need this if... ???
 
303
            end if;
 
304
            for L_El_Index in L'Range loop
 
305
               Check_Possible_Enclosing (L (L_El_Index));
 
306
 
 
307
               if Result_Found then
 
308
                  return;
 
309
               end if;
 
310
            end loop;
 
311
         end Check_List_Down;
 
312
 
 
313
      begin  -- Check_Possible_Enclosing
 
314
         if Result_Found then
 
315
            return;
 
316
            --  now the only goal is to not disturb the setting of the
 
317
            --  global variable Result_Element to be returned as a result
 
318
         end if;
 
319
 
 
320
         --  first, setting the (global for this procedure) Result_Element:
 
321
         Result_Element := Appr_Enclosing;
 
322
         --  the first level of the search - checking all the direct
 
323
         --  childs:
 
324
         for Each_Query in Child_Access'Range loop
 
325
            case Child_Access (Each_Query).Query_Kind is
 
326
               when Bug =>
 
327
                  null;
 
328
               when Single_Element_Query =>
 
329
                  Next_Child :=
 
330
                     Child_Access (Each_Query).Func_Simple (Appr_Enclosing);
 
331
 
 
332
                  if Is_Identical (Element, Next_Child) then
 
333
                     Result_Found := True;
 
334
                     return;
 
335
                  end if;
 
336
 
 
337
               when Element_List_Query =>
 
338
                  declare
 
339
                     Child_List : Asis.Element_List :=
 
340
                        Child_Access (Each_Query).Func_List (Appr_Enclosing);
 
341
                  begin
 
342
                     Check_List (Child_List);
 
343
                     if Result_Found then
 
344
                        return;
 
345
                     end if;
 
346
                  end;
 
347
               when Element_List_Query_With_Boolean =>
 
348
                  declare
 
349
                     Child_List : Asis.Element_List :=
 
350
                        Child_Access (Each_Query).Func_List_Boolean
 
351
                           (Appr_Enclosing, Child_Access (Each_Query).Bool);
 
352
                  begin
 
353
                     Check_List (Child_List);
 
354
                     if Result_Found then
 
355
                        return;
 
356
                     end if;
 
357
                  end;
 
358
            end case;
 
359
         end loop;
 
360
 
 
361
         --  if we are here, we have hot found Element among the direct
 
362
         --  childs of Appr_Enclosing. So we have to traverse the direct
 
363
         --  childs again, but this time we have to go one step down,
 
364
         --  so here we have the second level of the search:
 
365
 
 
366
         for Each_Query in Child_Access'Range loop
 
367
            case Child_Access (Each_Query).Query_Kind is
 
368
               when Bug =>
 
369
                  null;
 
370
               when Single_Element_Query =>
 
371
                  Next_Child :=
 
372
                     Child_Access (Each_Query).Func_Simple (Appr_Enclosing);
 
373
 
 
374
                  --  and here - recursively one step down
 
375
                  if not Is_Nil (Next_Child) then
 
376
                     Check_Possible_Enclosing (Next_Child);
 
377
                     if Result_Found then
 
378
                        return;
 
379
                     end if;
 
380
                  end if;
 
381
 
 
382
               when Element_List_Query =>
 
383
                  declare
 
384
                     Child_List : Asis.Element_List :=
 
385
                        Child_Access (Each_Query).Func_List (Appr_Enclosing);
 
386
                  begin
 
387
                     --  and here - recursively one step down
 
388
                     Check_List_Down (Child_List);
 
389
                     if Result_Found then
 
390
                        return;
 
391
                     end if;
 
392
                  end;
 
393
               when Element_List_Query_With_Boolean =>
 
394
                  declare
 
395
                     Child_List : Asis.Element_List :=
 
396
                        Child_Access (Each_Query).Func_List_Boolean
 
397
                           (Appr_Enclosing, Child_Access (Each_Query).Bool);
 
398
                  begin
 
399
                     --  and here - recursively one step down
 
400
                     Check_List_Down (Child_List);
 
401
                     if Result_Found then
 
402
                        return;
 
403
                     end if;
 
404
                  end;
 
405
            end case;
 
406
         end loop;
 
407
      end Check_Possible_Enclosing;
 
408
 
 
409
   begin  -- Get_Enclosing
 
410
      Check_Possible_Enclosing (Approximation);
 
411
      pragma Assert (Result_Found);
 
412
      return Result_Element;
 
413
   exception
 
414
      when Assert_Error : System.Assertions.Assert_Failure =>
 
415
         Raise_ASIS_Failed (
 
416
            Argument  => Element,
 
417
            Diagnosis =>
 
418
                 Package_Name & "Get_Enclosing - "  & LT
 
419
               & "Assert_Failure at "
 
420
               &  Ada.Exceptions.Exception_Message (Assert_Error));
 
421
      when ASIS_Failed =>
 
422
         Add_Call_Information (
 
423
            Argument   => Element,
 
424
            Outer_Call => Package_Name & "Get_Enclosing");
 
425
         raise;
 
426
      when others =>
 
427
         Raise_ASIS_Failed (Package_Name & "Get_Enclosing");
 
428
   end Get_Enclosing;
 
429
 
 
430
   ---------------------------------------
 
431
   -- Skip_Normalized_Declarations_Back --
 
432
   ---------------------------------------
 
433
 
 
434
   procedure Skip_Normalized_Declarations_Back (Node : in out Node_Id) is
 
435
      Arg_Kind : Node_Kind := Nkind (Node);
 
436
   begin
 
437
      loop
 
438
         if Arg_Kind = N_Object_Declaration         or else
 
439
            Arg_Kind = N_Number_Declaration         or else
 
440
            Arg_Kind = N_Discriminant_Specification or else
 
441
            Arg_Kind = N_Component_Declaration      or else
 
442
            Arg_Kind = N_Parameter_Specification    or else
 
443
            Arg_Kind = N_Exception_Declaration      or else
 
444
            Arg_Kind = N_Formal_Object_Declaration
 
445
         then
 
446
            if Prev_Ids (Node) then
 
447
               Node := Prev (Node);
 
448
               while Nkind (Node) /= Arg_Kind loop
 
449
                  --  some implicit subtype decarations may be inserted by
 
450
                  --  the compiler in between the normalized declarations, so:
 
451
                  Node := Prev (Node);
 
452
               end loop;
 
453
            else
 
454
               return;
 
455
            end if;
 
456
         elsif Arg_Kind = N_With_Clause then
 
457
            if First_Name (Node) then
 
458
               return;
 
459
            else
 
460
               Node := Prev (Node);
 
461
            end if;
 
462
         else
 
463
            return;
 
464
            --  nothing to do!
 
465
         end if;
 
466
      end loop;
 
467
   end Skip_Normalized_Declarations_Back;
 
468
 
 
469
end A4G.Nencl_El;
 
 
b'\\ No newline at end of file'