]>
Commit | Line | Data |
---|---|---|
21d27997 RD |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ A U X -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
1d005acc | 9 | -- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- |
21d27997 RD |
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 | ||
a4100e55 RD |
33 | with Atree; use Atree; |
34 | with Einfo; use Einfo; | |
a4100e55 RD |
35 | with Snames; use Snames; |
36 | with Stand; use Stand; | |
2c9f8c0a | 37 | with Uintp; use Uintp; |
a4100e55 | 38 | |
21d27997 RD |
39 | package body Sem_Aux is |
40 | ||
a4100e55 RD |
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 | ||
d347f572 | 50 | if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then |
a4100e55 RD |
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 | ||
dc726757 | 79 | function Available_View (Ent : Entity_Id) return Entity_Id is |
a4100e55 | 80 | begin |
47346923 | 81 | -- Obtain the non-limited view (if available) |
dc726757 | 82 | |
47346923 | 83 | if Has_Non_Limited_View (Ent) then |
dc726757 | 84 | return Get_Full_View (Non_Limited_View (Ent)); |
a4100e55 | 85 | |
1f0b1e48 RD |
86 | -- In all other cases, return entity unchanged |
87 | ||
a4100e55 | 88 | else |
dc726757 | 89 | return Ent; |
a4100e55 RD |
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 | |
550f4135 AC |
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. | |
a4100e55 RD |
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 | ||
934a3a25 | 114 | -- If this is a component declaration whose entity is a constant, it is |
b66c3ff4 | 115 | -- a prival within a protected function (and so has no constant value). |
a4100e55 RD |
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 | |
48bb06a7 | 123 | return Expression (D); |
a4100e55 RD |
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 | ||
2c9f8c0a AC |
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 | ||
a4100e55 RD |
170 | ----------------------------- |
171 | -- Enclosing_Dynamic_Scope -- | |
172 | ----------------------------- | |
173 | ||
174 | function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is | |
24357840 | 175 | S : Entity_Id; |
a4100e55 RD |
176 | |
177 | begin | |
550f4135 AC |
178 | -- The following test is an error defense against some syntax errors |
179 | -- that can leave scopes very messed up. | |
a4100e55 RD |
180 | |
181 | if Ent = Standard_Standard then | |
182 | return Ent; | |
183 | end if; | |
184 | ||
185 | -- Normal case, search enclosing scopes | |
186 | ||
ab8e1b35 RD |
187 | -- Note: the test for Present (S) should not be required, it defends |
188 | -- against an ill-formed tree. | |
a4100e55 RD |
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 | ||
e8374e7a AC |
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. | |
a4100e55 RD |
202 | |
203 | elsif S = Standard_Standard | |
204 | or else Is_Dynamic_Scope (S) | |
e8374e7a AC |
205 | or else (Is_Private_Type (S) |
206 | and then Present (Full_View (S)) | |
207 | and then Is_Dynamic_Scope (Full_View (S))) | |
a4100e55 RD |
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 | |
7730df14 | 228 | (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ)); |
a4100e55 RD |
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 | |
df3e68b1 | 234 | -- either because the tag must be ahead of them. |
a4100e55 RD |
235 | |
236 | if Chars (Ent) = Name_uTag then | |
237 | Ent := Next_Entity (Ent); | |
238 | end if; | |
239 | ||
a4100e55 RD |
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 | ||
66371f94 AC |
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 | ||
50ef946c AC |
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. | |
a4100e55 RD |
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) | |
527f5eb6 AC |
270 | -- Note that the entity list for the type may contain anonymous access |
271 | -- types created by expressions that constrain access discriminants. | |
a4100e55 RD |
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; | |
527f5eb6 AC |
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 | ||
9fe696a3 | 294 | elsif Ekind (Ent) = E_Discriminant |
527f5eb6 AC |
295 | and then Is_Completely_Hidden (Ent) |
296 | then | |
a4100e55 RD |
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 | ||
a4100e55 | 319 | if Has_Completely_Hidden_Discriminant (Ent) then |
a4100e55 | 320 | while Present (Ent) loop |
527f5eb6 AC |
321 | exit when Ekind (Ent) = E_Discriminant |
322 | and then Is_Completely_Hidden (Ent); | |
a4100e55 RD |
323 | Ent := Next_Entity (Ent); |
324 | end loop; | |
a4100e55 RD |
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 | |
9e64a2c1 RD |
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 | |
550f4135 AC |
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 | |
75ba322d | 346 | -- subtype of a generic formal is not its own first subtype. Its base |
550f4135 AC |
347 | -- type, if anonymous, is attached to the formal type decl. from which |
348 | -- the first subtype is obtained. | |
a4100e55 RD |
349 | |
350 | if No (F) then | |
a4100e55 RD |
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 | ||
4b03d946 AC |
434 | --------------------- |
435 | -- Get_Binary_Nkind -- | |
436 | --------------------- | |
437 | ||
438 | function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is | |
4b03d946 | 439 | begin |
0382062b | 440 | case Chars (Op) is |
d8f43ee6 HK |
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; | |
0382062b | 459 | end case; |
4b03d946 AC |
460 | end Get_Binary_Nkind; |
461 | ||
8437edb4 YM |
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 | ||
90a4b336 YM |
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 | |
ff1bedac | 497 | return Type_Low_Bound (E); |
90a4b336 YM |
498 | end if; |
499 | end Get_Low_Bound; | |
500 | ||
34f3a701 VP |
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 | |
616547fa AC |
515 | |
516 | -- Only one of Priority / Interrupt_Priority can be specified, so | |
517 | -- return whichever one is present to catch illegal duplication. | |
518 | ||
34f3a701 VP |
519 | if Nkind (N) = N_Pragma |
520 | and then | |
6e759c2a | 521 | (Pragma_Name_Unmapped (N) = Nam |
34f3a701 | 522 | or else (Nam = Name_Priority |
6e759c2a | 523 | and then Pragma_Name (N) = |
533e3abc | 524 | Name_Interrupt_Priority) |
616547fa | 525 | or else (Nam = Name_Interrupt_Priority |
6e759c2a | 526 | and then Pragma_Name (N) = Name_Priority)) |
34f3a701 VP |
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 | |
b69cd36a AC |
552 | or else (Nam = Name_Priority |
553 | and then Chars (N) = Name_Interrupt_Priority)) | |
34f3a701 | 554 | then |
758ad973 | 555 | if Check_Parents or else Entity (N) = E then |
34f3a701 VP |
556 | return N; |
557 | end if; | |
558 | ||
559 | elsif Nkind (N) = N_Aspect_Specification | |
560 | and then | |
561 | (Chars (Identifier (N)) = Nam | |
b69cd36a AC |
562 | or else |
563 | (Nam = Name_Priority | |
564 | and then Chars (Identifier (N)) = Name_Interrupt_Priority)) | |
34f3a701 VP |
565 | then |
566 | if Check_Parents then | |
567 | return N; | |
568 | ||
569 | elsif Entity (N) = E then | |
570 | return N; | |
571 | end if; | |
022c9dfe ES |
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); | |
34f3a701 VP |
578 | end if; |
579 | ||
580 | Next_Rep_Item (N); | |
581 | end loop; | |
582 | ||
583 | return Empty; | |
584 | end Get_Rep_Item; | |
585 | ||
dc3af7e2 AC |
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 | ||
34f3a701 VP |
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 | |
4754d4e8 | 629 | N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents); |
34f3a701 VP |
630 | |
631 | begin | |
dc3af7e2 AC |
632 | if Present (N) and then Nkind (N) = N_Pragma then |
633 | return N; | |
634 | end if; | |
34f3a701 | 635 | |
dc3af7e2 AC |
636 | return Empty; |
637 | end Get_Rep_Pragma; | |
34f3a701 | 638 | |
dc3af7e2 AC |
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; | |
34f3a701 VP |
665 | end if; |
666 | ||
667 | Next_Rep_Item (N); | |
668 | end loop; | |
669 | ||
670 | return Empty; | |
671 | end Get_Rep_Pragma; | |
672 | ||
4b03d946 AC |
673 | --------------------- |
674 | -- Get_Unary_Nkind -- | |
675 | --------------------- | |
676 | ||
677 | function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is | |
4b03d946 | 678 | begin |
0382062b | 679 | case Chars (Op) is |
d8f43ee6 HK |
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; | |
0382062b | 685 | end case; |
4b03d946 AC |
686 | end Get_Unary_Nkind; |
687 | ||
36295779 AC |
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 | ||
34f3a701 VP |
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 | ||
dc3af7e2 AC |
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 | ||
6dc87f5f AC |
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 | ||
34f3a701 VP |
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 | ||
dc3af7e2 AC |
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 | ||
b2834fbd AC |
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 | ||
dda38714 AC |
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 | ||
414b312e AC |
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) | |
f99ff327 AC |
853 | and then Nkind (Unit_Declaration_Node (S)) = |
854 | N_Generic_Subprogram_Declaration | |
414b312e AC |
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 | ||
0fbcb11c ES |
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 | ||
fba9ebfc AC |
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 | ||
a4100e55 RD |
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 | |
9d641fc0 | 928 | if Error_Posted (Ent) or else Error_Posted (Btype) then |
a4100e55 RD |
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 | |
1e55d29a EB |
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 | ||
a4100e55 | 950 | if No (Ftyp) then |
1e55d29a | 951 | return Is_Tagged_Type (Btype); |
a4100e55 RD |
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 | |
3b821fe9 VC |
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 | ||
a4100e55 RD |
980 | if Is_By_Reference_Type (Etype (C)) |
981 | or else Is_Volatile (Etype (C)) | |
3b821fe9 | 982 | or else Is_Volatile (C) |
a4100e55 RD |
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 | ||
ff1bedac | 1006 | ------------------------- |
83496138 | 1007 | -- Is_Definite_Subtype -- |
ff1bedac | 1008 | ------------------------- |
83496138 AC |
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 | |
b68cf874 | 1028 | return Present (Discriminant_Default_Value (First_Discriminant (T))); |
83496138 AC |
1029 | |
1030 | else | |
1031 | return True; | |
1032 | end if; | |
1033 | end Is_Definite_Subtype; | |
1034 | ||
a4100e55 RD |
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) | |
c7d22ee7 AC |
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 | ||
273123a4 | 1051 | and then Ekind (Ent) /= E_Subprogram_Type |
a4100e55 RD |
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 | ||
57d62f0c AC |
1070 | ----------------------- |
1071 | -- Is_Generic_Formal -- | |
1072 | ----------------------- | |
1073 | ||
1074 | function Is_Generic_Formal (E : Entity_Id) return Boolean is | |
1075 | Kind : Node_Kind; | |
f32eb591 | 1076 | |
57d62f0c AC |
1077 | begin |
1078 | if No (E) then | |
1079 | return False; | |
1080 | else | |
f32eb591 AC |
1081 | -- Formal derived types are rewritten as private extensions, so |
1082 | -- examine original node. | |
1083 | ||
1084 | Kind := Nkind (Original_Node (Parent (E))); | |
1085 | ||
57d62f0c AC |
1086 | return |
1087 | Nkind_In (Kind, N_Formal_Object_Declaration, | |
57d62f0c | 1088 | N_Formal_Type_Declaration) |
4269edf0 | 1089 | or else Is_Formal_Subprogram (E) |
4269edf0 AC |
1090 | or else |
1091 | (Ekind (E) = E_Package | |
1092 | and then Nkind (Original_Node (Unit_Declaration_Node (E))) = | |
c48e0f27 | 1093 | N_Formal_Package_Declaration); |
57d62f0c AC |
1094 | end if; |
1095 | end Is_Generic_Formal; | |
1096 | ||
51245e2d ES |
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; | |
a4100e55 RD |
1148 | |
1149 | else | |
1150 | return False; | |
1151 | end if; | |
40f07b4b | 1152 | end Is_Immutably_Limited_Type; |
a4100e55 RD |
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 | |
77a40ec1 | 1187 | -- trouble to recurse into a murky entity resulting from other errors. |
a4100e55 RD |
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 | ||
72d1b27a AC |
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 | ||
179682a5 YM |
1333 | ---------------------------- |
1334 | -- Is_Protected_Operation -- | |
1335 | ---------------------------- | |
1336 | ||
1337 | function Is_Protected_Operation (E : Entity_Id) return Boolean is | |
1338 | begin | |
29c64a0f HK |
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); | |
179682a5 YM |
1344 | end Is_Protected_Operation; |
1345 | ||
8110ee3b RD |
1346 | ---------------------- |
1347 | -- Nearest_Ancestor -- | |
1348 | ---------------------- | |
1349 | ||
1350 | function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is | |
e7c25229 AC |
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. | |
8110ee3b RD |
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 | ||
b98e2969 AC |
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 | ||
8110ee3b RD |
1391 | -- Otherwise, nothing useful to return, return Empty |
1392 | ||
1393 | else | |
1394 | return Empty; | |
1395 | end if; | |
1396 | end Nearest_Ancestor; | |
1397 | ||
24357840 RD |
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 | ||
a4100e55 RD |
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 | ||
043ce308 AC |
1421 | -- Loop to look for next tag component |
1422 | ||
a4100e55 RD |
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 | ||
90a4b336 YM |
1438 | ----------------------- |
1439 | -- Number_Components -- | |
1440 | ----------------------- | |
1441 | ||
877a5a12 | 1442 | function Number_Components (Typ : Entity_Id) return Nat is |
4754d4e8 | 1443 | N : Nat := 0; |
90a4b336 YM |
1444 | Comp : Entity_Id; |
1445 | ||
1446 | begin | |
90a4b336 YM |
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 | ||
a4100e55 RD |
1465 | -------------------------- |
1466 | -- Number_Discriminants -- | |
1467 | -------------------------- | |
1468 | ||
1469 | function Number_Discriminants (Typ : Entity_Id) return Pos is | |
4754d4e8 AC |
1470 | N : Nat := 0; |
1471 | Discr : Entity_Id := First_Discriminant (Typ); | |
a4100e55 RD |
1472 | |
1473 | begin | |
a4100e55 RD |
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 | ||
0fbcb11c ES |
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)) | |
33985131 GD |
1494 | and then (Is_Private_Type (Base_Type (Typ)) |
1495 | or else Is_Derived_Type (Base_Type (Typ))) | |
0fbcb11c ES |
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 | ||
ff1bedac YM |
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 | ||
d12b19fa AC |
1543 | --------------------------- |
1544 | -- Package_Specification -- | |
1545 | --------------------------- | |
1546 | ||
ff1bedac | 1547 | function Package_Specification (E : Entity_Id) return Node_Id is |
d12b19fa AC |
1548 | N : Node_Id; |
1549 | ||
1550 | begin | |
ff1bedac | 1551 | N := Parent (E); |
d12b19fa | 1552 | |
ff1bedac YM |
1553 | if Nkind (N) = N_Defining_Program_Unit_Name then |
1554 | N := Parent (N); | |
1555 | end if; | |
d12b19fa AC |
1556 | |
1557 | return N; | |
1558 | end Package_Specification; | |
1559 | ||
90a4b336 YM |
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 | |
4754d4e8 AC |
1580 | N : constant Node_Id := Parent (Subprogram_Specification (E)); |
1581 | -- Declaration for E | |
90a4b336 YM |
1582 | |
1583 | begin | |
90a4b336 | 1584 | -- If this declaration is not a subprogram body, then it must be a |
ad4ba28b AC |
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. | |
90a4b336 | 1588 | |
ff1bedac YM |
1589 | case Nkind (N) is |
1590 | when N_Subprogram_Body => | |
1591 | return E; | |
1592 | ||
d8f43ee6 HK |
1593 | when N_Subprogram_Body_Stub |
1594 | | N_Subprogram_Declaration | |
1595 | => | |
ff1bedac YM |
1596 | return Corresponding_Body (N); |
1597 | ||
1598 | when others => | |
1599 | return Empty; | |
1600 | end case; | |
90a4b336 YM |
1601 | end Subprogram_Body_Entity; |
1602 | ||
1603 | --------------------- | |
1604 | -- Subprogram_Spec -- | |
1605 | --------------------- | |
1606 | ||
1607 | function Subprogram_Spec (E : Entity_Id) return Node_Id is | |
4754d4e8 AC |
1608 | N : constant Node_Id := Parent (Subprogram_Specification (E)); |
1609 | -- Declaration for E | |
90a4b336 YM |
1610 | |
1611 | begin | |
90a4b336 YM |
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 | ||
21d27997 RD |
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 | ||
bb10b891 AC |
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 | ||
414b312e AC |
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 | |
f99ff327 AC |
1704 | and then Nkind (N) /= N_Entry_Body |
1705 | and then Nkind (N) /= N_Entry_Declaration | |
414b312e AC |
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 | |
5168a9b3 | 1716 | and then Nkind (N) /= N_Protected_Type_Declaration |
414b312e AC |
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 | ||
21d27997 | 1739 | end Sem_Aux; |