]>
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 | -- -- | |
b98e2969 | 9 | -- Copyright (C) 1992-2012, 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 Sinfo; use Sinfo; |
36 | with Snames; use Snames; | |
37 | with Stand; use Stand; | |
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 | ||
79 | function Available_View (Typ : Entity_Id) return Entity_Id is | |
80 | begin | |
81 | if Is_Incomplete_Type (Typ) | |
82 | and then Present (Non_Limited_View (Typ)) | |
83 | then | |
84 | -- The non-limited view may itself be an incomplete type, in which | |
85 | -- case get its full view. | |
86 | ||
87 | return Get_Full_View (Non_Limited_View (Typ)); | |
88 | ||
89 | elsif Is_Class_Wide_Type (Typ) | |
90 | and then Is_Incomplete_Type (Etype (Typ)) | |
91 | and then Present (Non_Limited_View (Etype (Typ))) | |
92 | then | |
93 | return Class_Wide_Type (Non_Limited_View (Etype (Typ))); | |
94 | ||
95 | else | |
96 | return Typ; | |
97 | end if; | |
98 | end Available_View; | |
99 | ||
100 | -------------------- | |
101 | -- Constant_Value -- | |
102 | -------------------- | |
103 | ||
104 | function Constant_Value (Ent : Entity_Id) return Node_Id is | |
105 | D : constant Node_Id := Declaration_Node (Ent); | |
106 | Full_D : Node_Id; | |
107 | ||
108 | begin | |
550f4135 AC |
109 | -- If we have no declaration node, then return no constant value. Not |
110 | -- clear how this can happen, but it does sometimes and this is the | |
111 | -- safest approach. | |
a4100e55 RD |
112 | |
113 | if No (D) then | |
114 | return Empty; | |
115 | ||
116 | -- Normal case where a declaration node is present | |
117 | ||
118 | elsif Nkind (D) = N_Object_Renaming_Declaration then | |
119 | return Renamed_Object (Ent); | |
120 | ||
934a3a25 | 121 | -- If this is a component declaration whose entity is a constant, it is |
b66c3ff4 | 122 | -- a prival within a protected function (and so has no constant value). |
a4100e55 RD |
123 | |
124 | elsif Nkind (D) = N_Component_Declaration then | |
125 | return Empty; | |
126 | ||
127 | -- If there is an expression, return it | |
128 | ||
129 | elsif Present (Expression (D)) then | |
130 | return (Expression (D)); | |
131 | ||
132 | -- For a constant, see if we have a full view | |
133 | ||
134 | elsif Ekind (Ent) = E_Constant | |
135 | and then Present (Full_View (Ent)) | |
136 | then | |
137 | Full_D := Parent (Full_View (Ent)); | |
138 | ||
139 | -- The full view may have been rewritten as an object renaming | |
140 | ||
141 | if Nkind (Full_D) = N_Object_Renaming_Declaration then | |
142 | return Name (Full_D); | |
143 | else | |
144 | return Expression (Full_D); | |
145 | end if; | |
146 | ||
147 | -- Otherwise we have no expression to return | |
148 | ||
149 | else | |
150 | return Empty; | |
151 | end if; | |
152 | end Constant_Value; | |
153 | ||
414b312e AC |
154 | ---------------------------------------------- |
155 | -- Effectively_Has_Constrained_Partial_View -- | |
156 | ---------------------------------------------- | |
157 | ||
158 | function Effectively_Has_Constrained_Partial_View | |
159 | (Typ : Entity_Id; | |
160 | Scop : Entity_Id) return Boolean | |
161 | is | |
162 | begin | |
163 | return Has_Constrained_Partial_View (Typ) | |
164 | or else (In_Generic_Body (Scop) | |
165 | and then Is_Generic_Type (Base_Type (Typ)) | |
166 | and then Is_Private_Type (Base_Type (Typ)) | |
167 | and then not Is_Tagged_Type (Typ) | |
168 | and then not (Is_Array_Type (Typ) | |
169 | and then not Is_Constrained (Typ)) | |
170 | and then Has_Discriminants (Typ)); | |
171 | end Effectively_Has_Constrained_Partial_View; | |
172 | ||
a4100e55 RD |
173 | ----------------------------- |
174 | -- Enclosing_Dynamic_Scope -- | |
175 | ----------------------------- | |
176 | ||
177 | function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is | |
24357840 | 178 | S : Entity_Id; |
a4100e55 RD |
179 | |
180 | begin | |
550f4135 AC |
181 | -- The following test is an error defense against some syntax errors |
182 | -- that can leave scopes very messed up. | |
a4100e55 RD |
183 | |
184 | if Ent = Standard_Standard then | |
185 | return Ent; | |
186 | end if; | |
187 | ||
188 | -- Normal case, search enclosing scopes | |
189 | ||
ab8e1b35 RD |
190 | -- Note: the test for Present (S) should not be required, it defends |
191 | -- against an ill-formed tree. | |
a4100e55 RD |
192 | |
193 | S := Scope (Ent); | |
194 | loop | |
195 | -- If we somehow got an empty value for Scope, the tree must be | |
196 | -- malformed. Rather than blow up we return Standard in this case. | |
197 | ||
198 | if No (S) then | |
199 | return Standard_Standard; | |
200 | ||
e8374e7a AC |
201 | -- Quit if we get to standard or a dynamic scope. We must also |
202 | -- handle enclosing scopes that have a full view; required to | |
203 | -- locate enclosing scopes that are synchronized private types | |
204 | -- whose full view is a task type. | |
a4100e55 RD |
205 | |
206 | elsif S = Standard_Standard | |
207 | or else Is_Dynamic_Scope (S) | |
e8374e7a AC |
208 | or else (Is_Private_Type (S) |
209 | and then Present (Full_View (S)) | |
210 | and then Is_Dynamic_Scope (Full_View (S))) | |
a4100e55 RD |
211 | then |
212 | return S; | |
213 | ||
214 | -- Otherwise keep climbing | |
215 | ||
216 | else | |
217 | S := Scope (S); | |
218 | end if; | |
219 | end loop; | |
220 | end Enclosing_Dynamic_Scope; | |
221 | ||
222 | ------------------------ | |
223 | -- First_Discriminant -- | |
224 | ------------------------ | |
225 | ||
226 | function First_Discriminant (Typ : Entity_Id) return Entity_Id is | |
227 | Ent : Entity_Id; | |
228 | ||
229 | begin | |
230 | pragma Assert | |
7730df14 | 231 | (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ)); |
a4100e55 RD |
232 | |
233 | Ent := First_Entity (Typ); | |
234 | ||
235 | -- The discriminants are not necessarily contiguous, because access | |
236 | -- discriminants will generate itypes. They are not the first entities | |
df3e68b1 | 237 | -- either because the tag must be ahead of them. |
a4100e55 RD |
238 | |
239 | if Chars (Ent) = Name_uTag then | |
240 | Ent := Next_Entity (Ent); | |
241 | end if; | |
242 | ||
a4100e55 RD |
243 | -- Skip all hidden stored discriminants if any |
244 | ||
245 | while Present (Ent) loop | |
246 | exit when Ekind (Ent) = E_Discriminant | |
247 | and then not Is_Completely_Hidden (Ent); | |
248 | ||
249 | Ent := Next_Entity (Ent); | |
250 | end loop; | |
251 | ||
252 | pragma Assert (Ekind (Ent) = E_Discriminant); | |
253 | ||
254 | return Ent; | |
255 | end First_Discriminant; | |
256 | ||
257 | ------------------------------- | |
258 | -- First_Stored_Discriminant -- | |
259 | ------------------------------- | |
260 | ||
261 | function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is | |
262 | Ent : Entity_Id; | |
263 | ||
264 | function Has_Completely_Hidden_Discriminant | |
265 | (Typ : Entity_Id) return Boolean; | |
266 | -- Scans the Discriminants to see whether any are Completely_Hidden | |
267 | -- (the mechanism for describing non-specified stored discriminants) | |
268 | ||
269 | ---------------------------------------- | |
270 | -- Has_Completely_Hidden_Discriminant -- | |
271 | ---------------------------------------- | |
272 | ||
273 | function Has_Completely_Hidden_Discriminant | |
274 | (Typ : Entity_Id) return Boolean | |
275 | is | |
276 | Ent : Entity_Id; | |
277 | ||
278 | begin | |
279 | pragma Assert (Ekind (Typ) = E_Discriminant); | |
280 | ||
281 | Ent := Typ; | |
282 | while Present (Ent) and then Ekind (Ent) = E_Discriminant loop | |
283 | if Is_Completely_Hidden (Ent) then | |
284 | return True; | |
285 | end if; | |
286 | ||
287 | Ent := Next_Entity (Ent); | |
288 | end loop; | |
289 | ||
290 | return False; | |
291 | end Has_Completely_Hidden_Discriminant; | |
292 | ||
293 | -- Start of processing for First_Stored_Discriminant | |
294 | ||
295 | begin | |
296 | pragma Assert | |
297 | (Has_Discriminants (Typ) | |
298 | or else Has_Unknown_Discriminants (Typ)); | |
299 | ||
300 | Ent := First_Entity (Typ); | |
301 | ||
302 | if Chars (Ent) = Name_uTag then | |
303 | Ent := Next_Entity (Ent); | |
304 | end if; | |
305 | ||
a4100e55 | 306 | if Has_Completely_Hidden_Discriminant (Ent) then |
a4100e55 RD |
307 | while Present (Ent) loop |
308 | exit when Is_Completely_Hidden (Ent); | |
309 | Ent := Next_Entity (Ent); | |
310 | end loop; | |
a4100e55 RD |
311 | end if; |
312 | ||
313 | pragma Assert (Ekind (Ent) = E_Discriminant); | |
314 | ||
315 | return Ent; | |
316 | end First_Stored_Discriminant; | |
317 | ||
318 | ------------------- | |
319 | -- First_Subtype -- | |
320 | ------------------- | |
321 | ||
322 | function First_Subtype (Typ : Entity_Id) return Entity_Id is | |
323 | B : constant Entity_Id := Base_Type (Typ); | |
324 | F : constant Node_Id := Freeze_Node (B); | |
325 | Ent : Entity_Id; | |
326 | ||
327 | begin | |
9e64a2c1 RD |
328 | -- If the base type has no freeze node, it is a type in Standard, and |
329 | -- always acts as its own first subtype, except where it is one of the | |
550f4135 AC |
330 | -- predefined integer types. If the type is formal, it is also a first |
331 | -- subtype, and its base type has no freeze node. On the other hand, a | |
75ba322d | 332 | -- subtype of a generic formal is not its own first subtype. Its base |
550f4135 AC |
333 | -- type, if anonymous, is attached to the formal type decl. from which |
334 | -- the first subtype is obtained. | |
a4100e55 RD |
335 | |
336 | if No (F) then | |
a4100e55 RD |
337 | if B = Base_Type (Standard_Integer) then |
338 | return Standard_Integer; | |
339 | ||
340 | elsif B = Base_Type (Standard_Long_Integer) then | |
341 | return Standard_Long_Integer; | |
342 | ||
343 | elsif B = Base_Type (Standard_Short_Short_Integer) then | |
344 | return Standard_Short_Short_Integer; | |
345 | ||
346 | elsif B = Base_Type (Standard_Short_Integer) then | |
347 | return Standard_Short_Integer; | |
348 | ||
349 | elsif B = Base_Type (Standard_Long_Long_Integer) then | |
350 | return Standard_Long_Long_Integer; | |
351 | ||
352 | elsif Is_Generic_Type (Typ) then | |
353 | if Present (Parent (B)) then | |
354 | return Defining_Identifier (Parent (B)); | |
355 | else | |
356 | return Defining_Identifier (Associated_Node_For_Itype (B)); | |
357 | end if; | |
358 | ||
359 | else | |
360 | return B; | |
361 | end if; | |
362 | ||
363 | -- Otherwise we check the freeze node, if it has a First_Subtype_Link | |
364 | -- then we use that link, otherwise (happens with some Itypes), we use | |
365 | -- the base type itself. | |
366 | ||
367 | else | |
368 | Ent := First_Subtype_Link (F); | |
369 | ||
370 | if Present (Ent) then | |
371 | return Ent; | |
372 | else | |
373 | return B; | |
374 | end if; | |
375 | end if; | |
376 | end First_Subtype; | |
377 | ||
378 | ------------------------- | |
379 | -- First_Tag_Component -- | |
380 | ------------------------- | |
381 | ||
382 | function First_Tag_Component (Typ : Entity_Id) return Entity_Id is | |
383 | Comp : Entity_Id; | |
384 | Ctyp : Entity_Id; | |
385 | ||
386 | begin | |
387 | Ctyp := Typ; | |
388 | pragma Assert (Is_Tagged_Type (Ctyp)); | |
389 | ||
390 | if Is_Class_Wide_Type (Ctyp) then | |
391 | Ctyp := Root_Type (Ctyp); | |
392 | end if; | |
393 | ||
394 | if Is_Private_Type (Ctyp) then | |
395 | Ctyp := Underlying_Type (Ctyp); | |
396 | ||
397 | -- If the underlying type is missing then the source program has | |
398 | -- errors and there is nothing else to do (the full-type declaration | |
399 | -- associated with the private type declaration is missing). | |
400 | ||
401 | if No (Ctyp) then | |
402 | return Empty; | |
403 | end if; | |
404 | end if; | |
405 | ||
406 | Comp := First_Entity (Ctyp); | |
407 | while Present (Comp) loop | |
408 | if Is_Tag (Comp) then | |
409 | return Comp; | |
410 | end if; | |
411 | ||
412 | Comp := Next_Entity (Comp); | |
413 | end loop; | |
414 | ||
415 | -- No tag component found | |
416 | ||
417 | return Empty; | |
418 | end First_Tag_Component; | |
419 | ||
34f3a701 VP |
420 | ------------------ |
421 | -- Get_Rep_Item -- | |
422 | ------------------ | |
423 | ||
424 | function Get_Rep_Item | |
425 | (E : Entity_Id; | |
426 | Nam : Name_Id; | |
427 | Check_Parents : Boolean := True) return Node_Id | |
428 | is | |
429 | N : Node_Id; | |
430 | ||
431 | begin | |
432 | N := First_Rep_Item (E); | |
433 | while Present (N) loop | |
616547fa AC |
434 | |
435 | -- Only one of Priority / Interrupt_Priority can be specified, so | |
436 | -- return whichever one is present to catch illegal duplication. | |
437 | ||
34f3a701 VP |
438 | if Nkind (N) = N_Pragma |
439 | and then | |
440 | (Pragma_Name (N) = Nam | |
441 | or else (Nam = Name_Priority | |
616547fa AC |
442 | and then Pragma_Name (N) = Name_Interrupt_Priority) |
443 | or else (Nam = Name_Interrupt_Priority | |
444 | and then Pragma_Name (N) = Name_Priority)) | |
34f3a701 VP |
445 | then |
446 | if Check_Parents then | |
447 | return N; | |
448 | ||
449 | -- If Check_Parents is False, return N if the pragma doesn't | |
450 | -- appear in the Rep_Item chain of the parent. | |
451 | ||
452 | else | |
453 | declare | |
454 | Par : constant Entity_Id := Nearest_Ancestor (E); | |
455 | -- This node represents the parent type of type E (if any) | |
456 | ||
457 | begin | |
458 | if No (Par) then | |
459 | return N; | |
460 | ||
461 | elsif not Present_In_Rep_Item (Par, N) then | |
462 | return N; | |
463 | end if; | |
464 | end; | |
465 | end if; | |
466 | ||
467 | elsif Nkind (N) = N_Attribute_Definition_Clause | |
468 | and then | |
469 | (Chars (N) = Nam | |
470 | or else (Nam = Name_Priority | |
471 | and then Chars (N) = Name_Interrupt_Priority)) | |
472 | then | |
758ad973 | 473 | if Check_Parents or else Entity (N) = E then |
34f3a701 VP |
474 | return N; |
475 | end if; | |
476 | ||
477 | elsif Nkind (N) = N_Aspect_Specification | |
478 | and then | |
479 | (Chars (Identifier (N)) = Nam | |
480 | or else (Nam = Name_Priority | |
481 | and then Chars (Identifier (N)) = | |
482 | Name_Interrupt_Priority)) | |
483 | then | |
484 | if Check_Parents then | |
485 | return N; | |
486 | ||
487 | elsif Entity (N) = E then | |
488 | return N; | |
489 | end if; | |
490 | end if; | |
491 | ||
492 | Next_Rep_Item (N); | |
493 | end loop; | |
494 | ||
495 | return Empty; | |
496 | end Get_Rep_Item; | |
497 | ||
dc3af7e2 AC |
498 | function Get_Rep_Item |
499 | (E : Entity_Id; | |
500 | Nam1 : Name_Id; | |
501 | Nam2 : Name_Id; | |
502 | Check_Parents : Boolean := True) return Node_Id | |
503 | is | |
504 | Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents); | |
505 | Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents); | |
506 | ||
507 | N : Node_Id; | |
508 | ||
509 | begin | |
510 | -- Check both Nam1_Item and Nam2_Item are present | |
511 | ||
512 | if No (Nam1_Item) then | |
513 | return Nam2_Item; | |
514 | elsif No (Nam2_Item) then | |
515 | return Nam1_Item; | |
516 | end if; | |
517 | ||
518 | -- Return the first node encountered in the list | |
519 | ||
520 | N := First_Rep_Item (E); | |
521 | while Present (N) loop | |
522 | if N = Nam1_Item or else N = Nam2_Item then | |
523 | return N; | |
524 | end if; | |
525 | ||
526 | Next_Rep_Item (N); | |
527 | end loop; | |
528 | ||
529 | return Empty; | |
530 | end Get_Rep_Item; | |
531 | ||
34f3a701 VP |
532 | -------------------- |
533 | -- Get_Rep_Pragma -- | |
534 | -------------------- | |
535 | ||
536 | function Get_Rep_Pragma | |
537 | (E : Entity_Id; | |
538 | Nam : Name_Id; | |
539 | Check_Parents : Boolean := True) return Node_Id | |
540 | is | |
541 | N : Node_Id; | |
542 | ||
543 | begin | |
dc3af7e2 | 544 | N := Get_Rep_Item (E, Nam, Check_Parents); |
34f3a701 | 545 | |
dc3af7e2 AC |
546 | if Present (N) and then Nkind (N) = N_Pragma then |
547 | return N; | |
548 | end if; | |
34f3a701 | 549 | |
dc3af7e2 AC |
550 | return Empty; |
551 | end Get_Rep_Pragma; | |
34f3a701 | 552 | |
dc3af7e2 AC |
553 | function Get_Rep_Pragma |
554 | (E : Entity_Id; | |
555 | Nam1 : Name_Id; | |
556 | Nam2 : Name_Id; | |
557 | Check_Parents : Boolean := True) return Node_Id | |
558 | is | |
559 | Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents); | |
560 | Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents); | |
561 | ||
562 | N : Node_Id; | |
563 | ||
564 | begin | |
565 | -- Check both Nam1_Item and Nam2_Item are present | |
566 | ||
567 | if No (Nam1_Item) then | |
568 | return Nam2_Item; | |
569 | elsif No (Nam2_Item) then | |
570 | return Nam1_Item; | |
571 | end if; | |
572 | ||
573 | -- Return the first node encountered in the list | |
574 | ||
575 | N := First_Rep_Item (E); | |
576 | while Present (N) loop | |
577 | if N = Nam1_Item or else N = Nam2_Item then | |
578 | return N; | |
34f3a701 VP |
579 | end if; |
580 | ||
581 | Next_Rep_Item (N); | |
582 | end loop; | |
583 | ||
584 | return Empty; | |
585 | end Get_Rep_Pragma; | |
586 | ||
587 | ------------------ | |
588 | -- Has_Rep_Item -- | |
589 | ------------------ | |
590 | ||
591 | function Has_Rep_Item | |
592 | (E : Entity_Id; | |
593 | Nam : Name_Id; | |
594 | Check_Parents : Boolean := True) return Boolean | |
595 | is | |
596 | begin | |
597 | return Present (Get_Rep_Item (E, Nam, Check_Parents)); | |
598 | end Has_Rep_Item; | |
599 | ||
dc3af7e2 AC |
600 | function Has_Rep_Item |
601 | (E : Entity_Id; | |
602 | Nam1 : Name_Id; | |
603 | Nam2 : Name_Id; | |
604 | Check_Parents : Boolean := True) return Boolean | |
605 | is | |
606 | begin | |
607 | return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); | |
608 | end Has_Rep_Item; | |
609 | ||
34f3a701 VP |
610 | -------------------- |
611 | -- Has_Rep_Pragma -- | |
612 | -------------------- | |
613 | ||
614 | function Has_Rep_Pragma | |
615 | (E : Entity_Id; | |
616 | Nam : Name_Id; | |
617 | Check_Parents : Boolean := True) return Boolean | |
618 | is | |
619 | begin | |
620 | return Present (Get_Rep_Pragma (E, Nam, Check_Parents)); | |
621 | end Has_Rep_Pragma; | |
622 | ||
dc3af7e2 AC |
623 | function Has_Rep_Pragma |
624 | (E : Entity_Id; | |
625 | Nam1 : Name_Id; | |
626 | Nam2 : Name_Id; | |
627 | Check_Parents : Boolean := True) return Boolean | |
628 | is | |
629 | begin | |
630 | return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); | |
631 | end Has_Rep_Pragma; | |
632 | ||
5b1e6aca RD |
633 | ------------------------------- |
634 | -- Initialization_Suppressed -- | |
635 | ------------------------------- | |
636 | ||
637 | function Initialization_Suppressed (Typ : Entity_Id) return Boolean is | |
638 | begin | |
639 | return Suppress_Initialization (Typ) | |
640 | or else Suppress_Initialization (Base_Type (Typ)); | |
641 | end Initialization_Suppressed; | |
642 | ||
21d27997 RD |
643 | ---------------- |
644 | -- Initialize -- | |
645 | ---------------- | |
646 | ||
647 | procedure Initialize is | |
648 | begin | |
649 | Obsolescent_Warnings.Init; | |
650 | end Initialize; | |
651 | ||
414b312e AC |
652 | --------------------- |
653 | -- In_Generic_Body -- | |
654 | --------------------- | |
655 | ||
656 | function In_Generic_Body (Id : Entity_Id) return Boolean is | |
657 | S : Entity_Id; | |
658 | ||
659 | begin | |
660 | -- Climb scopes looking for generic body | |
661 | ||
662 | S := Id; | |
663 | while Present (S) and then S /= Standard_Standard loop | |
664 | ||
665 | -- Generic package body | |
666 | ||
667 | if Ekind (S) = E_Generic_Package | |
668 | and then In_Package_Body (S) | |
669 | then | |
670 | return True; | |
671 | ||
672 | -- Generic subprogram body | |
673 | ||
674 | elsif Is_Subprogram (S) | |
675 | and then Nkind (Unit_Declaration_Node (S)) | |
676 | = N_Generic_Subprogram_Declaration | |
677 | then | |
678 | return True; | |
679 | end if; | |
680 | ||
681 | S := Scope (S); | |
682 | end loop; | |
683 | ||
684 | -- False if top of scope stack without finding a generic body | |
685 | ||
686 | return False; | |
687 | end In_Generic_Body; | |
688 | ||
a4100e55 RD |
689 | --------------------- |
690 | -- Is_By_Copy_Type -- | |
691 | --------------------- | |
692 | ||
693 | function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is | |
694 | begin | |
695 | -- If Id is a private type whose full declaration has not been seen, | |
696 | -- we assume for now that it is not a By_Copy type. Clearly this | |
697 | -- attribute should not be used before the type is frozen, but it is | |
698 | -- needed to build the associated record of a protected type. Another | |
699 | -- place where some lookahead for a full view is needed ??? | |
700 | ||
701 | return | |
702 | Is_Elementary_Type (Ent) | |
703 | or else (Is_Private_Type (Ent) | |
704 | and then Present (Underlying_Type (Ent)) | |
705 | and then Is_Elementary_Type (Underlying_Type (Ent))); | |
706 | end Is_By_Copy_Type; | |
707 | ||
708 | -------------------------- | |
709 | -- Is_By_Reference_Type -- | |
710 | -------------------------- | |
711 | ||
712 | function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is | |
713 | Btype : constant Entity_Id := Base_Type (Ent); | |
714 | ||
715 | begin | |
9d641fc0 | 716 | if Error_Posted (Ent) or else Error_Posted (Btype) then |
a4100e55 RD |
717 | return False; |
718 | ||
719 | elsif Is_Private_Type (Btype) then | |
720 | declare | |
721 | Utyp : constant Entity_Id := Underlying_Type (Btype); | |
722 | begin | |
723 | if No (Utyp) then | |
724 | return False; | |
725 | else | |
726 | return Is_By_Reference_Type (Utyp); | |
727 | end if; | |
728 | end; | |
729 | ||
730 | elsif Is_Incomplete_Type (Btype) then | |
731 | declare | |
732 | Ftyp : constant Entity_Id := Full_View (Btype); | |
733 | begin | |
734 | if No (Ftyp) then | |
735 | return False; | |
736 | else | |
737 | return Is_By_Reference_Type (Ftyp); | |
738 | end if; | |
739 | end; | |
740 | ||
741 | elsif Is_Concurrent_Type (Btype) then | |
742 | return True; | |
743 | ||
744 | elsif Is_Record_Type (Btype) then | |
745 | if Is_Limited_Record (Btype) | |
746 | or else Is_Tagged_Type (Btype) | |
747 | or else Is_Volatile (Btype) | |
748 | then | |
749 | return True; | |
750 | ||
751 | else | |
752 | declare | |
753 | C : Entity_Id; | |
754 | ||
755 | begin | |
756 | C := First_Component (Btype); | |
757 | while Present (C) loop | |
758 | if Is_By_Reference_Type (Etype (C)) | |
759 | or else Is_Volatile (Etype (C)) | |
760 | then | |
761 | return True; | |
762 | end if; | |
763 | ||
764 | C := Next_Component (C); | |
765 | end loop; | |
766 | end; | |
767 | ||
768 | return False; | |
769 | end if; | |
770 | ||
771 | elsif Is_Array_Type (Btype) then | |
772 | return | |
773 | Is_Volatile (Btype) | |
774 | or else Is_By_Reference_Type (Component_Type (Btype)) | |
775 | or else Is_Volatile (Component_Type (Btype)) | |
776 | or else Has_Volatile_Components (Btype); | |
777 | ||
778 | else | |
779 | return False; | |
780 | end if; | |
781 | end Is_By_Reference_Type; | |
782 | ||
783 | --------------------- | |
784 | -- Is_Derived_Type -- | |
785 | --------------------- | |
786 | ||
787 | function Is_Derived_Type (Ent : E) return B is | |
788 | Par : Node_Id; | |
789 | ||
790 | begin | |
791 | if Is_Type (Ent) | |
792 | and then Base_Type (Ent) /= Root_Type (Ent) | |
793 | and then not Is_Class_Wide_Type (Ent) | |
794 | then | |
795 | if not Is_Numeric_Type (Root_Type (Ent)) then | |
796 | return True; | |
797 | ||
798 | else | |
799 | Par := Parent (First_Subtype (Ent)); | |
800 | ||
801 | return Present (Par) | |
802 | and then Nkind (Par) = N_Full_Type_Declaration | |
803 | and then Nkind (Type_Definition (Par)) = | |
804 | N_Derived_Type_Definition; | |
805 | end if; | |
806 | ||
807 | else | |
808 | return False; | |
809 | end if; | |
810 | end Is_Derived_Type; | |
811 | ||
57d62f0c AC |
812 | ----------------------- |
813 | -- Is_Generic_Formal -- | |
814 | ----------------------- | |
815 | ||
816 | function Is_Generic_Formal (E : Entity_Id) return Boolean is | |
817 | Kind : Node_Kind; | |
818 | begin | |
819 | if No (E) then | |
820 | return False; | |
821 | else | |
822 | Kind := Nkind (Parent (E)); | |
823 | return | |
824 | Nkind_In (Kind, N_Formal_Object_Declaration, | |
825 | N_Formal_Package_Declaration, | |
826 | N_Formal_Type_Declaration) | |
827 | or else Is_Formal_Subprogram (E); | |
828 | end if; | |
829 | end Is_Generic_Formal; | |
830 | ||
a4100e55 RD |
831 | --------------------------- |
832 | -- Is_Indefinite_Subtype -- | |
833 | --------------------------- | |
834 | ||
835 | function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is | |
836 | K : constant Entity_Kind := Ekind (Ent); | |
837 | ||
838 | begin | |
839 | if Is_Constrained (Ent) then | |
840 | return False; | |
841 | ||
842 | elsif K in Array_Kind | |
843 | or else K in Class_Wide_Kind | |
844 | or else Has_Unknown_Discriminants (Ent) | |
845 | then | |
846 | return True; | |
847 | ||
848 | -- Known discriminants: indefinite if there are no default values | |
849 | ||
850 | elsif K in Record_Kind | |
851 | or else Is_Incomplete_Or_Private_Type (Ent) | |
852 | or else Is_Concurrent_Type (Ent) | |
853 | then | |
854 | return (Has_Discriminants (Ent) | |
855 | and then | |
856 | No (Discriminant_Default_Value (First_Discriminant (Ent)))); | |
857 | ||
858 | else | |
859 | return False; | |
860 | end if; | |
861 | end Is_Indefinite_Subtype; | |
862 | ||
40f07b4b AC |
863 | ------------------------------- |
864 | -- Is_Immutably_Limited_Type -- | |
865 | ------------------------------- | |
a4100e55 | 866 | |
40f07b4b | 867 | function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is |
94bbf008 | 868 | Btype : constant Entity_Id := Available_View (Base_Type (Ent)); |
a4100e55 RD |
869 | |
870 | begin | |
b0887a43 AC |
871 | if Is_Limited_Record (Btype) then |
872 | return True; | |
873 | ||
874 | elsif Ekind (Btype) = E_Limited_Private_Type | |
b878c938 AC |
875 | and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration |
876 | then | |
877 | return not In_Package_Body (Scope ((Btype))); | |
40f07b4b | 878 | |
94bbf008 | 879 | elsif Is_Private_Type (Btype) then |
e0ae93e2 RD |
880 | |
881 | -- AI05-0063: A type derived from a limited private formal type is | |
882 | -- not immutably limited in a generic body. | |
40f07b4b AC |
883 | |
884 | if Is_Derived_Type (Btype) | |
885 | and then Is_Generic_Type (Etype (Btype)) | |
886 | then | |
887 | if not Is_Limited_Type (Etype (Btype)) then | |
a4100e55 | 888 | return False; |
40f07b4b | 889 | |
b0887a43 AC |
890 | -- A descendant of a limited formal type is not immutably limited |
891 | -- in the generic body, or in the body of a generic child. | |
892 | ||
40f07b4b | 893 | elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then |
b0887a43 | 894 | return not In_Package_Body (Scope (Btype)); |
40f07b4b | 895 | |
a4100e55 | 896 | else |
40f07b4b | 897 | return False; |
a4100e55 | 898 | end if; |
40f07b4b AC |
899 | |
900 | else | |
901 | declare | |
902 | Utyp : constant Entity_Id := Underlying_Type (Btype); | |
903 | begin | |
904 | if No (Utyp) then | |
905 | return False; | |
906 | else | |
907 | return Is_Immutably_Limited_Type (Utyp); | |
908 | end if; | |
909 | end; | |
910 | end if; | |
a4100e55 RD |
911 | |
912 | elsif Is_Concurrent_Type (Btype) then | |
913 | return True; | |
914 | ||
915 | elsif Is_Record_Type (Btype) then | |
2a31c32b AC |
916 | |
917 | -- Note that we return True for all limited interfaces, even though | |
918 | -- (unsynchronized) limited interfaces can have descendants that are | |
919 | -- nonlimited, because this is a predicate on the type itself, and | |
920 | -- things like functions with limited interface results need to be | |
921 | -- handled as build in place even though they might return objects | |
922 | -- of a type that is not inherently limited. | |
923 | ||
b0887a43 | 924 | if Is_Class_Wide_Type (Btype) then |
40f07b4b | 925 | return Is_Immutably_Limited_Type (Root_Type (Btype)); |
a4100e55 RD |
926 | |
927 | else | |
928 | declare | |
929 | C : Entity_Id; | |
930 | ||
931 | begin | |
932 | C := First_Component (Btype); | |
933 | while Present (C) loop | |
2a31c32b AC |
934 | |
935 | -- Don't consider components with interface types (which can | |
936 | -- only occur in the case of a _parent component anyway). | |
937 | -- They don't have any components, plus it would cause this | |
938 | -- function to return true for nonlimited types derived from | |
308e6f3a | 939 | -- limited interfaces. |
2a31c32b AC |
940 | |
941 | if not Is_Interface (Etype (C)) | |
40f07b4b | 942 | and then Is_Immutably_Limited_Type (Etype (C)) |
2a31c32b | 943 | then |
a4100e55 RD |
944 | return True; |
945 | end if; | |
946 | ||
947 | C := Next_Component (C); | |
948 | end loop; | |
949 | end; | |
950 | ||
951 | return False; | |
952 | end if; | |
953 | ||
954 | elsif Is_Array_Type (Btype) then | |
40f07b4b | 955 | return Is_Immutably_Limited_Type (Component_Type (Btype)); |
a4100e55 RD |
956 | |
957 | else | |
958 | return False; | |
959 | end if; | |
40f07b4b | 960 | end Is_Immutably_Limited_Type; |
a4100e55 RD |
961 | |
962 | --------------------- | |
963 | -- Is_Limited_Type -- | |
964 | --------------------- | |
965 | ||
966 | function Is_Limited_Type (Ent : Entity_Id) return Boolean is | |
967 | Btype : constant E := Base_Type (Ent); | |
968 | Rtype : constant E := Root_Type (Btype); | |
969 | ||
970 | begin | |
971 | if not Is_Type (Ent) then | |
972 | return False; | |
973 | ||
974 | elsif Ekind (Btype) = E_Limited_Private_Type | |
975 | or else Is_Limited_Composite (Btype) | |
976 | then | |
977 | return True; | |
978 | ||
979 | elsif Is_Concurrent_Type (Btype) then | |
980 | return True; | |
981 | ||
982 | -- The Is_Limited_Record flag normally indicates that the type is | |
983 | -- limited. The exception is that a type does not inherit limitedness | |
984 | -- from its interface ancestor. So the type may be derived from a | |
985 | -- limited interface, but is not limited. | |
986 | ||
987 | elsif Is_Limited_Record (Ent) | |
988 | and then not Is_Interface (Ent) | |
989 | then | |
990 | return True; | |
991 | ||
992 | -- Otherwise we will look around to see if there is some other reason | |
993 | -- for it to be limited, except that if an error was posted on the | |
994 | -- entity, then just assume it is non-limited, because it can cause | |
995 | -- trouble to recurse into a murky erroneous entity! | |
996 | ||
997 | elsif Error_Posted (Ent) then | |
998 | return False; | |
999 | ||
1000 | elsif Is_Record_Type (Btype) then | |
1001 | ||
1002 | if Is_Limited_Interface (Ent) then | |
1003 | return True; | |
1004 | ||
1005 | -- AI-419: limitedness is not inherited from a limited interface | |
1006 | ||
1007 | elsif Is_Limited_Record (Rtype) then | |
1008 | return not Is_Interface (Rtype) | |
1009 | or else Is_Protected_Interface (Rtype) | |
1010 | or else Is_Synchronized_Interface (Rtype) | |
1011 | or else Is_Task_Interface (Rtype); | |
1012 | ||
1013 | elsif Is_Class_Wide_Type (Btype) then | |
1014 | return Is_Limited_Type (Rtype); | |
1015 | ||
1016 | else | |
1017 | declare | |
1018 | C : E; | |
1019 | ||
1020 | begin | |
1021 | C := First_Component (Btype); | |
1022 | while Present (C) loop | |
1023 | if Is_Limited_Type (Etype (C)) then | |
1024 | return True; | |
1025 | end if; | |
1026 | ||
1027 | C := Next_Component (C); | |
1028 | end loop; | |
1029 | end; | |
1030 | ||
1031 | return False; | |
1032 | end if; | |
1033 | ||
1034 | elsif Is_Array_Type (Btype) then | |
1035 | return Is_Limited_Type (Component_Type (Btype)); | |
1036 | ||
1037 | else | |
1038 | return False; | |
1039 | end if; | |
1040 | end Is_Limited_Type; | |
1041 | ||
8110ee3b RD |
1042 | ---------------------- |
1043 | -- Nearest_Ancestor -- | |
1044 | ---------------------- | |
1045 | ||
1046 | function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is | |
34f3a701 | 1047 | D : constant Node_Id := Declaration_Node (Typ); |
8110ee3b RD |
1048 | |
1049 | begin | |
1050 | -- If we have a subtype declaration, get the ancestor subtype | |
1051 | ||
1052 | if Nkind (D) = N_Subtype_Declaration then | |
1053 | if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then | |
1054 | return Entity (Subtype_Mark (Subtype_Indication (D))); | |
1055 | else | |
1056 | return Entity (Subtype_Indication (D)); | |
1057 | end if; | |
1058 | ||
1059 | -- If derived type declaration, find who we are derived from | |
1060 | ||
1061 | elsif Nkind (D) = N_Full_Type_Declaration | |
1062 | and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition | |
1063 | then | |
1064 | declare | |
1065 | DTD : constant Entity_Id := Type_Definition (D); | |
1066 | SI : constant Entity_Id := Subtype_Indication (DTD); | |
1067 | begin | |
1068 | if Is_Entity_Name (SI) then | |
1069 | return Entity (SI); | |
1070 | else | |
1071 | return Entity (Subtype_Mark (SI)); | |
1072 | end if; | |
1073 | end; | |
1074 | ||
b98e2969 AC |
1075 | -- If derived type and private type, get the full view to find who we |
1076 | -- are derived from. | |
1077 | ||
1078 | elsif Is_Derived_Type (Typ) | |
1079 | and then Is_Private_Type (Typ) | |
1080 | and then Present (Full_View (Typ)) | |
1081 | then | |
1082 | return Nearest_Ancestor (Full_View (Typ)); | |
1083 | ||
8110ee3b RD |
1084 | -- Otherwise, nothing useful to return, return Empty |
1085 | ||
1086 | else | |
1087 | return Empty; | |
1088 | end if; | |
1089 | end Nearest_Ancestor; | |
1090 | ||
24357840 RD |
1091 | --------------------------- |
1092 | -- Nearest_Dynamic_Scope -- | |
1093 | --------------------------- | |
1094 | ||
1095 | function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is | |
1096 | begin | |
1097 | if Is_Dynamic_Scope (Ent) then | |
1098 | return Ent; | |
1099 | else | |
1100 | return Enclosing_Dynamic_Scope (Ent); | |
1101 | end if; | |
1102 | end Nearest_Dynamic_Scope; | |
1103 | ||
a4100e55 RD |
1104 | ------------------------ |
1105 | -- Next_Tag_Component -- | |
1106 | ------------------------ | |
1107 | ||
1108 | function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is | |
1109 | Comp : Entity_Id; | |
1110 | ||
1111 | begin | |
1112 | pragma Assert (Is_Tag (Tag)); | |
1113 | ||
043ce308 AC |
1114 | -- Loop to look for next tag component |
1115 | ||
a4100e55 RD |
1116 | Comp := Next_Entity (Tag); |
1117 | while Present (Comp) loop | |
1118 | if Is_Tag (Comp) then | |
1119 | pragma Assert (Chars (Comp) /= Name_uTag); | |
1120 | return Comp; | |
1121 | end if; | |
1122 | ||
1123 | Comp := Next_Entity (Comp); | |
1124 | end loop; | |
1125 | ||
1126 | -- No tag component found | |
1127 | ||
1128 | return Empty; | |
1129 | end Next_Tag_Component; | |
1130 | ||
1131 | -------------------------- | |
1132 | -- Number_Discriminants -- | |
1133 | -------------------------- | |
1134 | ||
1135 | function Number_Discriminants (Typ : Entity_Id) return Pos is | |
1136 | N : Int; | |
1137 | Discr : Entity_Id; | |
1138 | ||
1139 | begin | |
1140 | N := 0; | |
1141 | Discr := First_Discriminant (Typ); | |
1142 | while Present (Discr) loop | |
1143 | N := N + 1; | |
1144 | Discr := Next_Discriminant (Discr); | |
1145 | end loop; | |
1146 | ||
1147 | return N; | |
1148 | end Number_Discriminants; | |
1149 | ||
21d27997 RD |
1150 | --------------- |
1151 | -- Tree_Read -- | |
1152 | --------------- | |
1153 | ||
1154 | procedure Tree_Read is | |
1155 | begin | |
1156 | Obsolescent_Warnings.Tree_Read; | |
1157 | end Tree_Read; | |
1158 | ||
1159 | ---------------- | |
1160 | -- Tree_Write -- | |
1161 | ---------------- | |
1162 | ||
1163 | procedure Tree_Write is | |
1164 | begin | |
1165 | Obsolescent_Warnings.Tree_Write; | |
1166 | end Tree_Write; | |
1167 | ||
bb10b891 AC |
1168 | -------------------- |
1169 | -- Ultimate_Alias -- | |
1170 | -------------------- | |
1171 | ||
1172 | function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is | |
1173 | E : Entity_Id := Prim; | |
1174 | ||
1175 | begin | |
1176 | while Present (Alias (E)) loop | |
1177 | pragma Assert (Alias (E) /= E); | |
1178 | E := Alias (E); | |
1179 | end loop; | |
1180 | ||
1181 | return E; | |
1182 | end Ultimate_Alias; | |
1183 | ||
414b312e AC |
1184 | -------------------------- |
1185 | -- Unit_Declaration_Node -- | |
1186 | -------------------------- | |
1187 | ||
1188 | function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is | |
1189 | N : Node_Id := Parent (Unit_Id); | |
1190 | ||
1191 | begin | |
1192 | -- Predefined operators do not have a full function declaration | |
1193 | ||
1194 | if Ekind (Unit_Id) = E_Operator then | |
1195 | return N; | |
1196 | end if; | |
1197 | ||
1198 | -- Isn't there some better way to express the following ??? | |
1199 | ||
1200 | while Nkind (N) /= N_Abstract_Subprogram_Declaration | |
1201 | and then Nkind (N) /= N_Formal_Package_Declaration | |
1202 | and then Nkind (N) /= N_Function_Instantiation | |
1203 | and then Nkind (N) /= N_Generic_Package_Declaration | |
1204 | and then Nkind (N) /= N_Generic_Subprogram_Declaration | |
1205 | and then Nkind (N) /= N_Package_Declaration | |
1206 | and then Nkind (N) /= N_Package_Body | |
1207 | and then Nkind (N) /= N_Package_Instantiation | |
1208 | and then Nkind (N) /= N_Package_Renaming_Declaration | |
1209 | and then Nkind (N) /= N_Procedure_Instantiation | |
1210 | and then Nkind (N) /= N_Protected_Body | |
1211 | and then Nkind (N) /= N_Subprogram_Declaration | |
1212 | and then Nkind (N) /= N_Subprogram_Body | |
1213 | and then Nkind (N) /= N_Subprogram_Body_Stub | |
1214 | and then Nkind (N) /= N_Subprogram_Renaming_Declaration | |
1215 | and then Nkind (N) /= N_Task_Body | |
1216 | and then Nkind (N) /= N_Task_Type_Declaration | |
1217 | and then Nkind (N) not in N_Formal_Subprogram_Declaration | |
1218 | and then Nkind (N) not in N_Generic_Renaming_Declaration | |
1219 | loop | |
1220 | N := Parent (N); | |
1221 | ||
1222 | -- We don't use Assert here, because that causes an infinite loop | |
1223 | -- when assertions are turned off. Better to crash. | |
1224 | ||
1225 | if No (N) then | |
1226 | raise Program_Error; | |
1227 | end if; | |
1228 | end loop; | |
1229 | ||
1230 | return N; | |
1231 | end Unit_Declaration_Node; | |
1232 | ||
21d27997 | 1233 | end Sem_Aux; |