]>
Commit | Line | Data |
---|---|---|
d55c93e0 | 1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ A U X -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8149276d | 9 | -- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- |
d55c93e0 | 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 | ||
d60c9ff7 | 33 | with Atree; use Atree; |
34 | with Einfo; use Einfo; | |
d60c9ff7 | 35 | with Snames; use Snames; |
36 | with Stand; use Stand; | |
34ebc386 | 37 | with Uintp; use Uintp; |
d60c9ff7 | 38 | |
d55c93e0 | 39 | package body Sem_Aux is |
40 | ||
d60c9ff7 | 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 | ||
5b990e08 | 50 | if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then |
d60c9ff7 | 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 | ||
da1724ff | 79 | function Available_View (Ent : Entity_Id) return Entity_Id is |
d60c9ff7 | 80 | begin |
40993cdb | 81 | -- Obtain the non-limited view (if available) |
da1724ff | 82 | |
40993cdb | 83 | if Has_Non_Limited_View (Ent) then |
da1724ff | 84 | return Get_Full_View (Non_Limited_View (Ent)); |
d60c9ff7 | 85 | |
ac9184ed | 86 | -- In all other cases, return entity unchanged |
87 | ||
d60c9ff7 | 88 | else |
da1724ff | 89 | return Ent; |
d60c9ff7 | 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 | |
4a8d5a0a | 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. | |
d60c9ff7 | 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 | ||
b6dbc975 | 114 | -- If this is a component declaration whose entity is a constant, it is |
1ce752d5 | 115 | -- a prival within a protected function (and so has no constant value). |
d60c9ff7 | 116 | |
117 | elsif Nkind (D) = N_Component_Declaration then | |
118 | return Empty; | |
119 | ||
120 | -- If there is an expression, return it | |
121 | ||
122 | elsif Present (Expression (D)) then | |
123 | return (Expression (D)); | |
124 | ||
125 | -- For a constant, see if we have a full view | |
126 | ||
127 | elsif Ekind (Ent) = E_Constant | |
128 | and then Present (Full_View (Ent)) | |
129 | then | |
130 | Full_D := Parent (Full_View (Ent)); | |
131 | ||
132 | -- The full view may have been rewritten as an object renaming | |
133 | ||
134 | if Nkind (Full_D) = N_Object_Renaming_Declaration then | |
135 | return Name (Full_D); | |
136 | else | |
137 | return Expression (Full_D); | |
138 | end if; | |
139 | ||
140 | -- Otherwise we have no expression to return | |
141 | ||
142 | else | |
143 | return Empty; | |
144 | end if; | |
145 | end Constant_Value; | |
146 | ||
34ebc386 | 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 | ||
d60c9ff7 | 170 | ----------------------------- |
171 | -- Enclosing_Dynamic_Scope -- | |
172 | ----------------------------- | |
173 | ||
174 | function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is | |
1971b754 | 175 | S : Entity_Id; |
d60c9ff7 | 176 | |
177 | begin | |
4a8d5a0a | 178 | -- The following test is an error defense against some syntax errors |
179 | -- that can leave scopes very messed up. | |
d60c9ff7 | 180 | |
181 | if Ent = Standard_Standard then | |
182 | return Ent; | |
183 | end if; | |
184 | ||
185 | -- Normal case, search enclosing scopes | |
186 | ||
d3df8832 | 187 | -- Note: the test for Present (S) should not be required, it defends |
188 | -- against an ill-formed tree. | |
d60c9ff7 | 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 | ||
bf7f5966 | 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. | |
d60c9ff7 | 202 | |
203 | elsif S = Standard_Standard | |
204 | or else Is_Dynamic_Scope (S) | |
bf7f5966 | 205 | or else (Is_Private_Type (S) |
206 | and then Present (Full_View (S)) | |
207 | and then Is_Dynamic_Scope (Full_View (S))) | |
d60c9ff7 | 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 | |
12f01b27 | 228 | (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ)); |
d60c9ff7 | 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 | |
bb3b440a | 234 | -- either because the tag must be ahead of them. |
d60c9ff7 | 235 | |
236 | if Chars (Ent) = Name_uTag then | |
237 | Ent := Next_Entity (Ent); | |
238 | end if; | |
239 | ||
d60c9ff7 | 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 | ||
3c9ef629 | 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 | ||
c96806b2 | 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. | |
d60c9ff7 | 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) | |
2ae4e1e6 | 270 | -- Note that the entity list for the type may contain anonymous access |
271 | -- types created by expressions that constrain access discriminants. | |
d60c9ff7 | 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; | |
2ae4e1e6 | 286 | while Present (Ent) loop |
287 | ||
288 | -- Skip anonymous types that may be created by expressions | |
289 | -- used as discriminant constraints on inherited discriminants. | |
290 | ||
291 | if Is_Itype (Ent) then | |
292 | null; | |
293 | ||
294 | elsif Ekind (Ent) = E_Discriminant | |
295 | and then Is_Completely_Hidden (Ent) | |
296 | then | |
d60c9ff7 | 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 | ||
d60c9ff7 | 319 | if Has_Completely_Hidden_Discriminant (Ent) then |
d60c9ff7 | 320 | while Present (Ent) loop |
2ae4e1e6 | 321 | exit when Ekind (Ent) = E_Discriminant |
322 | and then Is_Completely_Hidden (Ent); | |
d60c9ff7 | 323 | Ent := Next_Entity (Ent); |
324 | end loop; | |
d60c9ff7 | 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 | |
020b6058 | 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 | |
4a8d5a0a | 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 | |
ed195555 | 346 | -- subtype of a generic formal is not its own first subtype. Its base |
4a8d5a0a | 347 | -- type, if anonymous, is attached to the formal type decl. from which |
348 | -- the first subtype is obtained. | |
d60c9ff7 | 349 | |
350 | if No (F) then | |
d60c9ff7 | 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 | ||
5cf1cbbb | 434 | --------------------- |
435 | -- Get_Binary_Nkind -- | |
436 | --------------------- | |
437 | ||
438 | function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is | |
5cf1cbbb | 439 | begin |
7d4d0bef | 440 | case Chars (Op) is |
441 | when Name_Op_Add => | |
442 | return N_Op_Add; | |
443 | when Name_Op_Concat => | |
444 | return N_Op_Concat; | |
445 | when Name_Op_Expon => | |
446 | return N_Op_Expon; | |
447 | when Name_Op_Subtract => | |
448 | return N_Op_Subtract; | |
449 | when Name_Op_Mod => | |
450 | return N_Op_Mod; | |
451 | when Name_Op_Multiply => | |
452 | return N_Op_Multiply; | |
453 | when Name_Op_Divide => | |
454 | return N_Op_Divide; | |
455 | when Name_Op_Rem => | |
456 | return N_Op_Rem; | |
457 | when Name_Op_And => | |
458 | return N_Op_And; | |
459 | when Name_Op_Eq => | |
460 | return N_Op_Eq; | |
461 | when Name_Op_Ge => | |
462 | return N_Op_Ge; | |
463 | when Name_Op_Gt => | |
464 | return N_Op_Gt; | |
465 | when Name_Op_Le => | |
466 | return N_Op_Le; | |
467 | when Name_Op_Lt => | |
468 | return N_Op_Lt; | |
469 | when Name_Op_Ne => | |
470 | return N_Op_Ne; | |
471 | when Name_Op_Or => | |
472 | return N_Op_Or; | |
473 | when Name_Op_Xor => | |
474 | return N_Op_Xor; | |
475 | when others => | |
476 | raise Program_Error; | |
477 | end case; | |
5cf1cbbb | 478 | end Get_Binary_Nkind; |
479 | ||
c143b3d7 | 480 | ------------------- |
481 | -- Get_Low_Bound -- | |
482 | ------------------- | |
483 | ||
484 | function Get_Low_Bound (E : Entity_Id) return Node_Id is | |
485 | begin | |
486 | if Ekind (E) = E_String_Literal_Subtype then | |
487 | return String_Literal_Low_Bound (E); | |
488 | else | |
895fed95 | 489 | return Type_Low_Bound (E); |
c143b3d7 | 490 | end if; |
491 | end Get_Low_Bound; | |
492 | ||
89b3b365 | 493 | ------------------ |
494 | -- Get_Rep_Item -- | |
495 | ------------------ | |
496 | ||
497 | function Get_Rep_Item | |
498 | (E : Entity_Id; | |
499 | Nam : Name_Id; | |
500 | Check_Parents : Boolean := True) return Node_Id | |
501 | is | |
502 | N : Node_Id; | |
503 | ||
504 | begin | |
505 | N := First_Rep_Item (E); | |
506 | while Present (N) loop | |
b9e61b2a | 507 | |
508 | -- Only one of Priority / Interrupt_Priority can be specified, so | |
509 | -- return whichever one is present to catch illegal duplication. | |
510 | ||
89b3b365 | 511 | if Nkind (N) = N_Pragma |
512 | and then | |
513 | (Pragma_Name (N) = Nam | |
514 | or else (Nam = Name_Priority | |
b9e61b2a | 515 | and then Pragma_Name (N) = Name_Interrupt_Priority) |
516 | or else (Nam = Name_Interrupt_Priority | |
517 | and then Pragma_Name (N) = Name_Priority)) | |
89b3b365 | 518 | then |
519 | if Check_Parents then | |
520 | return N; | |
521 | ||
522 | -- If Check_Parents is False, return N if the pragma doesn't | |
523 | -- appear in the Rep_Item chain of the parent. | |
524 | ||
525 | else | |
526 | declare | |
527 | Par : constant Entity_Id := Nearest_Ancestor (E); | |
528 | -- This node represents the parent type of type E (if any) | |
529 | ||
530 | begin | |
531 | if No (Par) then | |
532 | return N; | |
533 | ||
534 | elsif not Present_In_Rep_Item (Par, N) then | |
535 | return N; | |
536 | end if; | |
537 | end; | |
538 | end if; | |
539 | ||
540 | elsif Nkind (N) = N_Attribute_Definition_Clause | |
541 | and then | |
542 | (Chars (N) = Nam | |
18393965 | 543 | or else (Nam = Name_Priority |
544 | and then Chars (N) = Name_Interrupt_Priority)) | |
89b3b365 | 545 | then |
2fec2b51 | 546 | if Check_Parents or else Entity (N) = E then |
89b3b365 | 547 | return N; |
548 | end if; | |
549 | ||
550 | elsif Nkind (N) = N_Aspect_Specification | |
551 | and then | |
552 | (Chars (Identifier (N)) = Nam | |
18393965 | 553 | or else |
554 | (Nam = Name_Priority | |
555 | and then Chars (Identifier (N)) = Name_Interrupt_Priority)) | |
89b3b365 | 556 | then |
557 | if Check_Parents then | |
558 | return N; | |
559 | ||
560 | elsif Entity (N) = E then | |
561 | return N; | |
562 | end if; | |
563 | end if; | |
564 | ||
565 | Next_Rep_Item (N); | |
566 | end loop; | |
567 | ||
568 | return Empty; | |
569 | end Get_Rep_Item; | |
570 | ||
99a2d5bd | 571 | function Get_Rep_Item |
572 | (E : Entity_Id; | |
573 | Nam1 : Name_Id; | |
574 | Nam2 : Name_Id; | |
575 | Check_Parents : Boolean := True) return Node_Id | |
576 | is | |
577 | Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents); | |
578 | Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents); | |
579 | ||
580 | N : Node_Id; | |
581 | ||
582 | begin | |
583 | -- Check both Nam1_Item and Nam2_Item are present | |
584 | ||
585 | if No (Nam1_Item) then | |
586 | return Nam2_Item; | |
587 | elsif No (Nam2_Item) then | |
588 | return Nam1_Item; | |
589 | end if; | |
590 | ||
591 | -- Return the first node encountered in the list | |
592 | ||
593 | N := First_Rep_Item (E); | |
594 | while Present (N) loop | |
595 | if N = Nam1_Item or else N = Nam2_Item then | |
596 | return N; | |
597 | end if; | |
598 | ||
599 | Next_Rep_Item (N); | |
600 | end loop; | |
601 | ||
602 | return Empty; | |
603 | end Get_Rep_Item; | |
604 | ||
89b3b365 | 605 | -------------------- |
606 | -- Get_Rep_Pragma -- | |
607 | -------------------- | |
608 | ||
609 | function Get_Rep_Pragma | |
610 | (E : Entity_Id; | |
611 | Nam : Name_Id; | |
612 | Check_Parents : Boolean := True) return Node_Id | |
613 | is | |
614 | N : Node_Id; | |
615 | ||
616 | begin | |
99a2d5bd | 617 | N := Get_Rep_Item (E, Nam, Check_Parents); |
89b3b365 | 618 | |
99a2d5bd | 619 | if Present (N) and then Nkind (N) = N_Pragma then |
620 | return N; | |
621 | end if; | |
89b3b365 | 622 | |
99a2d5bd | 623 | return Empty; |
624 | end Get_Rep_Pragma; | |
89b3b365 | 625 | |
99a2d5bd | 626 | function Get_Rep_Pragma |
627 | (E : Entity_Id; | |
628 | Nam1 : Name_Id; | |
629 | Nam2 : Name_Id; | |
630 | Check_Parents : Boolean := True) return Node_Id | |
631 | is | |
632 | Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents); | |
633 | Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents); | |
634 | ||
635 | N : Node_Id; | |
636 | ||
637 | begin | |
638 | -- Check both Nam1_Item and Nam2_Item are present | |
639 | ||
640 | if No (Nam1_Item) then | |
641 | return Nam2_Item; | |
642 | elsif No (Nam2_Item) then | |
643 | return Nam1_Item; | |
644 | end if; | |
645 | ||
646 | -- Return the first node encountered in the list | |
647 | ||
648 | N := First_Rep_Item (E); | |
649 | while Present (N) loop | |
650 | if N = Nam1_Item or else N = Nam2_Item then | |
651 | return N; | |
89b3b365 | 652 | end if; |
653 | ||
654 | Next_Rep_Item (N); | |
655 | end loop; | |
656 | ||
657 | return Empty; | |
658 | end Get_Rep_Pragma; | |
659 | ||
5cf1cbbb | 660 | --------------------- |
661 | -- Get_Unary_Nkind -- | |
662 | --------------------- | |
663 | ||
664 | function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is | |
5cf1cbbb | 665 | begin |
7d4d0bef | 666 | case Chars (Op) is |
667 | when Name_Op_Abs => | |
668 | return N_Op_Abs; | |
669 | when Name_Op_Subtract => | |
670 | return N_Op_Minus; | |
671 | when Name_Op_Not => | |
672 | return N_Op_Not; | |
673 | when Name_Op_Add => | |
674 | return N_Op_Plus; | |
675 | when others => | |
676 | raise Program_Error; | |
677 | end case; | |
5cf1cbbb | 678 | end Get_Unary_Nkind; |
679 | ||
15a67a0a | 680 | --------------------------------- |
681 | -- Has_External_Tag_Rep_Clause -- | |
682 | --------------------------------- | |
683 | ||
684 | function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is | |
685 | begin | |
686 | pragma Assert (Is_Tagged_Type (T)); | |
687 | return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False); | |
688 | end Has_External_Tag_Rep_Clause; | |
689 | ||
89b3b365 | 690 | ------------------ |
691 | -- Has_Rep_Item -- | |
692 | ------------------ | |
693 | ||
694 | function Has_Rep_Item | |
695 | (E : Entity_Id; | |
696 | Nam : Name_Id; | |
697 | Check_Parents : Boolean := True) return Boolean | |
698 | is | |
699 | begin | |
700 | return Present (Get_Rep_Item (E, Nam, Check_Parents)); | |
701 | end Has_Rep_Item; | |
702 | ||
99a2d5bd | 703 | function Has_Rep_Item |
704 | (E : Entity_Id; | |
705 | Nam1 : Name_Id; | |
706 | Nam2 : Name_Id; | |
707 | Check_Parents : Boolean := True) return Boolean | |
708 | is | |
709 | begin | |
710 | return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); | |
711 | end Has_Rep_Item; | |
712 | ||
89b3b365 | 713 | -------------------- |
714 | -- Has_Rep_Pragma -- | |
715 | -------------------- | |
716 | ||
717 | function Has_Rep_Pragma | |
718 | (E : Entity_Id; | |
719 | Nam : Name_Id; | |
720 | Check_Parents : Boolean := True) return Boolean | |
721 | is | |
722 | begin | |
723 | return Present (Get_Rep_Pragma (E, Nam, Check_Parents)); | |
724 | end Has_Rep_Pragma; | |
725 | ||
99a2d5bd | 726 | function Has_Rep_Pragma |
727 | (E : Entity_Id; | |
728 | Nam1 : Name_Id; | |
729 | Nam2 : Name_Id; | |
730 | Check_Parents : Boolean := True) return Boolean | |
731 | is | |
732 | begin | |
733 | return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); | |
734 | end Has_Rep_Pragma; | |
735 | ||
2fddb086 | 736 | -------------------------------- |
737 | -- Has_Unconstrained_Elements -- | |
738 | -------------------------------- | |
739 | ||
740 | function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is | |
741 | U_T : constant Entity_Id := Underlying_Type (T); | |
742 | begin | |
743 | if No (U_T) then | |
744 | return False; | |
745 | elsif Is_Record_Type (U_T) then | |
746 | return Has_Discriminants (U_T) and then not Is_Constrained (U_T); | |
747 | elsif Is_Array_Type (U_T) then | |
748 | return Has_Unconstrained_Elements (Component_Type (U_T)); | |
749 | else | |
750 | return False; | |
751 | end if; | |
752 | end Has_Unconstrained_Elements; | |
753 | ||
48680a09 | 754 | ---------------------- |
755 | -- Has_Variant_Part -- | |
756 | ---------------------- | |
757 | ||
758 | function Has_Variant_Part (Typ : Entity_Id) return Boolean is | |
759 | FSTyp : Entity_Id; | |
760 | Decl : Node_Id; | |
761 | TDef : Node_Id; | |
762 | CList : Node_Id; | |
763 | ||
764 | begin | |
765 | if not Is_Type (Typ) then | |
766 | return False; | |
767 | end if; | |
768 | ||
769 | FSTyp := First_Subtype (Typ); | |
770 | ||
771 | if not Has_Discriminants (FSTyp) then | |
772 | return False; | |
773 | end if; | |
774 | ||
775 | -- Proceed with cautious checks here, return False if tree is not | |
776 | -- as expected (may be caused by prior errors). | |
777 | ||
778 | Decl := Declaration_Node (FSTyp); | |
779 | ||
780 | if Nkind (Decl) /= N_Full_Type_Declaration then | |
781 | return False; | |
782 | end if; | |
783 | ||
784 | TDef := Type_Definition (Decl); | |
785 | ||
786 | if Nkind (TDef) /= N_Record_Definition then | |
787 | return False; | |
788 | end if; | |
789 | ||
790 | CList := Component_List (TDef); | |
791 | ||
792 | if Nkind (CList) /= N_Component_List then | |
793 | return False; | |
794 | else | |
795 | return Present (Variant_Part (CList)); | |
796 | end if; | |
797 | end Has_Variant_Part; | |
798 | ||
d41a3f41 | 799 | --------------------- |
800 | -- In_Generic_Body -- | |
801 | --------------------- | |
802 | ||
803 | function In_Generic_Body (Id : Entity_Id) return Boolean is | |
804 | S : Entity_Id; | |
805 | ||
806 | begin | |
807 | -- Climb scopes looking for generic body | |
808 | ||
809 | S := Id; | |
810 | while Present (S) and then S /= Standard_Standard loop | |
811 | ||
812 | -- Generic package body | |
813 | ||
814 | if Ekind (S) = E_Generic_Package | |
815 | and then In_Package_Body (S) | |
816 | then | |
817 | return True; | |
818 | ||
819 | -- Generic subprogram body | |
820 | ||
821 | elsif Is_Subprogram (S) | |
822 | and then Nkind (Unit_Declaration_Node (S)) | |
823 | = N_Generic_Subprogram_Declaration | |
824 | then | |
825 | return True; | |
826 | end if; | |
827 | ||
828 | S := Scope (S); | |
829 | end loop; | |
830 | ||
831 | -- False if top of scope stack without finding a generic body | |
832 | ||
833 | return False; | |
834 | end In_Generic_Body; | |
835 | ||
0d78d2d4 | 836 | ------------------------------- |
837 | -- Initialization_Suppressed -- | |
838 | ------------------------------- | |
839 | ||
840 | function Initialization_Suppressed (Typ : Entity_Id) return Boolean is | |
841 | begin | |
842 | return Suppress_Initialization (Typ) | |
843 | or else Suppress_Initialization (Base_Type (Typ)); | |
844 | end Initialization_Suppressed; | |
845 | ||
846 | ---------------- | |
847 | -- Initialize -- | |
848 | ---------------- | |
849 | ||
850 | procedure Initialize is | |
851 | begin | |
852 | Obsolescent_Warnings.Init; | |
853 | end Initialize; | |
854 | ||
985fe5d6 | 855 | ------------- |
856 | -- Is_Body -- | |
857 | ------------- | |
858 | ||
859 | function Is_Body (N : Node_Id) return Boolean is | |
860 | begin | |
861 | return | |
862 | Nkind (N) in N_Body_Stub | |
863 | or else Nkind_In (N, N_Entry_Body, | |
864 | N_Package_Body, | |
865 | N_Protected_Body, | |
866 | N_Subprogram_Body, | |
867 | N_Task_Body); | |
868 | end Is_Body; | |
869 | ||
d60c9ff7 | 870 | --------------------- |
871 | -- Is_By_Copy_Type -- | |
872 | --------------------- | |
873 | ||
874 | function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is | |
875 | begin | |
876 | -- If Id is a private type whose full declaration has not been seen, | |
877 | -- we assume for now that it is not a By_Copy type. Clearly this | |
878 | -- attribute should not be used before the type is frozen, but it is | |
879 | -- needed to build the associated record of a protected type. Another | |
880 | -- place where some lookahead for a full view is needed ??? | |
881 | ||
882 | return | |
883 | Is_Elementary_Type (Ent) | |
884 | or else (Is_Private_Type (Ent) | |
885 | and then Present (Underlying_Type (Ent)) | |
886 | and then Is_Elementary_Type (Underlying_Type (Ent))); | |
887 | end Is_By_Copy_Type; | |
888 | ||
889 | -------------------------- | |
890 | -- Is_By_Reference_Type -- | |
891 | -------------------------- | |
892 | ||
893 | function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is | |
894 | Btype : constant Entity_Id := Base_Type (Ent); | |
895 | ||
896 | begin | |
43ec7501 | 897 | if Error_Posted (Ent) or else Error_Posted (Btype) then |
d60c9ff7 | 898 | return False; |
899 | ||
900 | elsif Is_Private_Type (Btype) then | |
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_By_Reference_Type (Utyp); | |
908 | end if; | |
909 | end; | |
910 | ||
911 | elsif Is_Incomplete_Type (Btype) then | |
912 | declare | |
913 | Ftyp : constant Entity_Id := Full_View (Btype); | |
914 | begin | |
915 | if No (Ftyp) then | |
916 | return False; | |
917 | else | |
918 | return Is_By_Reference_Type (Ftyp); | |
919 | end if; | |
920 | end; | |
921 | ||
922 | elsif Is_Concurrent_Type (Btype) then | |
923 | return True; | |
924 | ||
925 | elsif Is_Record_Type (Btype) then | |
926 | if Is_Limited_Record (Btype) | |
927 | or else Is_Tagged_Type (Btype) | |
928 | or else Is_Volatile (Btype) | |
929 | then | |
930 | return True; | |
931 | ||
932 | else | |
933 | declare | |
934 | C : Entity_Id; | |
935 | ||
936 | begin | |
937 | C := First_Component (Btype); | |
938 | while Present (C) loop | |
d6ebb821 | 939 | |
940 | -- For each component, test if its type is a by reference | |
941 | -- type and if its type is volatile. Also test the component | |
942 | -- itself for being volatile. This happens for example when | |
943 | -- a Volatile aspect is added to a component. | |
944 | ||
d60c9ff7 | 945 | if Is_By_Reference_Type (Etype (C)) |
946 | or else Is_Volatile (Etype (C)) | |
d6ebb821 | 947 | or else Is_Volatile (C) |
d60c9ff7 | 948 | then |
949 | return True; | |
950 | end if; | |
951 | ||
952 | C := Next_Component (C); | |
953 | end loop; | |
954 | end; | |
955 | ||
956 | return False; | |
957 | end if; | |
958 | ||
959 | elsif Is_Array_Type (Btype) then | |
960 | return | |
961 | Is_Volatile (Btype) | |
962 | or else Is_By_Reference_Type (Component_Type (Btype)) | |
963 | or else Is_Volatile (Component_Type (Btype)) | |
964 | or else Has_Volatile_Components (Btype); | |
965 | ||
966 | else | |
967 | return False; | |
968 | end if; | |
969 | end Is_By_Reference_Type; | |
970 | ||
895fed95 | 971 | ------------------------- |
23225afb | 972 | -- Is_Definite_Subtype -- |
895fed95 | 973 | ------------------------- |
23225afb | 974 | |
975 | function Is_Definite_Subtype (T : Entity_Id) return Boolean is | |
976 | pragma Assert (Is_Type (T)); | |
977 | K : constant Entity_Kind := Ekind (T); | |
978 | ||
979 | begin | |
980 | if Is_Constrained (T) then | |
981 | return True; | |
982 | ||
983 | elsif K in Array_Kind | |
984 | or else K in Class_Wide_Kind | |
985 | or else Has_Unknown_Discriminants (T) | |
986 | then | |
987 | return False; | |
988 | ||
989 | -- Known discriminants: definite if there are default values. Note that | |
990 | -- if any discriminant has a default, they all do. | |
991 | ||
992 | elsif Has_Discriminants (T) then | |
6287ef56 | 993 | return Present (Discriminant_Default_Value (First_Discriminant (T))); |
23225afb | 994 | |
995 | else | |
996 | return True; | |
997 | end if; | |
998 | end Is_Definite_Subtype; | |
999 | ||
d60c9ff7 | 1000 | --------------------- |
1001 | -- Is_Derived_Type -- | |
1002 | --------------------- | |
1003 | ||
1004 | function Is_Derived_Type (Ent : E) return B is | |
1005 | Par : Node_Id; | |
1006 | ||
1007 | begin | |
1008 | if Is_Type (Ent) | |
1009 | and then Base_Type (Ent) /= Root_Type (Ent) | |
1010 | and then not Is_Class_Wide_Type (Ent) | |
4beb22df | 1011 | |
1012 | -- An access_to_subprogram whose result type is a limited view can | |
1013 | -- appear in a return statement, without the full view of the result | |
1014 | -- type being available. Do not interpret this as a derived type. | |
1015 | ||
8149276d | 1016 | and then Ekind (Ent) /= E_Subprogram_Type |
d60c9ff7 | 1017 | then |
1018 | if not Is_Numeric_Type (Root_Type (Ent)) then | |
1019 | return True; | |
1020 | ||
1021 | else | |
1022 | Par := Parent (First_Subtype (Ent)); | |
1023 | ||
1024 | return Present (Par) | |
1025 | and then Nkind (Par) = N_Full_Type_Declaration | |
1026 | and then Nkind (Type_Definition (Par)) = | |
1027 | N_Derived_Type_Definition; | |
1028 | end if; | |
1029 | ||
1030 | else | |
1031 | return False; | |
1032 | end if; | |
1033 | end Is_Derived_Type; | |
1034 | ||
f37e6e70 | 1035 | ----------------------- |
1036 | -- Is_Generic_Formal -- | |
1037 | ----------------------- | |
1038 | ||
1039 | function Is_Generic_Formal (E : Entity_Id) return Boolean is | |
1040 | Kind : Node_Kind; | |
1041 | begin | |
1042 | if No (E) then | |
1043 | return False; | |
1044 | else | |
1045 | Kind := Nkind (Parent (E)); | |
1046 | return | |
1047 | Nkind_In (Kind, N_Formal_Object_Declaration, | |
1048 | N_Formal_Package_Declaration, | |
1049 | N_Formal_Type_Declaration) | |
1050 | or else Is_Formal_Subprogram (E); | |
1051 | end if; | |
1052 | end Is_Generic_Formal; | |
1053 | ||
d7e97115 | 1054 | ------------------------------- |
1055 | -- Is_Immutably_Limited_Type -- | |
1056 | ------------------------------- | |
1057 | ||
1058 | function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is | |
1059 | Btype : constant Entity_Id := Available_View (Base_Type (Ent)); | |
1060 | ||
1061 | begin | |
1062 | if Is_Limited_Record (Btype) then | |
1063 | return True; | |
1064 | ||
1065 | elsif Ekind (Btype) = E_Limited_Private_Type | |
1066 | and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration | |
1067 | then | |
1068 | return not In_Package_Body (Scope ((Btype))); | |
1069 | ||
1070 | elsif Is_Private_Type (Btype) then | |
1071 | ||
1072 | -- AI05-0063: A type derived from a limited private formal type is | |
1073 | -- not immutably limited in a generic body. | |
1074 | ||
1075 | if Is_Derived_Type (Btype) | |
1076 | and then Is_Generic_Type (Etype (Btype)) | |
1077 | then | |
1078 | if not Is_Limited_Type (Etype (Btype)) then | |
1079 | return False; | |
1080 | ||
1081 | -- A descendant of a limited formal type is not immutably limited | |
1082 | -- in the generic body, or in the body of a generic child. | |
1083 | ||
1084 | elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then | |
1085 | return not In_Package_Body (Scope (Btype)); | |
1086 | ||
1087 | else | |
1088 | return False; | |
1089 | end if; | |
1090 | ||
1091 | else | |
1092 | declare | |
1093 | Utyp : constant Entity_Id := Underlying_Type (Btype); | |
1094 | begin | |
1095 | if No (Utyp) then | |
1096 | return False; | |
1097 | else | |
1098 | return Is_Immutably_Limited_Type (Utyp); | |
1099 | end if; | |
1100 | end; | |
1101 | end if; | |
1102 | ||
1103 | elsif Is_Concurrent_Type (Btype) then | |
1104 | return True; | |
d60c9ff7 | 1105 | |
1106 | else | |
1107 | return False; | |
1108 | end if; | |
172f8d3a | 1109 | end Is_Immutably_Limited_Type; |
d60c9ff7 | 1110 | |
1111 | --------------------- | |
1112 | -- Is_Limited_Type -- | |
1113 | --------------------- | |
1114 | ||
1115 | function Is_Limited_Type (Ent : Entity_Id) return Boolean is | |
1116 | Btype : constant E := Base_Type (Ent); | |
1117 | Rtype : constant E := Root_Type (Btype); | |
1118 | ||
1119 | begin | |
1120 | if not Is_Type (Ent) then | |
1121 | return False; | |
1122 | ||
1123 | elsif Ekind (Btype) = E_Limited_Private_Type | |
1124 | or else Is_Limited_Composite (Btype) | |
1125 | then | |
1126 | return True; | |
1127 | ||
1128 | elsif Is_Concurrent_Type (Btype) then | |
1129 | return True; | |
1130 | ||
1131 | -- The Is_Limited_Record flag normally indicates that the type is | |
1132 | -- limited. The exception is that a type does not inherit limitedness | |
1133 | -- from its interface ancestor. So the type may be derived from a | |
1134 | -- limited interface, but is not limited. | |
1135 | ||
1136 | elsif Is_Limited_Record (Ent) | |
1137 | and then not Is_Interface (Ent) | |
1138 | then | |
1139 | return True; | |
1140 | ||
1141 | -- Otherwise we will look around to see if there is some other reason | |
1142 | -- for it to be limited, except that if an error was posted on the | |
1143 | -- entity, then just assume it is non-limited, because it can cause | |
2625eb01 | 1144 | -- trouble to recurse into a murky entity resulting from other errors. |
d60c9ff7 | 1145 | |
1146 | elsif Error_Posted (Ent) then | |
1147 | return False; | |
1148 | ||
1149 | elsif Is_Record_Type (Btype) then | |
1150 | ||
1151 | if Is_Limited_Interface (Ent) then | |
1152 | return True; | |
1153 | ||
1154 | -- AI-419: limitedness is not inherited from a limited interface | |
1155 | ||
1156 | elsif Is_Limited_Record (Rtype) then | |
1157 | return not Is_Interface (Rtype) | |
1158 | or else Is_Protected_Interface (Rtype) | |
1159 | or else Is_Synchronized_Interface (Rtype) | |
1160 | or else Is_Task_Interface (Rtype); | |
1161 | ||
1162 | elsif Is_Class_Wide_Type (Btype) then | |
1163 | return Is_Limited_Type (Rtype); | |
1164 | ||
1165 | else | |
1166 | declare | |
1167 | C : E; | |
1168 | ||
1169 | begin | |
1170 | C := First_Component (Btype); | |
1171 | while Present (C) loop | |
1172 | if Is_Limited_Type (Etype (C)) then | |
1173 | return True; | |
1174 | end if; | |
1175 | ||
1176 | C := Next_Component (C); | |
1177 | end loop; | |
1178 | end; | |
1179 | ||
1180 | return False; | |
1181 | end if; | |
1182 | ||
1183 | elsif Is_Array_Type (Btype) then | |
1184 | return Is_Limited_Type (Component_Type (Btype)); | |
1185 | ||
1186 | else | |
1187 | return False; | |
1188 | end if; | |
1189 | end Is_Limited_Type; | |
1190 | ||
cb85a53b | 1191 | --------------------- |
1192 | -- Is_Limited_View -- | |
1193 | --------------------- | |
1194 | ||
1195 | function Is_Limited_View (Ent : Entity_Id) return Boolean is | |
1196 | Btype : constant Entity_Id := Available_View (Base_Type (Ent)); | |
1197 | ||
1198 | begin | |
1199 | if Is_Limited_Record (Btype) then | |
1200 | return True; | |
1201 | ||
1202 | elsif Ekind (Btype) = E_Limited_Private_Type | |
1203 | and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration | |
1204 | then | |
1205 | return not In_Package_Body (Scope ((Btype))); | |
1206 | ||
1207 | elsif Is_Private_Type (Btype) then | |
1208 | ||
1209 | -- AI05-0063: A type derived from a limited private formal type is | |
1210 | -- not immutably limited in a generic body. | |
1211 | ||
1212 | if Is_Derived_Type (Btype) | |
1213 | and then Is_Generic_Type (Etype (Btype)) | |
1214 | then | |
1215 | if not Is_Limited_Type (Etype (Btype)) then | |
1216 | return False; | |
1217 | ||
1218 | -- A descendant of a limited formal type is not immutably limited | |
1219 | -- in the generic body, or in the body of a generic child. | |
1220 | ||
1221 | elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then | |
1222 | return not In_Package_Body (Scope (Btype)); | |
1223 | ||
1224 | else | |
1225 | return False; | |
1226 | end if; | |
1227 | ||
1228 | else | |
1229 | declare | |
1230 | Utyp : constant Entity_Id := Underlying_Type (Btype); | |
1231 | begin | |
1232 | if No (Utyp) then | |
1233 | return False; | |
1234 | else | |
1235 | return Is_Limited_View (Utyp); | |
1236 | end if; | |
1237 | end; | |
1238 | end if; | |
1239 | ||
1240 | elsif Is_Concurrent_Type (Btype) then | |
1241 | return True; | |
1242 | ||
1243 | elsif Is_Record_Type (Btype) then | |
1244 | ||
1245 | -- Note that we return True for all limited interfaces, even though | |
1246 | -- (unsynchronized) limited interfaces can have descendants that are | |
1247 | -- nonlimited, because this is a predicate on the type itself, and | |
1248 | -- things like functions with limited interface results need to be | |
1249 | -- handled as build in place even though they might return objects | |
1250 | -- of a type that is not inherently limited. | |
1251 | ||
1252 | if Is_Class_Wide_Type (Btype) then | |
1253 | return Is_Limited_View (Root_Type (Btype)); | |
1254 | ||
1255 | else | |
1256 | declare | |
1257 | C : Entity_Id; | |
1258 | ||
1259 | begin | |
1260 | C := First_Component (Btype); | |
1261 | while Present (C) loop | |
1262 | ||
1263 | -- Don't consider components with interface types (which can | |
1264 | -- only occur in the case of a _parent component anyway). | |
1265 | -- They don't have any components, plus it would cause this | |
1266 | -- function to return true for nonlimited types derived from | |
1267 | -- limited interfaces. | |
1268 | ||
1269 | if not Is_Interface (Etype (C)) | |
1270 | and then Is_Limited_View (Etype (C)) | |
1271 | then | |
1272 | return True; | |
1273 | end if; | |
1274 | ||
1275 | C := Next_Component (C); | |
1276 | end loop; | |
1277 | end; | |
1278 | ||
1279 | return False; | |
1280 | end if; | |
1281 | ||
1282 | elsif Is_Array_Type (Btype) then | |
1283 | return Is_Limited_View (Component_Type (Btype)); | |
1284 | ||
1285 | else | |
1286 | return False; | |
1287 | end if; | |
1288 | end Is_Limited_View; | |
1289 | ||
701d57a4 | 1290 | ---------------------- |
1291 | -- Nearest_Ancestor -- | |
1292 | ---------------------- | |
1293 | ||
1294 | function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is | |
89b3b365 | 1295 | D : constant Node_Id := Declaration_Node (Typ); |
701d57a4 | 1296 | |
1297 | begin | |
1298 | -- If we have a subtype declaration, get the ancestor subtype | |
1299 | ||
1300 | if Nkind (D) = N_Subtype_Declaration then | |
1301 | if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then | |
1302 | return Entity (Subtype_Mark (Subtype_Indication (D))); | |
1303 | else | |
1304 | return Entity (Subtype_Indication (D)); | |
1305 | end if; | |
1306 | ||
1307 | -- If derived type declaration, find who we are derived from | |
1308 | ||
1309 | elsif Nkind (D) = N_Full_Type_Declaration | |
1310 | and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition | |
1311 | then | |
1312 | declare | |
1313 | DTD : constant Entity_Id := Type_Definition (D); | |
1314 | SI : constant Entity_Id := Subtype_Indication (DTD); | |
1315 | begin | |
1316 | if Is_Entity_Name (SI) then | |
1317 | return Entity (SI); | |
1318 | else | |
1319 | return Entity (Subtype_Mark (SI)); | |
1320 | end if; | |
1321 | end; | |
1322 | ||
89f1e35c | 1323 | -- If derived type and private type, get the full view to find who we |
1324 | -- are derived from. | |
1325 | ||
1326 | elsif Is_Derived_Type (Typ) | |
1327 | and then Is_Private_Type (Typ) | |
1328 | and then Present (Full_View (Typ)) | |
1329 | then | |
1330 | return Nearest_Ancestor (Full_View (Typ)); | |
1331 | ||
701d57a4 | 1332 | -- Otherwise, nothing useful to return, return Empty |
1333 | ||
1334 | else | |
1335 | return Empty; | |
1336 | end if; | |
1337 | end Nearest_Ancestor; | |
1338 | ||
1971b754 | 1339 | --------------------------- |
1340 | -- Nearest_Dynamic_Scope -- | |
1341 | --------------------------- | |
1342 | ||
1343 | function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is | |
1344 | begin | |
1345 | if Is_Dynamic_Scope (Ent) then | |
1346 | return Ent; | |
1347 | else | |
1348 | return Enclosing_Dynamic_Scope (Ent); | |
1349 | end if; | |
1350 | end Nearest_Dynamic_Scope; | |
1351 | ||
d60c9ff7 | 1352 | ------------------------ |
1353 | -- Next_Tag_Component -- | |
1354 | ------------------------ | |
1355 | ||
1356 | function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is | |
1357 | Comp : Entity_Id; | |
1358 | ||
1359 | begin | |
1360 | pragma Assert (Is_Tag (Tag)); | |
1361 | ||
4d1f0a53 | 1362 | -- Loop to look for next tag component |
1363 | ||
d60c9ff7 | 1364 | Comp := Next_Entity (Tag); |
1365 | while Present (Comp) loop | |
1366 | if Is_Tag (Comp) then | |
1367 | pragma Assert (Chars (Comp) /= Name_uTag); | |
1368 | return Comp; | |
1369 | end if; | |
1370 | ||
1371 | Comp := Next_Entity (Comp); | |
1372 | end loop; | |
1373 | ||
1374 | -- No tag component found | |
1375 | ||
1376 | return Empty; | |
1377 | end Next_Tag_Component; | |
1378 | ||
c143b3d7 | 1379 | ----------------------- |
1380 | -- Number_Components -- | |
1381 | ----------------------- | |
1382 | ||
1383 | function Number_Components (Typ : Entity_Id) return Pos is | |
1384 | N : Int; | |
1385 | Comp : Entity_Id; | |
1386 | ||
1387 | begin | |
1388 | N := 0; | |
1389 | ||
1390 | -- We do not call Einfo.First_Component_Or_Discriminant, as this | |
1391 | -- function does not skip completely hidden discriminants, which we | |
1392 | -- want to skip here. | |
1393 | ||
1394 | if Has_Discriminants (Typ) then | |
1395 | Comp := First_Discriminant (Typ); | |
1396 | else | |
1397 | Comp := First_Component (Typ); | |
1398 | end if; | |
1399 | ||
1400 | while Present (Comp) loop | |
1401 | N := N + 1; | |
1402 | Comp := Next_Component_Or_Discriminant (Comp); | |
1403 | end loop; | |
1404 | ||
1405 | return N; | |
1406 | end Number_Components; | |
1407 | ||
d60c9ff7 | 1408 | -------------------------- |
1409 | -- Number_Discriminants -- | |
1410 | -------------------------- | |
1411 | ||
1412 | function Number_Discriminants (Typ : Entity_Id) return Pos is | |
1413 | N : Int; | |
1414 | Discr : Entity_Id; | |
1415 | ||
1416 | begin | |
1417 | N := 0; | |
1418 | Discr := First_Discriminant (Typ); | |
1419 | while Present (Discr) loop | |
1420 | N := N + 1; | |
1421 | Discr := Next_Discriminant (Discr); | |
1422 | end loop; | |
1423 | ||
1424 | return N; | |
1425 | end Number_Discriminants; | |
1426 | ||
0d78d2d4 | 1427 | ---------------------------------------------- |
1428 | -- Object_Type_Has_Constrained_Partial_View -- | |
1429 | ---------------------------------------------- | |
1430 | ||
1431 | function Object_Type_Has_Constrained_Partial_View | |
1432 | (Typ : Entity_Id; | |
1433 | Scop : Entity_Id) return Boolean | |
1434 | is | |
1435 | begin | |
1436 | return Has_Constrained_Partial_View (Typ) | |
1437 | or else (In_Generic_Body (Scop) | |
1438 | and then Is_Generic_Type (Base_Type (Typ)) | |
1439 | and then Is_Private_Type (Base_Type (Typ)) | |
1440 | and then not Is_Tagged_Type (Typ) | |
1441 | and then not (Is_Array_Type (Typ) | |
1442 | and then not Is_Constrained (Typ)) | |
1443 | and then Has_Discriminants (Typ)); | |
1444 | end Object_Type_Has_Constrained_Partial_View; | |
1445 | ||
895fed95 | 1446 | ------------------ |
1447 | -- Package_Body -- | |
1448 | ------------------ | |
1449 | ||
1450 | function Package_Body (E : Entity_Id) return Node_Id is | |
1451 | N : Node_Id; | |
1452 | ||
1453 | begin | |
1454 | if Ekind (E) = E_Package_Body then | |
1455 | N := Parent (E); | |
1456 | ||
1457 | if Nkind (N) = N_Defining_Program_Unit_Name then | |
1458 | N := Parent (N); | |
1459 | end if; | |
1460 | ||
1461 | else | |
1462 | N := Package_Spec (E); | |
1463 | ||
1464 | if Present (Corresponding_Body (N)) then | |
1465 | N := Parent (Corresponding_Body (N)); | |
1466 | ||
1467 | if Nkind (N) = N_Defining_Program_Unit_Name then | |
1468 | N := Parent (N); | |
1469 | end if; | |
1470 | else | |
1471 | N := Empty; | |
1472 | end if; | |
1473 | end if; | |
1474 | ||
1475 | return N; | |
1476 | end Package_Body; | |
1477 | ||
1478 | ------------------ | |
1479 | -- Package_Spec -- | |
1480 | ------------------ | |
1481 | ||
1482 | function Package_Spec (E : Entity_Id) return Node_Id is | |
1483 | begin | |
1484 | return Parent (Package_Specification (E)); | |
1485 | end Package_Spec; | |
1486 | ||
e8b4793a | 1487 | --------------------------- |
1488 | -- Package_Specification -- | |
1489 | --------------------------- | |
1490 | ||
895fed95 | 1491 | function Package_Specification (E : Entity_Id) return Node_Id is |
e8b4793a | 1492 | N : Node_Id; |
1493 | ||
1494 | begin | |
895fed95 | 1495 | N := Parent (E); |
e8b4793a | 1496 | |
895fed95 | 1497 | if Nkind (N) = N_Defining_Program_Unit_Name then |
1498 | N := Parent (N); | |
1499 | end if; | |
e8b4793a | 1500 | |
1501 | return N; | |
1502 | end Package_Specification; | |
1503 | ||
c143b3d7 | 1504 | --------------------- |
1505 | -- Subprogram_Body -- | |
1506 | --------------------- | |
1507 | ||
1508 | function Subprogram_Body (E : Entity_Id) return Node_Id is | |
1509 | Body_E : constant Entity_Id := Subprogram_Body_Entity (E); | |
1510 | ||
1511 | begin | |
1512 | if No (Body_E) then | |
1513 | return Empty; | |
1514 | else | |
1515 | return Parent (Subprogram_Specification (Body_E)); | |
1516 | end if; | |
1517 | end Subprogram_Body; | |
1518 | ||
1519 | ---------------------------- | |
1520 | -- Subprogram_Body_Entity -- | |
1521 | ---------------------------- | |
1522 | ||
1523 | function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is | |
1524 | N : Node_Id; | |
1525 | ||
1526 | begin | |
1527 | -- Retrieve the declaration for E | |
1528 | ||
1529 | N := Parent (Subprogram_Specification (E)); | |
1530 | ||
1531 | -- If this declaration is not a subprogram body, then it must be a | |
8d8194a6 | 1532 | -- subprogram declaration or body stub, from which we can retrieve the |
1533 | -- entity for the corresponding subprogram body if any, or an abstract | |
1534 | -- subprogram declaration, for which we return Empty. | |
c143b3d7 | 1535 | |
895fed95 | 1536 | case Nkind (N) is |
1537 | when N_Subprogram_Body => | |
1538 | return E; | |
1539 | ||
8d8194a6 | 1540 | when N_Subprogram_Declaration | N_Subprogram_Body_Stub => |
895fed95 | 1541 | return Corresponding_Body (N); |
1542 | ||
1543 | when others => | |
1544 | return Empty; | |
1545 | end case; | |
c143b3d7 | 1546 | end Subprogram_Body_Entity; |
1547 | ||
1548 | --------------------- | |
1549 | -- Subprogram_Spec -- | |
1550 | --------------------- | |
1551 | ||
1552 | function Subprogram_Spec (E : Entity_Id) return Node_Id is | |
1553 | N : Node_Id; | |
1554 | ||
1555 | begin | |
1556 | -- Retrieve the declaration for E | |
1557 | ||
1558 | N := Parent (Subprogram_Specification (E)); | |
1559 | ||
1560 | -- This declaration is either subprogram declaration or a subprogram | |
1561 | -- body, in which case return Empty. | |
1562 | ||
1563 | if Nkind (N) = N_Subprogram_Declaration then | |
1564 | return N; | |
1565 | else | |
1566 | return Empty; | |
1567 | end if; | |
1568 | end Subprogram_Spec; | |
1569 | ||
1570 | ------------------------------ | |
1571 | -- Subprogram_Specification -- | |
1572 | ------------------------------ | |
1573 | ||
1574 | function Subprogram_Specification (E : Entity_Id) return Node_Id is | |
1575 | N : Node_Id; | |
1576 | ||
1577 | begin | |
1578 | N := Parent (E); | |
1579 | ||
1580 | if Nkind (N) = N_Defining_Program_Unit_Name then | |
1581 | N := Parent (N); | |
1582 | end if; | |
1583 | ||
1584 | -- If the Parent pointer of E is not a subprogram specification node | |
1585 | -- (going through an intermediate N_Defining_Program_Unit_Name node | |
1586 | -- for subprogram units), then E is an inherited operation. Its parent | |
1587 | -- points to the type derivation that produces the inheritance: that's | |
1588 | -- the node that generates the subprogram specification. Its alias | |
1589 | -- is the parent subprogram, and that one points to a subprogram | |
1590 | -- declaration, or to another type declaration if this is a hierarchy | |
1591 | -- of derivations. | |
1592 | ||
1593 | if Nkind (N) not in N_Subprogram_Specification then | |
1594 | pragma Assert (Present (Alias (E))); | |
1595 | N := Subprogram_Specification (Alias (E)); | |
1596 | end if; | |
1597 | ||
1598 | return N; | |
1599 | end Subprogram_Specification; | |
1600 | ||
d55c93e0 | 1601 | --------------- |
1602 | -- Tree_Read -- | |
1603 | --------------- | |
1604 | ||
1605 | procedure Tree_Read is | |
1606 | begin | |
1607 | Obsolescent_Warnings.Tree_Read; | |
1608 | end Tree_Read; | |
1609 | ||
1610 | ---------------- | |
1611 | -- Tree_Write -- | |
1612 | ---------------- | |
1613 | ||
1614 | procedure Tree_Write is | |
1615 | begin | |
1616 | Obsolescent_Warnings.Tree_Write; | |
1617 | end Tree_Write; | |
1618 | ||
64988bb0 | 1619 | -------------------- |
1620 | -- Ultimate_Alias -- | |
1621 | -------------------- | |
1622 | ||
1623 | function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is | |
1624 | E : Entity_Id := Prim; | |
1625 | ||
1626 | begin | |
1627 | while Present (Alias (E)) loop | |
1628 | pragma Assert (Alias (E) /= E); | |
1629 | E := Alias (E); | |
1630 | end loop; | |
1631 | ||
1632 | return E; | |
1633 | end Ultimate_Alias; | |
1634 | ||
d41a3f41 | 1635 | -------------------------- |
1636 | -- Unit_Declaration_Node -- | |
1637 | -------------------------- | |
1638 | ||
1639 | function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is | |
1640 | N : Node_Id := Parent (Unit_Id); | |
1641 | ||
1642 | begin | |
1643 | -- Predefined operators do not have a full function declaration | |
1644 | ||
1645 | if Ekind (Unit_Id) = E_Operator then | |
1646 | return N; | |
1647 | end if; | |
1648 | ||
1649 | -- Isn't there some better way to express the following ??? | |
1650 | ||
1651 | while Nkind (N) /= N_Abstract_Subprogram_Declaration | |
1652 | and then Nkind (N) /= N_Formal_Package_Declaration | |
1653 | and then Nkind (N) /= N_Function_Instantiation | |
1654 | and then Nkind (N) /= N_Generic_Package_Declaration | |
1655 | and then Nkind (N) /= N_Generic_Subprogram_Declaration | |
1656 | and then Nkind (N) /= N_Package_Declaration | |
1657 | and then Nkind (N) /= N_Package_Body | |
1658 | and then Nkind (N) /= N_Package_Instantiation | |
1659 | and then Nkind (N) /= N_Package_Renaming_Declaration | |
1660 | and then Nkind (N) /= N_Procedure_Instantiation | |
1661 | and then Nkind (N) /= N_Protected_Body | |
1662 | and then Nkind (N) /= N_Subprogram_Declaration | |
1663 | and then Nkind (N) /= N_Subprogram_Body | |
1664 | and then Nkind (N) /= N_Subprogram_Body_Stub | |
1665 | and then Nkind (N) /= N_Subprogram_Renaming_Declaration | |
1666 | and then Nkind (N) /= N_Task_Body | |
1667 | and then Nkind (N) /= N_Task_Type_Declaration | |
1668 | and then Nkind (N) not in N_Formal_Subprogram_Declaration | |
1669 | and then Nkind (N) not in N_Generic_Renaming_Declaration | |
1670 | loop | |
1671 | N := Parent (N); | |
1672 | ||
1673 | -- We don't use Assert here, because that causes an infinite loop | |
1674 | -- when assertions are turned off. Better to crash. | |
1675 | ||
1676 | if No (N) then | |
1677 | raise Program_Error; | |
1678 | end if; | |
1679 | end loop; | |
1680 | ||
1681 | return N; | |
1682 | end Unit_Declaration_Node; | |
1683 | ||
d55c93e0 | 1684 | end Sem_Aux; |