|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S E M _ A U X --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- As a special exception, if other files instantiate generics from this --
|
|
|
22 -- unit, or you link this unit with other files to produce an executable, --
|
|
|
23 -- this unit does not by itself cause the resulting executable to be --
|
|
|
24 -- covered by the GNU General Public License. This exception does not --
|
|
|
25 -- however invalidate any other reasons why the executable file might be --
|
|
|
26 -- covered by the GNU Public License. --
|
|
|
27 -- --
|
|
|
28 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
30 -- --
|
|
|
31 ------------------------------------------------------------------------------
|
|
|
32
|
|
|
33 with Atree; use Atree;
|
|
|
34 with Einfo; use Einfo;
|
|
|
35 with Snames; use Snames;
|
|
|
36 with Stand; use Stand;
|
|
|
37 with Uintp; use Uintp;
|
|
|
38
|
|
|
39 package body Sem_Aux is
|
|
|
40
|
|
|
41 ----------------------
|
|
|
42 -- Ancestor_Subtype --
|
|
|
43 ----------------------
|
|
|
44
|
|
|
45 function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
|
|
|
46 begin
|
|
|
47 -- If this is first subtype, or is a base type, then there is no
|
|
|
48 -- ancestor subtype, so we return Empty to indicate this fact.
|
|
|
49
|
|
|
50 if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
|
|
|
51 return Empty;
|
|
|
52 end if;
|
|
|
53
|
|
|
54 declare
|
|
|
55 D : constant Node_Id := Declaration_Node (Typ);
|
|
|
56
|
|
|
57 begin
|
|
|
58 -- If we have a subtype declaration, get the ancestor subtype
|
|
|
59
|
|
|
60 if Nkind (D) = N_Subtype_Declaration then
|
|
|
61 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
|
|
|
62 return Entity (Subtype_Mark (Subtype_Indication (D)));
|
|
|
63 else
|
|
|
64 return Entity (Subtype_Indication (D));
|
|
|
65 end if;
|
|
|
66
|
|
|
67 -- If not, then no subtype indication is available
|
|
|
68
|
|
|
69 else
|
|
|
70 return Empty;
|
|
|
71 end if;
|
|
|
72 end;
|
|
|
73 end Ancestor_Subtype;
|
|
|
74
|
|
|
75 --------------------
|
|
|
76 -- Available_View --
|
|
|
77 --------------------
|
|
|
78
|
|
|
79 function Available_View (Ent : Entity_Id) return Entity_Id is
|
|
|
80 begin
|
|
|
81 -- Obtain the non-limited view (if available)
|
|
|
82
|
|
|
83 if Has_Non_Limited_View (Ent) then
|
|
|
84 return Get_Full_View (Non_Limited_View (Ent));
|
|
|
85
|
|
|
86 -- In all other cases, return entity unchanged
|
|
|
87
|
|
|
88 else
|
|
|
89 return Ent;
|
|
|
90 end if;
|
|
|
91 end Available_View;
|
|
|
92
|
|
|
93 --------------------
|
|
|
94 -- Constant_Value --
|
|
|
95 --------------------
|
|
|
96
|
|
|
97 function Constant_Value (Ent : Entity_Id) return Node_Id is
|
|
|
98 D : constant Node_Id := Declaration_Node (Ent);
|
|
|
99 Full_D : Node_Id;
|
|
|
100
|
|
|
101 begin
|
|
|
102 -- If we have no declaration node, then return no constant value. Not
|
|
|
103 -- clear how this can happen, but it does sometimes and this is the
|
|
|
104 -- safest approach.
|
|
|
105
|
|
|
106 if No (D) then
|
|
|
107 return Empty;
|
|
|
108
|
|
|
109 -- Normal case where a declaration node is present
|
|
|
110
|
|
|
111 elsif Nkind (D) = N_Object_Renaming_Declaration then
|
|
|
112 return Renamed_Object (Ent);
|
|
|
113
|
|
|
114 -- If this is a component declaration whose entity is a constant, it is
|
|
|
115 -- a prival within a protected function (and so has no constant value).
|
|
|
116
|
|
|
117 elsif Nkind (D) = N_Component_Declaration then
|
|
|
118 return Empty;
|
|
|
119
|
|
|
120 -- If there is an expression, return it
|
|
|
121
|
|
|
122 elsif Present (Expression (D)) then
|
|
|
123 return Expression (D);
|
|
|
124
|
|
|
125 -- For a constant, see if we have a full view
|
|
|
126
|
|
|
127 elsif Ekind (Ent) = E_Constant
|
|
|
128 and then Present (Full_View (Ent))
|
|
|
129 then
|
|
|
130 Full_D := Parent (Full_View (Ent));
|
|
|
131
|
|
|
132 -- The full view may have been rewritten as an object renaming
|
|
|
133
|
|
|
134 if Nkind (Full_D) = N_Object_Renaming_Declaration then
|
|
|
135 return Name (Full_D);
|
|
|
136 else
|
|
|
137 return Expression (Full_D);
|
|
|
138 end if;
|
|
|
139
|
|
|
140 -- Otherwise we have no expression to return
|
|
|
141
|
|
|
142 else
|
|
|
143 return Empty;
|
|
|
144 end if;
|
|
|
145 end Constant_Value;
|
|
|
146
|
|
|
147 ---------------------------------
|
|
|
148 -- Corresponding_Unsigned_Type --
|
|
|
149 ---------------------------------
|
|
|
150
|
|
|
151 function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is
|
|
|
152 pragma Assert (Is_Signed_Integer_Type (Typ));
|
|
|
153 Siz : constant Uint := Esize (Base_Type (Typ));
|
|
|
154 begin
|
|
|
155 if Siz = Esize (Standard_Short_Short_Integer) then
|
|
|
156 return Standard_Short_Short_Unsigned;
|
|
|
157 elsif Siz = Esize (Standard_Short_Integer) then
|
|
|
158 return Standard_Short_Unsigned;
|
|
|
159 elsif Siz = Esize (Standard_Unsigned) then
|
|
|
160 return Standard_Unsigned;
|
|
|
161 elsif Siz = Esize (Standard_Long_Integer) then
|
|
|
162 return Standard_Long_Unsigned;
|
|
|
163 elsif Siz = Esize (Standard_Long_Long_Integer) then
|
|
|
164 return Standard_Long_Long_Unsigned;
|
|
|
165 else
|
|
|
166 raise Program_Error;
|
|
|
167 end if;
|
|
|
168 end Corresponding_Unsigned_Type;
|
|
|
169
|
|
|
170 -----------------------------
|
|
|
171 -- Enclosing_Dynamic_Scope --
|
|
|
172 -----------------------------
|
|
|
173
|
|
|
174 function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
|
|
|
175 S : Entity_Id;
|
|
|
176
|
|
|
177 begin
|
|
|
178 -- The following test is an error defense against some syntax errors
|
|
|
179 -- that can leave scopes very messed up.
|
|
|
180
|
|
|
181 if Ent = Standard_Standard then
|
|
|
182 return Ent;
|
|
|
183 end if;
|
|
|
184
|
|
|
185 -- Normal case, search enclosing scopes
|
|
|
186
|
|
|
187 -- Note: the test for Present (S) should not be required, it defends
|
|
|
188 -- against an ill-formed tree.
|
|
|
189
|
|
|
190 S := Scope (Ent);
|
|
|
191 loop
|
|
|
192 -- If we somehow got an empty value for Scope, the tree must be
|
|
|
193 -- malformed. Rather than blow up we return Standard in this case.
|
|
|
194
|
|
|
195 if No (S) then
|
|
|
196 return Standard_Standard;
|
|
|
197
|
|
|
198 -- Quit if we get to standard or a dynamic scope. We must also
|
|
|
199 -- handle enclosing scopes that have a full view; required to
|
|
|
200 -- locate enclosing scopes that are synchronized private types
|
|
|
201 -- whose full view is a task type.
|
|
|
202
|
|
|
203 elsif S = Standard_Standard
|
|
|
204 or else Is_Dynamic_Scope (S)
|
|
|
205 or else (Is_Private_Type (S)
|
|
|
206 and then Present (Full_View (S))
|
|
|
207 and then Is_Dynamic_Scope (Full_View (S)))
|
|
|
208 then
|
|
|
209 return S;
|
|
|
210
|
|
|
211 -- Otherwise keep climbing
|
|
|
212
|
|
|
213 else
|
|
|
214 S := Scope (S);
|
|
|
215 end if;
|
|
|
216 end loop;
|
|
|
217 end Enclosing_Dynamic_Scope;
|
|
|
218
|
|
|
219 ------------------------
|
|
|
220 -- First_Discriminant --
|
|
|
221 ------------------------
|
|
|
222
|
|
|
223 function First_Discriminant (Typ : Entity_Id) return Entity_Id is
|
|
|
224 Ent : Entity_Id;
|
|
|
225
|
|
|
226 begin
|
|
|
227 pragma Assert
|
|
|
228 (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
|
|
|
229
|
|
|
230 Ent := First_Entity (Typ);
|
|
|
231
|
|
|
232 -- The discriminants are not necessarily contiguous, because access
|
|
|
233 -- discriminants will generate itypes. They are not the first entities
|
|
|
234 -- either because the tag must be ahead of them.
|
|
|
235
|
|
|
236 if Chars (Ent) = Name_uTag then
|
|
|
237 Ent := Next_Entity (Ent);
|
|
|
238 end if;
|
|
|
239
|
|
|
240 -- Skip all hidden stored discriminants if any
|
|
|
241
|
|
|
242 while Present (Ent) loop
|
|
|
243 exit when Ekind (Ent) = E_Discriminant
|
|
|
244 and then not Is_Completely_Hidden (Ent);
|
|
|
245
|
|
|
246 Ent := Next_Entity (Ent);
|
|
|
247 end loop;
|
|
|
248
|
|
|
249 -- Call may be on a private type with unknown discriminants, in which
|
|
|
250 -- case Ent is Empty, and as per the spec, we return Empty in this case.
|
|
|
251
|
|
|
252 -- Historical note: The assertion in previous versions that Ent is a
|
|
|
253 -- discriminant was overly cautious and prevented convenient application
|
|
|
254 -- of this function in the gnatprove context.
|
|
|
255
|
|
|
256 return Ent;
|
|
|
257 end First_Discriminant;
|
|
|
258
|
|
|
259 -------------------------------
|
|
|
260 -- First_Stored_Discriminant --
|
|
|
261 -------------------------------
|
|
|
262
|
|
|
263 function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
|
|
|
264 Ent : Entity_Id;
|
|
|
265
|
|
|
266 function Has_Completely_Hidden_Discriminant
|
|
|
267 (Typ : Entity_Id) return Boolean;
|
|
|
268 -- Scans the Discriminants to see whether any are Completely_Hidden
|
|
|
269 -- (the mechanism for describing non-specified stored discriminants)
|
|
|
270 -- Note that the entity list for the type may contain anonymous access
|
|
|
271 -- types created by expressions that constrain access discriminants.
|
|
|
272
|
|
|
273 ----------------------------------------
|
|
|
274 -- Has_Completely_Hidden_Discriminant --
|
|
|
275 ----------------------------------------
|
|
|
276
|
|
|
277 function Has_Completely_Hidden_Discriminant
|
|
|
278 (Typ : Entity_Id) return Boolean
|
|
|
279 is
|
|
|
280 Ent : Entity_Id;
|
|
|
281
|
|
|
282 begin
|
|
|
283 pragma Assert (Ekind (Typ) = E_Discriminant);
|
|
|
284
|
|
|
285 Ent := Typ;
|
|
|
286 while Present (Ent) loop
|
|
|
287
|
|
|
288 -- Skip anonymous types that may be created by expressions
|
|
|
289 -- used as discriminant constraints on inherited discriminants.
|
|
|
290
|
|
|
291 if Is_Itype (Ent) then
|
|
|
292 null;
|
|
|
293
|
|
|
294 elsif Ekind (Ent) = E_Discriminant
|
|
|
295 and then Is_Completely_Hidden (Ent)
|
|
|
296 then
|
|
|
297 return True;
|
|
|
298 end if;
|
|
|
299
|
|
|
300 Ent := Next_Entity (Ent);
|
|
|
301 end loop;
|
|
|
302
|
|
|
303 return False;
|
|
|
304 end Has_Completely_Hidden_Discriminant;
|
|
|
305
|
|
|
306 -- Start of processing for First_Stored_Discriminant
|
|
|
307
|
|
|
308 begin
|
|
|
309 pragma Assert
|
|
|
310 (Has_Discriminants (Typ)
|
|
|
311 or else Has_Unknown_Discriminants (Typ));
|
|
|
312
|
|
|
313 Ent := First_Entity (Typ);
|
|
|
314
|
|
|
315 if Chars (Ent) = Name_uTag then
|
|
|
316 Ent := Next_Entity (Ent);
|
|
|
317 end if;
|
|
|
318
|
|
|
319 if Has_Completely_Hidden_Discriminant (Ent) then
|
|
|
320 while Present (Ent) loop
|
|
|
321 exit when Ekind (Ent) = E_Discriminant
|
|
|
322 and then Is_Completely_Hidden (Ent);
|
|
|
323 Ent := Next_Entity (Ent);
|
|
|
324 end loop;
|
|
|
325 end if;
|
|
|
326
|
|
|
327 pragma Assert (Ekind (Ent) = E_Discriminant);
|
|
|
328
|
|
|
329 return Ent;
|
|
|
330 end First_Stored_Discriminant;
|
|
|
331
|
|
|
332 -------------------
|
|
|
333 -- First_Subtype --
|
|
|
334 -------------------
|
|
|
335
|
|
|
336 function First_Subtype (Typ : Entity_Id) return Entity_Id is
|
|
|
337 B : constant Entity_Id := Base_Type (Typ);
|
|
|
338 F : constant Node_Id := Freeze_Node (B);
|
|
|
339 Ent : Entity_Id;
|
|
|
340
|
|
|
341 begin
|
|
|
342 -- If the base type has no freeze node, it is a type in Standard, and
|
|
|
343 -- always acts as its own first subtype, except where it is one of the
|
|
|
344 -- predefined integer types. If the type is formal, it is also a first
|
|
|
345 -- subtype, and its base type has no freeze node. On the other hand, a
|
|
|
346 -- subtype of a generic formal is not its own first subtype. Its base
|
|
|
347 -- type, if anonymous, is attached to the formal type decl. from which
|
|
|
348 -- the first subtype is obtained.
|
|
|
349
|
|
|
350 if No (F) then
|
|
|
351 if B = Base_Type (Standard_Integer) then
|
|
|
352 return Standard_Integer;
|
|
|
353
|
|
|
354 elsif B = Base_Type (Standard_Long_Integer) then
|
|
|
355 return Standard_Long_Integer;
|
|
|
356
|
|
|
357 elsif B = Base_Type (Standard_Short_Short_Integer) then
|
|
|
358 return Standard_Short_Short_Integer;
|
|
|
359
|
|
|
360 elsif B = Base_Type (Standard_Short_Integer) then
|
|
|
361 return Standard_Short_Integer;
|
|
|
362
|
|
|
363 elsif B = Base_Type (Standard_Long_Long_Integer) then
|
|
|
364 return Standard_Long_Long_Integer;
|
|
|
365
|
|
|
366 elsif Is_Generic_Type (Typ) then
|
|
|
367 if Present (Parent (B)) then
|
|
|
368 return Defining_Identifier (Parent (B));
|
|
|
369 else
|
|
|
370 return Defining_Identifier (Associated_Node_For_Itype (B));
|
|
|
371 end if;
|
|
|
372
|
|
|
373 else
|
|
|
374 return B;
|
|
|
375 end if;
|
|
|
376
|
|
|
377 -- Otherwise we check the freeze node, if it has a First_Subtype_Link
|
|
|
378 -- then we use that link, otherwise (happens with some Itypes), we use
|
|
|
379 -- the base type itself.
|
|
|
380
|
|
|
381 else
|
|
|
382 Ent := First_Subtype_Link (F);
|
|
|
383
|
|
|
384 if Present (Ent) then
|
|
|
385 return Ent;
|
|
|
386 else
|
|
|
387 return B;
|
|
|
388 end if;
|
|
|
389 end if;
|
|
|
390 end First_Subtype;
|
|
|
391
|
|
|
392 -------------------------
|
|
|
393 -- First_Tag_Component --
|
|
|
394 -------------------------
|
|
|
395
|
|
|
396 function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
|
|
|
397 Comp : Entity_Id;
|
|
|
398 Ctyp : Entity_Id;
|
|
|
399
|
|
|
400 begin
|
|
|
401 Ctyp := Typ;
|
|
|
402 pragma Assert (Is_Tagged_Type (Ctyp));
|
|
|
403
|
|
|
404 if Is_Class_Wide_Type (Ctyp) then
|
|
|
405 Ctyp := Root_Type (Ctyp);
|
|
|
406 end if;
|
|
|
407
|
|
|
408 if Is_Private_Type (Ctyp) then
|
|
|
409 Ctyp := Underlying_Type (Ctyp);
|
|
|
410
|
|
|
411 -- If the underlying type is missing then the source program has
|
|
|
412 -- errors and there is nothing else to do (the full-type declaration
|
|
|
413 -- associated with the private type declaration is missing).
|
|
|
414
|
|
|
415 if No (Ctyp) then
|
|
|
416 return Empty;
|
|
|
417 end if;
|
|
|
418 end if;
|
|
|
419
|
|
|
420 Comp := First_Entity (Ctyp);
|
|
|
421 while Present (Comp) loop
|
|
|
422 if Is_Tag (Comp) then
|
|
|
423 return Comp;
|
|
|
424 end if;
|
|
|
425
|
|
|
426 Comp := Next_Entity (Comp);
|
|
|
427 end loop;
|
|
|
428
|
|
|
429 -- No tag component found
|
|
|
430
|
|
|
431 return Empty;
|
|
|
432 end First_Tag_Component;
|
|
|
433
|
|
|
434 ---------------------
|
|
|
435 -- Get_Binary_Nkind --
|
|
|
436 ---------------------
|
|
|
437
|
|
|
438 function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
|
|
|
439 begin
|
|
|
440 case Chars (Op) is
|
|
|
441 when Name_Op_Add => return N_Op_Add;
|
|
|
442 when Name_Op_Concat => return N_Op_Concat;
|
|
|
443 when Name_Op_Expon => return N_Op_Expon;
|
|
|
444 when Name_Op_Subtract => return N_Op_Subtract;
|
|
|
445 when Name_Op_Mod => return N_Op_Mod;
|
|
|
446 when Name_Op_Multiply => return N_Op_Multiply;
|
|
|
447 when Name_Op_Divide => return N_Op_Divide;
|
|
|
448 when Name_Op_Rem => return N_Op_Rem;
|
|
|
449 when Name_Op_And => return N_Op_And;
|
|
|
450 when Name_Op_Eq => return N_Op_Eq;
|
|
|
451 when Name_Op_Ge => return N_Op_Ge;
|
|
|
452 when Name_Op_Gt => return N_Op_Gt;
|
|
|
453 when Name_Op_Le => return N_Op_Le;
|
|
|
454 when Name_Op_Lt => return N_Op_Lt;
|
|
|
455 when Name_Op_Ne => return N_Op_Ne;
|
|
|
456 when Name_Op_Or => return N_Op_Or;
|
|
|
457 when Name_Op_Xor => return N_Op_Xor;
|
|
|
458 when others => raise Program_Error;
|
|
|
459 end case;
|
|
|
460 end Get_Binary_Nkind;
|
|
|
461
|
|
|
462 -----------------------
|
|
|
463 -- Get_Called_Entity --
|
|
|
464 -----------------------
|
|
|
465
|
|
|
466 function Get_Called_Entity (Call : Node_Id) return Entity_Id is
|
|
|
467 Nam : constant Node_Id := Name (Call);
|
|
|
468 Id : Entity_Id;
|
|
|
469
|
|
|
470 begin
|
|
|
471 if Nkind (Nam) = N_Explicit_Dereference then
|
|
|
472 Id := Etype (Nam);
|
|
|
473 pragma Assert (Ekind (Id) = E_Subprogram_Type);
|
|
|
474
|
|
|
475 elsif Nkind (Nam) = N_Selected_Component then
|
|
|
476 Id := Entity (Selector_Name (Nam));
|
|
|
477
|
|
|
478 elsif Nkind (Nam) = N_Indexed_Component then
|
|
|
479 Id := Entity (Selector_Name (Prefix (Nam)));
|
|
|
480
|
|
|
481 else
|
|
|
482 Id := Entity (Nam);
|
|
|
483 end if;
|
|
|
484
|
|
|
485 return Id;
|
|
|
486 end Get_Called_Entity;
|
|
|
487
|
|
|
488 -------------------
|
|
|
489 -- Get_Low_Bound --
|
|
|
490 -------------------
|
|
|
491
|
|
|
492 function Get_Low_Bound (E : Entity_Id) return Node_Id is
|
|
|
493 begin
|
|
|
494 if Ekind (E) = E_String_Literal_Subtype then
|
|
|
495 return String_Literal_Low_Bound (E);
|
|
|
496 else
|
|
|
497 return Type_Low_Bound (E);
|
|
|
498 end if;
|
|
|
499 end Get_Low_Bound;
|
|
|
500
|
|
|
501 ------------------
|
|
|
502 -- Get_Rep_Item --
|
|
|
503 ------------------
|
|
|
504
|
|
|
505 function Get_Rep_Item
|
|
|
506 (E : Entity_Id;
|
|
|
507 Nam : Name_Id;
|
|
|
508 Check_Parents : Boolean := True) return Node_Id
|
|
|
509 is
|
|
|
510 N : Node_Id;
|
|
|
511
|
|
|
512 begin
|
|
|
513 N := First_Rep_Item (E);
|
|
|
514 while Present (N) loop
|
|
|
515
|
|
|
516 -- Only one of Priority / Interrupt_Priority can be specified, so
|
|
|
517 -- return whichever one is present to catch illegal duplication.
|
|
|
518
|
|
|
519 if Nkind (N) = N_Pragma
|
|
|
520 and then
|
|
|
521 (Pragma_Name_Unmapped (N) = Nam
|
|
|
522 or else (Nam = Name_Priority
|
|
|
523 and then Pragma_Name (N) =
|
|
|
524 Name_Interrupt_Priority)
|
|
|
525 or else (Nam = Name_Interrupt_Priority
|
|
|
526 and then Pragma_Name (N) = Name_Priority))
|
|
|
527 then
|
|
|
528 if Check_Parents then
|
|
|
529 return N;
|
|
|
530
|
|
|
531 -- If Check_Parents is False, return N if the pragma doesn't
|
|
|
532 -- appear in the Rep_Item chain of the parent.
|
|
|
533
|
|
|
534 else
|
|
|
535 declare
|
|
|
536 Par : constant Entity_Id := Nearest_Ancestor (E);
|
|
|
537 -- This node represents the parent type of type E (if any)
|
|
|
538
|
|
|
539 begin
|
|
|
540 if No (Par) then
|
|
|
541 return N;
|
|
|
542
|
|
|
543 elsif not Present_In_Rep_Item (Par, N) then
|
|
|
544 return N;
|
|
|
545 end if;
|
|
|
546 end;
|
|
|
547 end if;
|
|
|
548
|
|
|
549 elsif Nkind (N) = N_Attribute_Definition_Clause
|
|
|
550 and then
|
|
|
551 (Chars (N) = Nam
|
|
|
552 or else (Nam = Name_Priority
|
|
|
553 and then Chars (N) = Name_Interrupt_Priority))
|
|
|
554 then
|
|
|
555 if Check_Parents or else Entity (N) = E then
|
|
|
556 return N;
|
|
|
557 end if;
|
|
|
558
|
|
|
559 elsif Nkind (N) = N_Aspect_Specification
|
|
|
560 and then
|
|
|
561 (Chars (Identifier (N)) = Nam
|
|
|
562 or else
|
|
|
563 (Nam = Name_Priority
|
|
|
564 and then Chars (Identifier (N)) = Name_Interrupt_Priority))
|
|
|
565 then
|
|
|
566 if Check_Parents then
|
|
|
567 return N;
|
|
|
568
|
|
|
569 elsif Entity (N) = E then
|
|
|
570 return N;
|
|
|
571 end if;
|
|
145
|
572
|
|
|
573 -- A Ghost-related aspect, if disabled, may have been replaced by a
|
|
|
574 -- null statement.
|
|
|
575
|
|
|
576 elsif Nkind (N) = N_Null_Statement then
|
|
|
577 N := Original_Node (N);
|
|
111
|
578 end if;
|
|
|
579
|
|
|
580 Next_Rep_Item (N);
|
|
|
581 end loop;
|
|
|
582
|
|
|
583 return Empty;
|
|
|
584 end Get_Rep_Item;
|
|
|
585
|
|
|
586 function Get_Rep_Item
|
|
|
587 (E : Entity_Id;
|
|
|
588 Nam1 : Name_Id;
|
|
|
589 Nam2 : Name_Id;
|
|
|
590 Check_Parents : Boolean := True) return Node_Id
|
|
|
591 is
|
|
|
592 Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
|
|
|
593 Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);
|
|
|
594
|
|
|
595 N : Node_Id;
|
|
|
596
|
|
|
597 begin
|
|
|
598 -- Check both Nam1_Item and Nam2_Item are present
|
|
|
599
|
|
|
600 if No (Nam1_Item) then
|
|
|
601 return Nam2_Item;
|
|
|
602 elsif No (Nam2_Item) then
|
|
|
603 return Nam1_Item;
|
|
|
604 end if;
|
|
|
605
|
|
|
606 -- Return the first node encountered in the list
|
|
|
607
|
|
|
608 N := First_Rep_Item (E);
|
|
|
609 while Present (N) loop
|
|
|
610 if N = Nam1_Item or else N = Nam2_Item then
|
|
|
611 return N;
|
|
|
612 end if;
|
|
|
613
|
|
|
614 Next_Rep_Item (N);
|
|
|
615 end loop;
|
|
|
616
|
|
|
617 return Empty;
|
|
|
618 end Get_Rep_Item;
|
|
|
619
|
|
|
620 --------------------
|
|
|
621 -- Get_Rep_Pragma --
|
|
|
622 --------------------
|
|
|
623
|
|
|
624 function Get_Rep_Pragma
|
|
|
625 (E : Entity_Id;
|
|
|
626 Nam : Name_Id;
|
|
|
627 Check_Parents : Boolean := True) return Node_Id
|
|
|
628 is
|
|
|
629 N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents);
|
|
|
630
|
|
|
631 begin
|
|
|
632 if Present (N) and then Nkind (N) = N_Pragma then
|
|
|
633 return N;
|
|
|
634 end if;
|
|
|
635
|
|
|
636 return Empty;
|
|
|
637 end Get_Rep_Pragma;
|
|
|
638
|
|
|
639 function Get_Rep_Pragma
|
|
|
640 (E : Entity_Id;
|
|
|
641 Nam1 : Name_Id;
|
|
|
642 Nam2 : Name_Id;
|
|
|
643 Check_Parents : Boolean := True) return Node_Id
|
|
|
644 is
|
|
|
645 Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
|
|
|
646 Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);
|
|
|
647
|
|
|
648 N : Node_Id;
|
|
|
649
|
|
|
650 begin
|
|
|
651 -- Check both Nam1_Item and Nam2_Item are present
|
|
|
652
|
|
|
653 if No (Nam1_Item) then
|
|
|
654 return Nam2_Item;
|
|
|
655 elsif No (Nam2_Item) then
|
|
|
656 return Nam1_Item;
|
|
|
657 end if;
|
|
|
658
|
|
|
659 -- Return the first node encountered in the list
|
|
|
660
|
|
|
661 N := First_Rep_Item (E);
|
|
|
662 while Present (N) loop
|
|
|
663 if N = Nam1_Item or else N = Nam2_Item then
|
|
|
664 return N;
|
|
|
665 end if;
|
|
|
666
|
|
|
667 Next_Rep_Item (N);
|
|
|
668 end loop;
|
|
|
669
|
|
|
670 return Empty;
|
|
|
671 end Get_Rep_Pragma;
|
|
|
672
|
|
|
673 ---------------------
|
|
|
674 -- Get_Unary_Nkind --
|
|
|
675 ---------------------
|
|
|
676
|
|
|
677 function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
|
|
|
678 begin
|
|
|
679 case Chars (Op) is
|
|
|
680 when Name_Op_Abs => return N_Op_Abs;
|
|
|
681 when Name_Op_Subtract => return N_Op_Minus;
|
|
|
682 when Name_Op_Not => return N_Op_Not;
|
|
|
683 when Name_Op_Add => return N_Op_Plus;
|
|
|
684 when others => raise Program_Error;
|
|
|
685 end case;
|
|
|
686 end Get_Unary_Nkind;
|
|
|
687
|
|
|
688 ---------------------------------
|
|
|
689 -- Has_External_Tag_Rep_Clause --
|
|
|
690 ---------------------------------
|
|
|
691
|
|
|
692 function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
|
|
|
693 begin
|
|
|
694 pragma Assert (Is_Tagged_Type (T));
|
|
|
695 return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
|
|
|
696 end Has_External_Tag_Rep_Clause;
|
|
|
697
|
|
|
698 ------------------
|
|
|
699 -- Has_Rep_Item --
|
|
|
700 ------------------
|
|
|
701
|
|
|
702 function Has_Rep_Item
|
|
|
703 (E : Entity_Id;
|
|
|
704 Nam : Name_Id;
|
|
|
705 Check_Parents : Boolean := True) return Boolean
|
|
|
706 is
|
|
|
707 begin
|
|
|
708 return Present (Get_Rep_Item (E, Nam, Check_Parents));
|
|
|
709 end Has_Rep_Item;
|
|
|
710
|
|
|
711 function Has_Rep_Item
|
|
|
712 (E : Entity_Id;
|
|
|
713 Nam1 : Name_Id;
|
|
|
714 Nam2 : Name_Id;
|
|
|
715 Check_Parents : Boolean := True) return Boolean
|
|
|
716 is
|
|
|
717 begin
|
|
|
718 return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
|
|
|
719 end Has_Rep_Item;
|
|
|
720
|
|
|
721 function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
|
|
|
722 Item : Node_Id;
|
|
|
723
|
|
|
724 begin
|
|
|
725 pragma Assert
|
|
|
726 (Nkind_In (N, N_Aspect_Specification,
|
|
|
727 N_Attribute_Definition_Clause,
|
|
|
728 N_Enumeration_Representation_Clause,
|
|
|
729 N_Pragma,
|
|
|
730 N_Record_Representation_Clause));
|
|
|
731
|
|
|
732 Item := First_Rep_Item (E);
|
|
|
733 while Present (Item) loop
|
|
|
734 if Item = N then
|
|
|
735 return True;
|
|
|
736 end if;
|
|
|
737
|
|
|
738 Item := Next_Rep_Item (Item);
|
|
|
739 end loop;
|
|
|
740
|
|
|
741 return False;
|
|
|
742 end Has_Rep_Item;
|
|
|
743
|
|
|
744 --------------------
|
|
|
745 -- Has_Rep_Pragma --
|
|
|
746 --------------------
|
|
|
747
|
|
|
748 function Has_Rep_Pragma
|
|
|
749 (E : Entity_Id;
|
|
|
750 Nam : Name_Id;
|
|
|
751 Check_Parents : Boolean := True) return Boolean
|
|
|
752 is
|
|
|
753 begin
|
|
|
754 return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
|
|
|
755 end Has_Rep_Pragma;
|
|
|
756
|
|
|
757 function Has_Rep_Pragma
|
|
|
758 (E : Entity_Id;
|
|
|
759 Nam1 : Name_Id;
|
|
|
760 Nam2 : Name_Id;
|
|
|
761 Check_Parents : Boolean := True) return Boolean
|
|
|
762 is
|
|
|
763 begin
|
|
|
764 return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
|
|
|
765 end Has_Rep_Pragma;
|
|
|
766
|
|
|
767 --------------------------------
|
|
|
768 -- Has_Unconstrained_Elements --
|
|
|
769 --------------------------------
|
|
|
770
|
|
|
771 function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
|
|
|
772 U_T : constant Entity_Id := Underlying_Type (T);
|
|
|
773 begin
|
|
|
774 if No (U_T) then
|
|
|
775 return False;
|
|
|
776 elsif Is_Record_Type (U_T) then
|
|
|
777 return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
|
|
|
778 elsif Is_Array_Type (U_T) then
|
|
|
779 return Has_Unconstrained_Elements (Component_Type (U_T));
|
|
|
780 else
|
|
|
781 return False;
|
|
|
782 end if;
|
|
|
783 end Has_Unconstrained_Elements;
|
|
|
784
|
|
|
785 ----------------------
|
|
|
786 -- Has_Variant_Part --
|
|
|
787 ----------------------
|
|
|
788
|
|
|
789 function Has_Variant_Part (Typ : Entity_Id) return Boolean is
|
|
|
790 FSTyp : Entity_Id;
|
|
|
791 Decl : Node_Id;
|
|
|
792 TDef : Node_Id;
|
|
|
793 CList : Node_Id;
|
|
|
794
|
|
|
795 begin
|
|
|
796 if not Is_Type (Typ) then
|
|
|
797 return False;
|
|
|
798 end if;
|
|
|
799
|
|
|
800 FSTyp := First_Subtype (Typ);
|
|
|
801
|
|
|
802 if not Has_Discriminants (FSTyp) then
|
|
|
803 return False;
|
|
|
804 end if;
|
|
|
805
|
|
|
806 -- Proceed with cautious checks here, return False if tree is not
|
|
|
807 -- as expected (may be caused by prior errors).
|
|
|
808
|
|
|
809 Decl := Declaration_Node (FSTyp);
|
|
|
810
|
|
|
811 if Nkind (Decl) /= N_Full_Type_Declaration then
|
|
|
812 return False;
|
|
|
813 end if;
|
|
|
814
|
|
|
815 TDef := Type_Definition (Decl);
|
|
|
816
|
|
|
817 if Nkind (TDef) /= N_Record_Definition then
|
|
|
818 return False;
|
|
|
819 end if;
|
|
|
820
|
|
|
821 CList := Component_List (TDef);
|
|
|
822
|
|
|
823 if Nkind (CList) /= N_Component_List then
|
|
|
824 return False;
|
|
|
825 else
|
|
|
826 return Present (Variant_Part (CList));
|
|
|
827 end if;
|
|
|
828 end Has_Variant_Part;
|
|
|
829
|
|
|
830 ---------------------
|
|
|
831 -- In_Generic_Body --
|
|
|
832 ---------------------
|
|
|
833
|
|
|
834 function In_Generic_Body (Id : Entity_Id) return Boolean is
|
|
|
835 S : Entity_Id;
|
|
|
836
|
|
|
837 begin
|
|
|
838 -- Climb scopes looking for generic body
|
|
|
839
|
|
|
840 S := Id;
|
|
|
841 while Present (S) and then S /= Standard_Standard loop
|
|
|
842
|
|
|
843 -- Generic package body
|
|
|
844
|
|
|
845 if Ekind (S) = E_Generic_Package
|
|
|
846 and then In_Package_Body (S)
|
|
|
847 then
|
|
|
848 return True;
|
|
|
849
|
|
|
850 -- Generic subprogram body
|
|
|
851
|
|
|
852 elsif Is_Subprogram (S)
|
|
|
853 and then Nkind (Unit_Declaration_Node (S)) =
|
|
|
854 N_Generic_Subprogram_Declaration
|
|
|
855 then
|
|
|
856 return True;
|
|
|
857 end if;
|
|
|
858
|
|
|
859 S := Scope (S);
|
|
|
860 end loop;
|
|
|
861
|
|
|
862 -- False if top of scope stack without finding a generic body
|
|
|
863
|
|
|
864 return False;
|
|
|
865 end In_Generic_Body;
|
|
|
866
|
|
|
867 -------------------------------
|
|
|
868 -- Initialization_Suppressed --
|
|
|
869 -------------------------------
|
|
|
870
|
|
|
871 function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
|
|
|
872 begin
|
|
|
873 return Suppress_Initialization (Typ)
|
|
|
874 or else Suppress_Initialization (Base_Type (Typ));
|
|
|
875 end Initialization_Suppressed;
|
|
|
876
|
|
|
877 ----------------
|
|
|
878 -- Initialize --
|
|
|
879 ----------------
|
|
|
880
|
|
|
881 procedure Initialize is
|
|
|
882 begin
|
|
|
883 Obsolescent_Warnings.Init;
|
|
|
884 end Initialize;
|
|
|
885
|
|
|
886 -------------
|
|
|
887 -- Is_Body --
|
|
|
888 -------------
|
|
|
889
|
|
|
890 function Is_Body (N : Node_Id) return Boolean is
|
|
|
891 begin
|
|
|
892 return
|
|
|
893 Nkind (N) in N_Body_Stub
|
|
|
894 or else Nkind_In (N, N_Entry_Body,
|
|
|
895 N_Package_Body,
|
|
|
896 N_Protected_Body,
|
|
|
897 N_Subprogram_Body,
|
|
|
898 N_Task_Body);
|
|
|
899 end Is_Body;
|
|
|
900
|
|
|
901 ---------------------
|
|
|
902 -- Is_By_Copy_Type --
|
|
|
903 ---------------------
|
|
|
904
|
|
|
905 function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
|
|
|
906 begin
|
|
|
907 -- If Id is a private type whose full declaration has not been seen,
|
|
|
908 -- we assume for now that it is not a By_Copy type. Clearly this
|
|
|
909 -- attribute should not be used before the type is frozen, but it is
|
|
|
910 -- needed to build the associated record of a protected type. Another
|
|
|
911 -- place where some lookahead for a full view is needed ???
|
|
|
912
|
|
|
913 return
|
|
|
914 Is_Elementary_Type (Ent)
|
|
|
915 or else (Is_Private_Type (Ent)
|
|
|
916 and then Present (Underlying_Type (Ent))
|
|
|
917 and then Is_Elementary_Type (Underlying_Type (Ent)));
|
|
|
918 end Is_By_Copy_Type;
|
|
|
919
|
|
|
920 --------------------------
|
|
|
921 -- Is_By_Reference_Type --
|
|
|
922 --------------------------
|
|
|
923
|
|
|
924 function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
|
|
|
925 Btype : constant Entity_Id := Base_Type (Ent);
|
|
|
926
|
|
|
927 begin
|
|
|
928 if Error_Posted (Ent) or else Error_Posted (Btype) then
|
|
|
929 return False;
|
|
|
930
|
|
|
931 elsif Is_Private_Type (Btype) then
|
|
|
932 declare
|
|
|
933 Utyp : constant Entity_Id := Underlying_Type (Btype);
|
|
|
934 begin
|
|
|
935 if No (Utyp) then
|
|
|
936 return False;
|
|
|
937 else
|
|
|
938 return Is_By_Reference_Type (Utyp);
|
|
|
939 end if;
|
|
|
940 end;
|
|
|
941
|
|
|
942 elsif Is_Incomplete_Type (Btype) then
|
|
|
943 declare
|
|
|
944 Ftyp : constant Entity_Id := Full_View (Btype);
|
|
|
945 begin
|
|
|
946 -- Return true for a tagged incomplete type built as a shadow
|
|
|
947 -- entity in Build_Limited_Views. It can appear in the profile
|
|
|
948 -- of a thunk and the back end needs to know how it is passed.
|
|
|
949
|
|
|
950 if No (Ftyp) then
|
|
|
951 return Is_Tagged_Type (Btype);
|
|
|
952 else
|
|
|
953 return Is_By_Reference_Type (Ftyp);
|
|
|
954 end if;
|
|
|
955 end;
|
|
|
956
|
|
|
957 elsif Is_Concurrent_Type (Btype) then
|
|
|
958 return True;
|
|
|
959
|
|
|
960 elsif Is_Record_Type (Btype) then
|
|
|
961 if Is_Limited_Record (Btype)
|
|
|
962 or else Is_Tagged_Type (Btype)
|
|
|
963 or else Is_Volatile (Btype)
|
|
|
964 then
|
|
|
965 return True;
|
|
|
966
|
|
|
967 else
|
|
|
968 declare
|
|
|
969 C : Entity_Id;
|
|
|
970
|
|
|
971 begin
|
|
|
972 C := First_Component (Btype);
|
|
|
973 while Present (C) loop
|
|
|
974
|
|
|
975 -- For each component, test if its type is a by reference
|
|
|
976 -- type and if its type is volatile. Also test the component
|
|
|
977 -- itself for being volatile. This happens for example when
|
|
|
978 -- a Volatile aspect is added to a component.
|
|
|
979
|
|
|
980 if Is_By_Reference_Type (Etype (C))
|
|
|
981 or else Is_Volatile (Etype (C))
|
|
|
982 or else Is_Volatile (C)
|
|
|
983 then
|
|
|
984 return True;
|
|
|
985 end if;
|
|
|
986
|
|
|
987 C := Next_Component (C);
|
|
|
988 end loop;
|
|
|
989 end;
|
|
|
990
|
|
|
991 return False;
|
|
|
992 end if;
|
|
|
993
|
|
|
994 elsif Is_Array_Type (Btype) then
|
|
|
995 return
|
|
|
996 Is_Volatile (Btype)
|
|
|
997 or else Is_By_Reference_Type (Component_Type (Btype))
|
|
|
998 or else Is_Volatile (Component_Type (Btype))
|
|
|
999 or else Has_Volatile_Components (Btype);
|
|
|
1000
|
|
|
1001 else
|
|
|
1002 return False;
|
|
|
1003 end if;
|
|
|
1004 end Is_By_Reference_Type;
|
|
|
1005
|
|
|
1006 -------------------------
|
|
|
1007 -- Is_Definite_Subtype --
|
|
|
1008 -------------------------
|
|
|
1009
|
|
|
1010 function Is_Definite_Subtype (T : Entity_Id) return Boolean is
|
|
|
1011 pragma Assert (Is_Type (T));
|
|
|
1012 K : constant Entity_Kind := Ekind (T);
|
|
|
1013
|
|
|
1014 begin
|
|
|
1015 if Is_Constrained (T) then
|
|
|
1016 return True;
|
|
|
1017
|
|
|
1018 elsif K in Array_Kind
|
|
|
1019 or else K in Class_Wide_Kind
|
|
|
1020 or else Has_Unknown_Discriminants (T)
|
|
|
1021 then
|
|
|
1022 return False;
|
|
|
1023
|
|
|
1024 -- Known discriminants: definite if there are default values. Note that
|
|
|
1025 -- if any discriminant has a default, they all do.
|
|
|
1026
|
|
|
1027 elsif Has_Discriminants (T) then
|
|
|
1028 return Present (Discriminant_Default_Value (First_Discriminant (T)));
|
|
|
1029
|
|
|
1030 else
|
|
|
1031 return True;
|
|
|
1032 end if;
|
|
|
1033 end Is_Definite_Subtype;
|
|
|
1034
|
|
|
1035 ---------------------
|
|
|
1036 -- Is_Derived_Type --
|
|
|
1037 ---------------------
|
|
|
1038
|
|
|
1039 function Is_Derived_Type (Ent : E) return B is
|
|
|
1040 Par : Node_Id;
|
|
|
1041
|
|
|
1042 begin
|
|
|
1043 if Is_Type (Ent)
|
|
|
1044 and then Base_Type (Ent) /= Root_Type (Ent)
|
|
|
1045 and then not Is_Class_Wide_Type (Ent)
|
|
|
1046
|
|
|
1047 -- An access_to_subprogram whose result type is a limited view can
|
|
|
1048 -- appear in a return statement, without the full view of the result
|
|
|
1049 -- type being available. Do not interpret this as a derived type.
|
|
|
1050
|
|
|
1051 and then Ekind (Ent) /= E_Subprogram_Type
|
|
|
1052 then
|
|
|
1053 if not Is_Numeric_Type (Root_Type (Ent)) then
|
|
|
1054 return True;
|
|
|
1055
|
|
|
1056 else
|
|
|
1057 Par := Parent (First_Subtype (Ent));
|
|
|
1058
|
|
|
1059 return Present (Par)
|
|
|
1060 and then Nkind (Par) = N_Full_Type_Declaration
|
|
|
1061 and then Nkind (Type_Definition (Par)) =
|
|
|
1062 N_Derived_Type_Definition;
|
|
|
1063 end if;
|
|
|
1064
|
|
|
1065 else
|
|
|
1066 return False;
|
|
|
1067 end if;
|
|
|
1068 end Is_Derived_Type;
|
|
|
1069
|
|
|
1070 -----------------------
|
|
|
1071 -- Is_Generic_Formal --
|
|
|
1072 -----------------------
|
|
|
1073
|
|
|
1074 function Is_Generic_Formal (E : Entity_Id) return Boolean is
|
|
|
1075 Kind : Node_Kind;
|
|
|
1076
|
|
|
1077 begin
|
|
|
1078 if No (E) then
|
|
|
1079 return False;
|
|
|
1080 else
|
|
|
1081 -- Formal derived types are rewritten as private extensions, so
|
|
|
1082 -- examine original node.
|
|
|
1083
|
|
|
1084 Kind := Nkind (Original_Node (Parent (E)));
|
|
|
1085
|
|
|
1086 return
|
|
|
1087 Nkind_In (Kind, N_Formal_Object_Declaration,
|
|
|
1088 N_Formal_Type_Declaration)
|
|
|
1089 or else Is_Formal_Subprogram (E)
|
|
|
1090 or else
|
|
|
1091 (Ekind (E) = E_Package
|
|
|
1092 and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
|
|
|
1093 N_Formal_Package_Declaration);
|
|
|
1094 end if;
|
|
|
1095 end Is_Generic_Formal;
|
|
|
1096
|
|
|
1097 -------------------------------
|
|
|
1098 -- Is_Immutably_Limited_Type --
|
|
|
1099 -------------------------------
|
|
|
1100
|
|
|
1101 function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
|
|
|
1102 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
|
|
|
1103
|
|
|
1104 begin
|
|
|
1105 if Is_Limited_Record (Btype) then
|
|
|
1106 return True;
|
|
|
1107
|
|
|
1108 elsif Ekind (Btype) = E_Limited_Private_Type
|
|
|
1109 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
|
|
|
1110 then
|
|
|
1111 return not In_Package_Body (Scope ((Btype)));
|
|
|
1112
|
|
|
1113 elsif Is_Private_Type (Btype) then
|
|
|
1114
|
|
|
1115 -- AI05-0063: A type derived from a limited private formal type is
|
|
|
1116 -- not immutably limited in a generic body.
|
|
|
1117
|
|
|
1118 if Is_Derived_Type (Btype)
|
|
|
1119 and then Is_Generic_Type (Etype (Btype))
|
|
|
1120 then
|
|
|
1121 if not Is_Limited_Type (Etype (Btype)) then
|
|
|
1122 return False;
|
|
|
1123
|
|
|
1124 -- A descendant of a limited formal type is not immutably limited
|
|
|
1125 -- in the generic body, or in the body of a generic child.
|
|
|
1126
|
|
|
1127 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
|
|
|
1128 return not In_Package_Body (Scope (Btype));
|
|
|
1129
|
|
|
1130 else
|
|
|
1131 return False;
|
|
|
1132 end if;
|
|
|
1133
|
|
|
1134 else
|
|
|
1135 declare
|
|
|
1136 Utyp : constant Entity_Id := Underlying_Type (Btype);
|
|
|
1137 begin
|
|
|
1138 if No (Utyp) then
|
|
|
1139 return False;
|
|
|
1140 else
|
|
|
1141 return Is_Immutably_Limited_Type (Utyp);
|
|
|
1142 end if;
|
|
|
1143 end;
|
|
|
1144 end if;
|
|
|
1145
|
|
|
1146 elsif Is_Concurrent_Type (Btype) then
|
|
|
1147 return True;
|
|
|
1148
|
|
|
1149 else
|
|
|
1150 return False;
|
|
|
1151 end if;
|
|
|
1152 end Is_Immutably_Limited_Type;
|
|
|
1153
|
|
|
1154 ---------------------
|
|
|
1155 -- Is_Limited_Type --
|
|
|
1156 ---------------------
|
|
|
1157
|
|
|
1158 function Is_Limited_Type (Ent : Entity_Id) return Boolean is
|
|
|
1159 Btype : constant E := Base_Type (Ent);
|
|
|
1160 Rtype : constant E := Root_Type (Btype);
|
|
|
1161
|
|
|
1162 begin
|
|
|
1163 if not Is_Type (Ent) then
|
|
|
1164 return False;
|
|
|
1165
|
|
|
1166 elsif Ekind (Btype) = E_Limited_Private_Type
|
|
|
1167 or else Is_Limited_Composite (Btype)
|
|
|
1168 then
|
|
|
1169 return True;
|
|
|
1170
|
|
|
1171 elsif Is_Concurrent_Type (Btype) then
|
|
|
1172 return True;
|
|
|
1173
|
|
|
1174 -- The Is_Limited_Record flag normally indicates that the type is
|
|
|
1175 -- limited. The exception is that a type does not inherit limitedness
|
|
|
1176 -- from its interface ancestor. So the type may be derived from a
|
|
|
1177 -- limited interface, but is not limited.
|
|
|
1178
|
|
|
1179 elsif Is_Limited_Record (Ent)
|
|
|
1180 and then not Is_Interface (Ent)
|
|
|
1181 then
|
|
|
1182 return True;
|
|
|
1183
|
|
|
1184 -- Otherwise we will look around to see if there is some other reason
|
|
|
1185 -- for it to be limited, except that if an error was posted on the
|
|
|
1186 -- entity, then just assume it is non-limited, because it can cause
|
|
|
1187 -- trouble to recurse into a murky entity resulting from other errors.
|
|
|
1188
|
|
|
1189 elsif Error_Posted (Ent) then
|
|
|
1190 return False;
|
|
|
1191
|
|
|
1192 elsif Is_Record_Type (Btype) then
|
|
|
1193
|
|
|
1194 if Is_Limited_Interface (Ent) then
|
|
|
1195 return True;
|
|
|
1196
|
|
|
1197 -- AI-419: limitedness is not inherited from a limited interface
|
|
|
1198
|
|
|
1199 elsif Is_Limited_Record (Rtype) then
|
|
|
1200 return not Is_Interface (Rtype)
|
|
|
1201 or else Is_Protected_Interface (Rtype)
|
|
|
1202 or else Is_Synchronized_Interface (Rtype)
|
|
|
1203 or else Is_Task_Interface (Rtype);
|
|
|
1204
|
|
|
1205 elsif Is_Class_Wide_Type (Btype) then
|
|
|
1206 return Is_Limited_Type (Rtype);
|
|
|
1207
|
|
|
1208 else
|
|
|
1209 declare
|
|
|
1210 C : E;
|
|
|
1211
|
|
|
1212 begin
|
|
|
1213 C := First_Component (Btype);
|
|
|
1214 while Present (C) loop
|
|
|
1215 if Is_Limited_Type (Etype (C)) then
|
|
|
1216 return True;
|
|
|
1217 end if;
|
|
|
1218
|
|
|
1219 C := Next_Component (C);
|
|
|
1220 end loop;
|
|
|
1221 end;
|
|
|
1222
|
|
|
1223 return False;
|
|
|
1224 end if;
|
|
|
1225
|
|
|
1226 elsif Is_Array_Type (Btype) then
|
|
|
1227 return Is_Limited_Type (Component_Type (Btype));
|
|
|
1228
|
|
|
1229 else
|
|
|
1230 return False;
|
|
|
1231 end if;
|
|
|
1232 end Is_Limited_Type;
|
|
|
1233
|
|
|
1234 ---------------------
|
|
|
1235 -- Is_Limited_View --
|
|
|
1236 ---------------------
|
|
|
1237
|
|
|
1238 function Is_Limited_View (Ent : Entity_Id) return Boolean is
|
|
|
1239 Btype : constant Entity_Id := Available_View (Base_Type (Ent));
|
|
|
1240
|
|
|
1241 begin
|
|
|
1242 if Is_Limited_Record (Btype) then
|
|
|
1243 return True;
|
|
|
1244
|
|
|
1245 elsif Ekind (Btype) = E_Limited_Private_Type
|
|
|
1246 and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
|
|
|
1247 then
|
|
|
1248 return not In_Package_Body (Scope ((Btype)));
|
|
|
1249
|
|
|
1250 elsif Is_Private_Type (Btype) then
|
|
|
1251
|
|
|
1252 -- AI05-0063: A type derived from a limited private formal type is
|
|
|
1253 -- not immutably limited in a generic body.
|
|
|
1254
|
|
|
1255 if Is_Derived_Type (Btype)
|
|
|
1256 and then Is_Generic_Type (Etype (Btype))
|
|
|
1257 then
|
|
|
1258 if not Is_Limited_Type (Etype (Btype)) then
|
|
|
1259 return False;
|
|
|
1260
|
|
|
1261 -- A descendant of a limited formal type is not immutably limited
|
|
|
1262 -- in the generic body, or in the body of a generic child.
|
|
|
1263
|
|
|
1264 elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
|
|
|
1265 return not In_Package_Body (Scope (Btype));
|
|
|
1266
|
|
|
1267 else
|
|
|
1268 return False;
|
|
|
1269 end if;
|
|
|
1270
|
|
|
1271 else
|
|
|
1272 declare
|
|
|
1273 Utyp : constant Entity_Id := Underlying_Type (Btype);
|
|
|
1274 begin
|
|
|
1275 if No (Utyp) then
|
|
|
1276 return False;
|
|
|
1277 else
|
|
|
1278 return Is_Limited_View (Utyp);
|
|
|
1279 end if;
|
|
|
1280 end;
|
|
|
1281 end if;
|
|
|
1282
|
|
|
1283 elsif Is_Concurrent_Type (Btype) then
|
|
|
1284 return True;
|
|
|
1285
|
|
|
1286 elsif Is_Record_Type (Btype) then
|
|
|
1287
|
|
|
1288 -- Note that we return True for all limited interfaces, even though
|
|
|
1289 -- (unsynchronized) limited interfaces can have descendants that are
|
|
|
1290 -- nonlimited, because this is a predicate on the type itself, and
|
|
|
1291 -- things like functions with limited interface results need to be
|
|
|
1292 -- handled as build in place even though they might return objects
|
|
|
1293 -- of a type that is not inherently limited.
|
|
|
1294
|
|
|
1295 if Is_Class_Wide_Type (Btype) then
|
|
|
1296 return Is_Limited_View (Root_Type (Btype));
|
|
|
1297
|
|
|
1298 else
|
|
|
1299 declare
|
|
|
1300 C : Entity_Id;
|
|
|
1301
|
|
|
1302 begin
|
|
|
1303 C := First_Component (Btype);
|
|
|
1304 while Present (C) loop
|
|
|
1305
|
|
|
1306 -- Don't consider components with interface types (which can
|
|
|
1307 -- only occur in the case of a _parent component anyway).
|
|
|
1308 -- They don't have any components, plus it would cause this
|
|
|
1309 -- function to return true for nonlimited types derived from
|
|
|
1310 -- limited interfaces.
|
|
|
1311
|
|
|
1312 if not Is_Interface (Etype (C))
|
|
|
1313 and then Is_Limited_View (Etype (C))
|
|
|
1314 then
|
|
|
1315 return True;
|
|
|
1316 end if;
|
|
|
1317
|
|
|
1318 C := Next_Component (C);
|
|
|
1319 end loop;
|
|
|
1320 end;
|
|
|
1321
|
|
|
1322 return False;
|
|
|
1323 end if;
|
|
|
1324
|
|
|
1325 elsif Is_Array_Type (Btype) then
|
|
|
1326 return Is_Limited_View (Component_Type (Btype));
|
|
|
1327
|
|
|
1328 else
|
|
|
1329 return False;
|
|
|
1330 end if;
|
|
|
1331 end Is_Limited_View;
|
|
|
1332
|
|
145
|
1333 ----------------------------
|
|
|
1334 -- Is_Protected_Operation --
|
|
|
1335 ----------------------------
|
|
|
1336
|
|
|
1337 function Is_Protected_Operation (E : Entity_Id) return Boolean is
|
|
|
1338 begin
|
|
|
1339 return
|
|
|
1340 Is_Entry (E)
|
|
|
1341 or else (Is_Subprogram (E)
|
|
|
1342 and then Nkind (Parent (Unit_Declaration_Node (E))) =
|
|
|
1343 N_Protected_Definition);
|
|
|
1344 end Is_Protected_Operation;
|
|
|
1345
|
|
111
|
1346 ----------------------
|
|
|
1347 -- Nearest_Ancestor --
|
|
|
1348 ----------------------
|
|
|
1349
|
|
|
1350 function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
|
|
|
1351 D : constant Node_Id := Original_Node (Declaration_Node (Typ));
|
|
|
1352 -- We use the original node of the declaration, because derived
|
|
|
1353 -- types from record subtypes are rewritten as record declarations,
|
|
|
1354 -- and it is the original declaration that carries the ancestor.
|
|
|
1355
|
|
|
1356 begin
|
|
|
1357 -- If we have a subtype declaration, get the ancestor subtype
|
|
|
1358
|
|
|
1359 if Nkind (D) = N_Subtype_Declaration then
|
|
|
1360 if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
|
|
|
1361 return Entity (Subtype_Mark (Subtype_Indication (D)));
|
|
|
1362 else
|
|
|
1363 return Entity (Subtype_Indication (D));
|
|
|
1364 end if;
|
|
|
1365
|
|
|
1366 -- If derived type declaration, find who we are derived from
|
|
|
1367
|
|
|
1368 elsif Nkind (D) = N_Full_Type_Declaration
|
|
|
1369 and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
|
|
|
1370 then
|
|
|
1371 declare
|
|
|
1372 DTD : constant Entity_Id := Type_Definition (D);
|
|
|
1373 SI : constant Entity_Id := Subtype_Indication (DTD);
|
|
|
1374 begin
|
|
|
1375 if Is_Entity_Name (SI) then
|
|
|
1376 return Entity (SI);
|
|
|
1377 else
|
|
|
1378 return Entity (Subtype_Mark (SI));
|
|
|
1379 end if;
|
|
|
1380 end;
|
|
|
1381
|
|
|
1382 -- If derived type and private type, get the full view to find who we
|
|
|
1383 -- are derived from.
|
|
|
1384
|
|
|
1385 elsif Is_Derived_Type (Typ)
|
|
|
1386 and then Is_Private_Type (Typ)
|
|
|
1387 and then Present (Full_View (Typ))
|
|
|
1388 then
|
|
|
1389 return Nearest_Ancestor (Full_View (Typ));
|
|
|
1390
|
|
|
1391 -- Otherwise, nothing useful to return, return Empty
|
|
|
1392
|
|
|
1393 else
|
|
|
1394 return Empty;
|
|
|
1395 end if;
|
|
|
1396 end Nearest_Ancestor;
|
|
|
1397
|
|
|
1398 ---------------------------
|
|
|
1399 -- Nearest_Dynamic_Scope --
|
|
|
1400 ---------------------------
|
|
|
1401
|
|
|
1402 function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
|
|
|
1403 begin
|
|
|
1404 if Is_Dynamic_Scope (Ent) then
|
|
|
1405 return Ent;
|
|
|
1406 else
|
|
|
1407 return Enclosing_Dynamic_Scope (Ent);
|
|
|
1408 end if;
|
|
|
1409 end Nearest_Dynamic_Scope;
|
|
|
1410
|
|
|
1411 ------------------------
|
|
|
1412 -- Next_Tag_Component --
|
|
|
1413 ------------------------
|
|
|
1414
|
|
|
1415 function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
|
|
|
1416 Comp : Entity_Id;
|
|
|
1417
|
|
|
1418 begin
|
|
|
1419 pragma Assert (Is_Tag (Tag));
|
|
|
1420
|
|
|
1421 -- Loop to look for next tag component
|
|
|
1422
|
|
|
1423 Comp := Next_Entity (Tag);
|
|
|
1424 while Present (Comp) loop
|
|
|
1425 if Is_Tag (Comp) then
|
|
|
1426 pragma Assert (Chars (Comp) /= Name_uTag);
|
|
|
1427 return Comp;
|
|
|
1428 end if;
|
|
|
1429
|
|
|
1430 Comp := Next_Entity (Comp);
|
|
|
1431 end loop;
|
|
|
1432
|
|
|
1433 -- No tag component found
|
|
|
1434
|
|
|
1435 return Empty;
|
|
|
1436 end Next_Tag_Component;
|
|
|
1437
|
|
|
1438 -----------------------
|
|
|
1439 -- Number_Components --
|
|
|
1440 -----------------------
|
|
|
1441
|
|
|
1442 function Number_Components (Typ : Entity_Id) return Nat is
|
|
|
1443 N : Nat := 0;
|
|
|
1444 Comp : Entity_Id;
|
|
|
1445
|
|
|
1446 begin
|
|
|
1447 -- We do not call Einfo.First_Component_Or_Discriminant, as this
|
|
|
1448 -- function does not skip completely hidden discriminants, which we
|
|
|
1449 -- want to skip here.
|
|
|
1450
|
|
|
1451 if Has_Discriminants (Typ) then
|
|
|
1452 Comp := First_Discriminant (Typ);
|
|
|
1453 else
|
|
|
1454 Comp := First_Component (Typ);
|
|
|
1455 end if;
|
|
|
1456
|
|
|
1457 while Present (Comp) loop
|
|
|
1458 N := N + 1;
|
|
|
1459 Comp := Next_Component_Or_Discriminant (Comp);
|
|
|
1460 end loop;
|
|
|
1461
|
|
|
1462 return N;
|
|
|
1463 end Number_Components;
|
|
|
1464
|
|
|
1465 --------------------------
|
|
|
1466 -- Number_Discriminants --
|
|
|
1467 --------------------------
|
|
|
1468
|
|
|
1469 function Number_Discriminants (Typ : Entity_Id) return Pos is
|
|
|
1470 N : Nat := 0;
|
|
|
1471 Discr : Entity_Id := First_Discriminant (Typ);
|
|
|
1472
|
|
|
1473 begin
|
|
|
1474 while Present (Discr) loop
|
|
|
1475 N := N + 1;
|
|
|
1476 Discr := Next_Discriminant (Discr);
|
|
|
1477 end loop;
|
|
|
1478
|
|
|
1479 return N;
|
|
|
1480 end Number_Discriminants;
|
|
|
1481
|
|
|
1482 ----------------------------------------------
|
|
|
1483 -- Object_Type_Has_Constrained_Partial_View --
|
|
|
1484 ----------------------------------------------
|
|
|
1485
|
|
|
1486 function Object_Type_Has_Constrained_Partial_View
|
|
|
1487 (Typ : Entity_Id;
|
|
|
1488 Scop : Entity_Id) return Boolean
|
|
|
1489 is
|
|
|
1490 begin
|
|
|
1491 return Has_Constrained_Partial_View (Typ)
|
|
|
1492 or else (In_Generic_Body (Scop)
|
|
|
1493 and then Is_Generic_Type (Base_Type (Typ))
|
|
145
|
1494 and then (Is_Private_Type (Base_Type (Typ))
|
|
|
1495 or else Is_Derived_Type (Base_Type (Typ)))
|
|
111
|
1496 and then not Is_Tagged_Type (Typ)
|
|
|
1497 and then not (Is_Array_Type (Typ)
|
|
|
1498 and then not Is_Constrained (Typ))
|
|
|
1499 and then Has_Discriminants (Typ));
|
|
|
1500 end Object_Type_Has_Constrained_Partial_View;
|
|
|
1501
|
|
|
1502 ------------------
|
|
|
1503 -- Package_Body --
|
|
|
1504 ------------------
|
|
|
1505
|
|
|
1506 function Package_Body (E : Entity_Id) return Node_Id is
|
|
|
1507 N : Node_Id;
|
|
|
1508
|
|
|
1509 begin
|
|
|
1510 if Ekind (E) = E_Package_Body then
|
|
|
1511 N := Parent (E);
|
|
|
1512
|
|
|
1513 if Nkind (N) = N_Defining_Program_Unit_Name then
|
|
|
1514 N := Parent (N);
|
|
|
1515 end if;
|
|
|
1516
|
|
|
1517 else
|
|
|
1518 N := Package_Spec (E);
|
|
|
1519
|
|
|
1520 if Present (Corresponding_Body (N)) then
|
|
|
1521 N := Parent (Corresponding_Body (N));
|
|
|
1522
|
|
|
1523 if Nkind (N) = N_Defining_Program_Unit_Name then
|
|
|
1524 N := Parent (N);
|
|
|
1525 end if;
|
|
|
1526 else
|
|
|
1527 N := Empty;
|
|
|
1528 end if;
|
|
|
1529 end if;
|
|
|
1530
|
|
|
1531 return N;
|
|
|
1532 end Package_Body;
|
|
|
1533
|
|
|
1534 ------------------
|
|
|
1535 -- Package_Spec --
|
|
|
1536 ------------------
|
|
|
1537
|
|
|
1538 function Package_Spec (E : Entity_Id) return Node_Id is
|
|
|
1539 begin
|
|
|
1540 return Parent (Package_Specification (E));
|
|
|
1541 end Package_Spec;
|
|
|
1542
|
|
|
1543 ---------------------------
|
|
|
1544 -- Package_Specification --
|
|
|
1545 ---------------------------
|
|
|
1546
|
|
|
1547 function Package_Specification (E : Entity_Id) return Node_Id is
|
|
|
1548 N : Node_Id;
|
|
|
1549
|
|
|
1550 begin
|
|
|
1551 N := Parent (E);
|
|
|
1552
|
|
|
1553 if Nkind (N) = N_Defining_Program_Unit_Name then
|
|
|
1554 N := Parent (N);
|
|
|
1555 end if;
|
|
|
1556
|
|
|
1557 return N;
|
|
|
1558 end Package_Specification;
|
|
|
1559
|
|
|
1560 ---------------------
|
|
|
1561 -- Subprogram_Body --
|
|
|
1562 ---------------------
|
|
|
1563
|
|
|
1564 function Subprogram_Body (E : Entity_Id) return Node_Id is
|
|
|
1565 Body_E : constant Entity_Id := Subprogram_Body_Entity (E);
|
|
|
1566
|
|
|
1567 begin
|
|
|
1568 if No (Body_E) then
|
|
|
1569 return Empty;
|
|
|
1570 else
|
|
|
1571 return Parent (Subprogram_Specification (Body_E));
|
|
|
1572 end if;
|
|
|
1573 end Subprogram_Body;
|
|
|
1574
|
|
|
1575 ----------------------------
|
|
|
1576 -- Subprogram_Body_Entity --
|
|
|
1577 ----------------------------
|
|
|
1578
|
|
|
1579 function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is
|
|
|
1580 N : constant Node_Id := Parent (Subprogram_Specification (E));
|
|
|
1581 -- Declaration for E
|
|
|
1582
|
|
|
1583 begin
|
|
|
1584 -- If this declaration is not a subprogram body, then it must be a
|
|
|
1585 -- subprogram declaration or body stub, from which we can retrieve the
|
|
|
1586 -- entity for the corresponding subprogram body if any, or an abstract
|
|
|
1587 -- subprogram declaration, for which we return Empty.
|
|
|
1588
|
|
|
1589 case Nkind (N) is
|
|
|
1590 when N_Subprogram_Body =>
|
|
|
1591 return E;
|
|
|
1592
|
|
|
1593 when N_Subprogram_Body_Stub
|
|
|
1594 | N_Subprogram_Declaration
|
|
|
1595 =>
|
|
|
1596 return Corresponding_Body (N);
|
|
|
1597
|
|
|
1598 when others =>
|
|
|
1599 return Empty;
|
|
|
1600 end case;
|
|
|
1601 end Subprogram_Body_Entity;
|
|
|
1602
|
|
|
1603 ---------------------
|
|
|
1604 -- Subprogram_Spec --
|
|
|
1605 ---------------------
|
|
|
1606
|
|
|
1607 function Subprogram_Spec (E : Entity_Id) return Node_Id is
|
|
|
1608 N : constant Node_Id := Parent (Subprogram_Specification (E));
|
|
|
1609 -- Declaration for E
|
|
|
1610
|
|
|
1611 begin
|
|
|
1612 -- This declaration is either subprogram declaration or a subprogram
|
|
|
1613 -- body, in which case return Empty.
|
|
|
1614
|
|
|
1615 if Nkind (N) = N_Subprogram_Declaration then
|
|
|
1616 return N;
|
|
|
1617 else
|
|
|
1618 return Empty;
|
|
|
1619 end if;
|
|
|
1620 end Subprogram_Spec;
|
|
|
1621
|
|
|
1622 ------------------------------
|
|
|
1623 -- Subprogram_Specification --
|
|
|
1624 ------------------------------
|
|
|
1625
|
|
|
1626 function Subprogram_Specification (E : Entity_Id) return Node_Id is
|
|
|
1627 N : Node_Id;
|
|
|
1628
|
|
|
1629 begin
|
|
|
1630 N := Parent (E);
|
|
|
1631
|
|
|
1632 if Nkind (N) = N_Defining_Program_Unit_Name then
|
|
|
1633 N := Parent (N);
|
|
|
1634 end if;
|
|
|
1635
|
|
|
1636 -- If the Parent pointer of E is not a subprogram specification node
|
|
|
1637 -- (going through an intermediate N_Defining_Program_Unit_Name node
|
|
|
1638 -- for subprogram units), then E is an inherited operation. Its parent
|
|
|
1639 -- points to the type derivation that produces the inheritance: that's
|
|
|
1640 -- the node that generates the subprogram specification. Its alias
|
|
|
1641 -- is the parent subprogram, and that one points to a subprogram
|
|
|
1642 -- declaration, or to another type declaration if this is a hierarchy
|
|
|
1643 -- of derivations.
|
|
|
1644
|
|
|
1645 if Nkind (N) not in N_Subprogram_Specification then
|
|
|
1646 pragma Assert (Present (Alias (E)));
|
|
|
1647 N := Subprogram_Specification (Alias (E));
|
|
|
1648 end if;
|
|
|
1649
|
|
|
1650 return N;
|
|
|
1651 end Subprogram_Specification;
|
|
|
1652
|
|
|
1653 ---------------
|
|
|
1654 -- Tree_Read --
|
|
|
1655 ---------------
|
|
|
1656
|
|
|
1657 procedure Tree_Read is
|
|
|
1658 begin
|
|
|
1659 Obsolescent_Warnings.Tree_Read;
|
|
|
1660 end Tree_Read;
|
|
|
1661
|
|
|
1662 ----------------
|
|
|
1663 -- Tree_Write --
|
|
|
1664 ----------------
|
|
|
1665
|
|
|
1666 procedure Tree_Write is
|
|
|
1667 begin
|
|
|
1668 Obsolescent_Warnings.Tree_Write;
|
|
|
1669 end Tree_Write;
|
|
|
1670
|
|
|
1671 --------------------
|
|
|
1672 -- Ultimate_Alias --
|
|
|
1673 --------------------
|
|
|
1674
|
|
|
1675 function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
|
|
|
1676 E : Entity_Id := Prim;
|
|
|
1677
|
|
|
1678 begin
|
|
|
1679 while Present (Alias (E)) loop
|
|
|
1680 pragma Assert (Alias (E) /= E);
|
|
|
1681 E := Alias (E);
|
|
|
1682 end loop;
|
|
|
1683
|
|
|
1684 return E;
|
|
|
1685 end Ultimate_Alias;
|
|
|
1686
|
|
|
1687 --------------------------
|
|
|
1688 -- Unit_Declaration_Node --
|
|
|
1689 --------------------------
|
|
|
1690
|
|
|
1691 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
|
|
|
1692 N : Node_Id := Parent (Unit_Id);
|
|
|
1693
|
|
|
1694 begin
|
|
|
1695 -- Predefined operators do not have a full function declaration
|
|
|
1696
|
|
|
1697 if Ekind (Unit_Id) = E_Operator then
|
|
|
1698 return N;
|
|
|
1699 end if;
|
|
|
1700
|
|
|
1701 -- Isn't there some better way to express the following ???
|
|
|
1702
|
|
|
1703 while Nkind (N) /= N_Abstract_Subprogram_Declaration
|
|
|
1704 and then Nkind (N) /= N_Entry_Body
|
|
|
1705 and then Nkind (N) /= N_Entry_Declaration
|
|
|
1706 and then Nkind (N) /= N_Formal_Package_Declaration
|
|
|
1707 and then Nkind (N) /= N_Function_Instantiation
|
|
|
1708 and then Nkind (N) /= N_Generic_Package_Declaration
|
|
|
1709 and then Nkind (N) /= N_Generic_Subprogram_Declaration
|
|
|
1710 and then Nkind (N) /= N_Package_Declaration
|
|
|
1711 and then Nkind (N) /= N_Package_Body
|
|
|
1712 and then Nkind (N) /= N_Package_Instantiation
|
|
|
1713 and then Nkind (N) /= N_Package_Renaming_Declaration
|
|
|
1714 and then Nkind (N) /= N_Procedure_Instantiation
|
|
|
1715 and then Nkind (N) /= N_Protected_Body
|
|
|
1716 and then Nkind (N) /= N_Protected_Type_Declaration
|
|
|
1717 and then Nkind (N) /= N_Subprogram_Declaration
|
|
|
1718 and then Nkind (N) /= N_Subprogram_Body
|
|
|
1719 and then Nkind (N) /= N_Subprogram_Body_Stub
|
|
|
1720 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
|
|
|
1721 and then Nkind (N) /= N_Task_Body
|
|
|
1722 and then Nkind (N) /= N_Task_Type_Declaration
|
|
|
1723 and then Nkind (N) not in N_Formal_Subprogram_Declaration
|
|
|
1724 and then Nkind (N) not in N_Generic_Renaming_Declaration
|
|
|
1725 loop
|
|
|
1726 N := Parent (N);
|
|
|
1727
|
|
|
1728 -- We don't use Assert here, because that causes an infinite loop
|
|
|
1729 -- when assertions are turned off. Better to crash.
|
|
|
1730
|
|
|
1731 if No (N) then
|
|
|
1732 raise Program_Error;
|
|
|
1733 end if;
|
|
|
1734 end loop;
|
|
|
1735
|
|
|
1736 return N;
|
|
|
1737 end Unit_Declaration_Node;
|
|
|
1738
|
|
|
1739 end Sem_Aux;
|
