]>
Commit | Line | Data |
---|---|---|
76f9c7f4 BD |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E I N F O . U T I L S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
9 | -- Copyright (C) 2020-2021, Free Software Foundation, Inc. -- | |
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 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
23 | -- -- | |
24 | ------------------------------------------------------------------------------ | |
25 | ||
104f58db BD |
26 | with Atree; use Atree; |
27 | with Elists; use Elists; | |
28 | with Nlists; use Nlists; | |
29 | with Output; use Output; | |
30 | with Sinfo; use Sinfo; | |
31 | with Sinfo.Nodes; use Sinfo.Nodes; | |
32 | with Sinfo.Utils; use Sinfo.Utils; | |
76f9c7f4 BD |
33 | |
34 | package body Einfo.Utils is | |
35 | ||
36 | ----------------------- | |
37 | -- Local subprograms -- | |
38 | ----------------------- | |
39 | ||
40 | function Has_Option | |
41 | (State_Id : Entity_Id; | |
42 | Option_Nam : Name_Id) return Boolean; | |
43 | -- Determine whether abstract state State_Id has particular option denoted | |
44 | -- by the name Option_Nam. | |
45 | ||
a7cadd18 BD |
46 | ----------------------------------- |
47 | -- Renamings of Renamed_Or_Alias -- | |
48 | ----------------------------------- | |
49 | ||
50 | function Alias (N : Entity_Id) return Node_Id is | |
51 | begin | |
52 | pragma Assert | |
53 | (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type); | |
54 | return Renamed_Or_Alias (N); | |
55 | end Alias; | |
56 | ||
57 | procedure Set_Alias (N : Entity_Id; Val : Node_Id) is | |
58 | begin | |
59 | pragma Assert | |
60 | (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type); | |
61 | Set_Renamed_Or_Alias (N, Val); | |
62 | end Set_Alias; | |
63 | ||
76f9c7f4 BD |
64 | ---------------- |
65 | -- Has_Option -- | |
66 | ---------------- | |
67 | ||
68 | function Has_Option | |
69 | (State_Id : Entity_Id; | |
70 | Option_Nam : Name_Id) return Boolean | |
71 | is | |
72 | Decl : constant Node_Id := Parent (State_Id); | |
73 | Opt : Node_Id; | |
74 | Opt_Nam : Node_Id; | |
75 | ||
76 | begin | |
77 | pragma Assert (Ekind (State_Id) = E_Abstract_State); | |
78 | ||
79 | -- The declaration of abstract states with options appear as an | |
80 | -- extension aggregate. If this is not the case, the option is not | |
81 | -- available. | |
82 | ||
83 | if Nkind (Decl) /= N_Extension_Aggregate then | |
84 | return False; | |
85 | end if; | |
86 | ||
87 | -- Simple options | |
88 | ||
89 | Opt := First (Expressions (Decl)); | |
90 | while Present (Opt) loop | |
91 | if Nkind (Opt) = N_Identifier and then Chars (Opt) = Option_Nam then | |
92 | return True; | |
93 | end if; | |
94 | ||
95 | Next (Opt); | |
96 | end loop; | |
97 | ||
98 | -- Complex options with various specifiers | |
99 | ||
100 | Opt := First (Component_Associations (Decl)); | |
101 | while Present (Opt) loop | |
102 | Opt_Nam := First (Choices (Opt)); | |
103 | ||
104 | if Nkind (Opt_Nam) = N_Identifier | |
105 | and then Chars (Opt_Nam) = Option_Nam | |
106 | then | |
107 | return True; | |
108 | end if; | |
109 | ||
110 | Next (Opt); | |
111 | end loop; | |
112 | ||
113 | return False; | |
114 | end Has_Option; | |
115 | ||
116 | ------------------------------ | |
117 | -- Classification Functions -- | |
118 | ------------------------------ | |
119 | ||
120 | function Is_Access_Object_Type (Id : E) return B is | |
121 | begin | |
a4613d9a PT |
122 | return Is_Access_Type (Id) |
123 | and then Ekind (Directly_Designated_Type (Id)) /= E_Subprogram_Type; | |
76f9c7f4 BD |
124 | end Is_Access_Object_Type; |
125 | ||
126 | function Is_Access_Type (Id : E) return B is | |
127 | begin | |
128 | return Ekind (Id) in Access_Kind; | |
129 | end Is_Access_Type; | |
130 | ||
131 | function Is_Access_Protected_Subprogram_Type (Id : E) return B is | |
132 | begin | |
133 | return Ekind (Id) in Access_Protected_Kind; | |
134 | end Is_Access_Protected_Subprogram_Type; | |
135 | ||
136 | function Is_Access_Subprogram_Type (Id : E) return B is | |
137 | begin | |
a4613d9a PT |
138 | return Is_Access_Type (Id) |
139 | and then Ekind (Directly_Designated_Type (Id)) = E_Subprogram_Type; | |
76f9c7f4 BD |
140 | end Is_Access_Subprogram_Type; |
141 | ||
142 | function Is_Aggregate_Type (Id : E) return B is | |
143 | begin | |
144 | return Ekind (Id) in Aggregate_Kind; | |
145 | end Is_Aggregate_Type; | |
146 | ||
147 | function Is_Anonymous_Access_Type (Id : E) return B is | |
148 | begin | |
149 | return Ekind (Id) in Anonymous_Access_Kind; | |
150 | end Is_Anonymous_Access_Type; | |
151 | ||
152 | function Is_Array_Type (Id : E) return B is | |
153 | begin | |
154 | return Ekind (Id) in Array_Kind; | |
155 | end Is_Array_Type; | |
156 | ||
157 | function Is_Assignable (Id : E) return B is | |
158 | begin | |
159 | return Ekind (Id) in Assignable_Kind; | |
160 | end Is_Assignable; | |
161 | ||
162 | function Is_Class_Wide_Type (Id : E) return B is | |
163 | begin | |
164 | return Ekind (Id) in Class_Wide_Kind; | |
165 | end Is_Class_Wide_Type; | |
166 | ||
167 | function Is_Composite_Type (Id : E) return B is | |
168 | begin | |
169 | return Ekind (Id) in Composite_Kind; | |
170 | end Is_Composite_Type; | |
171 | ||
172 | function Is_Concurrent_Body (Id : E) return B is | |
173 | begin | |
174 | return Ekind (Id) in Concurrent_Body_Kind; | |
175 | end Is_Concurrent_Body; | |
176 | ||
177 | function Is_Concurrent_Type (Id : E) return B is | |
178 | begin | |
179 | return Ekind (Id) in Concurrent_Kind; | |
180 | end Is_Concurrent_Type; | |
181 | ||
182 | function Is_Decimal_Fixed_Point_Type (Id : E) return B is | |
183 | begin | |
184 | return Ekind (Id) in Decimal_Fixed_Point_Kind; | |
185 | end Is_Decimal_Fixed_Point_Type; | |
186 | ||
187 | function Is_Digits_Type (Id : E) return B is | |
188 | begin | |
189 | return Ekind (Id) in Digits_Kind; | |
190 | end Is_Digits_Type; | |
191 | ||
192 | function Is_Discrete_Or_Fixed_Point_Type (Id : E) return B is | |
193 | begin | |
194 | return Ekind (Id) in Discrete_Or_Fixed_Point_Kind; | |
195 | end Is_Discrete_Or_Fixed_Point_Type; | |
196 | ||
197 | function Is_Discrete_Type (Id : E) return B is | |
198 | begin | |
199 | return Ekind (Id) in Discrete_Kind; | |
200 | end Is_Discrete_Type; | |
201 | ||
202 | function Is_Elementary_Type (Id : E) return B is | |
203 | begin | |
204 | return Ekind (Id) in Elementary_Kind; | |
205 | end Is_Elementary_Type; | |
206 | ||
207 | function Is_Entry (Id : E) return B is | |
208 | begin | |
209 | return Ekind (Id) in Entry_Kind; | |
210 | end Is_Entry; | |
211 | ||
212 | function Is_Enumeration_Type (Id : E) return B is | |
213 | begin | |
214 | return Ekind (Id) in Enumeration_Kind; | |
215 | end Is_Enumeration_Type; | |
216 | ||
217 | function Is_Fixed_Point_Type (Id : E) return B is | |
218 | begin | |
219 | return Ekind (Id) in Fixed_Point_Kind; | |
220 | end Is_Fixed_Point_Type; | |
221 | ||
222 | function Is_Floating_Point_Type (Id : E) return B is | |
223 | begin | |
224 | return Ekind (Id) in Float_Kind; | |
225 | end Is_Floating_Point_Type; | |
226 | ||
227 | function Is_Formal (Id : E) return B is | |
228 | begin | |
229 | return Ekind (Id) in Formal_Kind; | |
230 | end Is_Formal; | |
231 | ||
232 | function Is_Formal_Object (Id : E) return B is | |
233 | begin | |
234 | return Ekind (Id) in Formal_Object_Kind; | |
235 | end Is_Formal_Object; | |
236 | ||
237 | function Is_Generic_Subprogram (Id : E) return B is | |
238 | begin | |
239 | return Ekind (Id) in Generic_Subprogram_Kind; | |
240 | end Is_Generic_Subprogram; | |
241 | ||
242 | function Is_Generic_Unit (Id : E) return B is | |
243 | begin | |
244 | return Ekind (Id) in Generic_Unit_Kind; | |
245 | end Is_Generic_Unit; | |
246 | ||
247 | function Is_Ghost_Entity (Id : Entity_Id) return Boolean is | |
248 | begin | |
249 | return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id); | |
250 | end Is_Ghost_Entity; | |
251 | ||
252 | function Is_Incomplete_Or_Private_Type (Id : E) return B is | |
253 | begin | |
254 | return Ekind (Id) in Incomplete_Or_Private_Kind; | |
255 | end Is_Incomplete_Or_Private_Type; | |
256 | ||
257 | function Is_Incomplete_Type (Id : E) return B is | |
258 | begin | |
259 | return Ekind (Id) in Incomplete_Kind; | |
260 | end Is_Incomplete_Type; | |
261 | ||
262 | function Is_Integer_Type (Id : E) return B is | |
263 | begin | |
264 | return Ekind (Id) in Integer_Kind; | |
265 | end Is_Integer_Type; | |
266 | ||
267 | function Is_Modular_Integer_Type (Id : E) return B is | |
268 | begin | |
269 | return Ekind (Id) in Modular_Integer_Kind; | |
270 | end Is_Modular_Integer_Type; | |
271 | ||
272 | function Is_Named_Access_Type (Id : E) return B is | |
273 | begin | |
a7cadd18 | 274 | return Ekind (Id) in Named_Access_Kind; |
76f9c7f4 BD |
275 | end Is_Named_Access_Type; |
276 | ||
277 | function Is_Named_Number (Id : E) return B is | |
278 | begin | |
279 | return Ekind (Id) in Named_Kind; | |
280 | end Is_Named_Number; | |
281 | ||
282 | function Is_Numeric_Type (Id : E) return B is | |
283 | begin | |
284 | return Ekind (Id) in Numeric_Kind; | |
285 | end Is_Numeric_Type; | |
286 | ||
287 | function Is_Object (Id : E) return B is | |
288 | begin | |
289 | return Ekind (Id) in Object_Kind; | |
290 | end Is_Object; | |
291 | ||
292 | function Is_Ordinary_Fixed_Point_Type (Id : E) return B is | |
293 | begin | |
294 | return Ekind (Id) in Ordinary_Fixed_Point_Kind; | |
295 | end Is_Ordinary_Fixed_Point_Type; | |
296 | ||
297 | function Is_Overloadable (Id : E) return B is | |
298 | begin | |
299 | return Ekind (Id) in Overloadable_Kind; | |
300 | end Is_Overloadable; | |
301 | ||
302 | function Is_Private_Type (Id : E) return B is | |
303 | begin | |
304 | return Ekind (Id) in Private_Kind; | |
305 | end Is_Private_Type; | |
306 | ||
307 | function Is_Protected_Type (Id : E) return B is | |
308 | begin | |
309 | return Ekind (Id) in Protected_Kind; | |
310 | end Is_Protected_Type; | |
311 | ||
312 | function Is_Real_Type (Id : E) return B is | |
313 | begin | |
314 | return Ekind (Id) in Real_Kind; | |
315 | end Is_Real_Type; | |
316 | ||
317 | function Is_Record_Type (Id : E) return B is | |
318 | begin | |
319 | return Ekind (Id) in Record_Kind; | |
320 | end Is_Record_Type; | |
321 | ||
322 | function Is_Scalar_Type (Id : E) return B is | |
323 | begin | |
324 | return Ekind (Id) in Scalar_Kind; | |
325 | end Is_Scalar_Type; | |
326 | ||
327 | function Is_Signed_Integer_Type (Id : E) return B is | |
328 | begin | |
329 | return Ekind (Id) in Signed_Integer_Kind; | |
330 | end Is_Signed_Integer_Type; | |
331 | ||
332 | function Is_Subprogram (Id : E) return B is | |
333 | begin | |
334 | return Ekind (Id) in Subprogram_Kind; | |
335 | end Is_Subprogram; | |
336 | ||
337 | function Is_Subprogram_Or_Entry (Id : E) return B is | |
338 | begin | |
339 | return Ekind (Id) in Subprogram_Kind | |
340 | or else | |
341 | Ekind (Id) in Entry_Kind; | |
342 | end Is_Subprogram_Or_Entry; | |
343 | ||
344 | function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is | |
345 | begin | |
346 | return Ekind (Id) in Subprogram_Kind | |
347 | or else | |
348 | Ekind (Id) in Generic_Subprogram_Kind; | |
349 | end Is_Subprogram_Or_Generic_Subprogram; | |
350 | ||
351 | function Is_Task_Type (Id : E) return B is | |
352 | begin | |
353 | return Ekind (Id) in Task_Kind; | |
354 | end Is_Task_Type; | |
355 | ||
356 | function Is_Type (Id : E) return B is | |
357 | begin | |
358 | return Ekind (Id) in Type_Kind; | |
359 | end Is_Type; | |
360 | ||
361 | ----------------------------------- | |
362 | -- Field Initialization Routines -- | |
363 | ----------------------------------- | |
364 | ||
365 | procedure Init_Alignment (Id : E) is | |
366 | begin | |
0c8ff35e | 367 | Reinit_Field_To_Zero (Id, F_Alignment); |
76f9c7f4 BD |
368 | end Init_Alignment; |
369 | ||
370 | procedure Init_Alignment (Id : E; V : Int) is | |
371 | begin | |
372 | Set_Alignment (Id, UI_From_Int (V)); | |
373 | end Init_Alignment; | |
374 | ||
375 | procedure Init_Component_Bit_Offset (Id : E) is | |
376 | begin | |
377 | Set_Component_Bit_Offset (Id, No_Uint); | |
378 | end Init_Component_Bit_Offset; | |
379 | ||
380 | procedure Init_Component_Bit_Offset (Id : E; V : Int) is | |
381 | begin | |
382 | Set_Component_Bit_Offset (Id, UI_From_Int (V)); | |
383 | end Init_Component_Bit_Offset; | |
384 | ||
385 | procedure Init_Component_Size (Id : E) is | |
386 | begin | |
387 | Set_Component_Size (Id, Uint_0); | |
388 | end Init_Component_Size; | |
389 | ||
390 | procedure Init_Component_Size (Id : E; V : Int) is | |
391 | begin | |
392 | Set_Component_Size (Id, UI_From_Int (V)); | |
393 | end Init_Component_Size; | |
394 | ||
395 | procedure Init_Digits_Value (Id : E) is | |
396 | begin | |
397 | Set_Digits_Value (Id, Uint_0); | |
398 | end Init_Digits_Value; | |
399 | ||
400 | procedure Init_Digits_Value (Id : E; V : Int) is | |
401 | begin | |
402 | Set_Digits_Value (Id, UI_From_Int (V)); | |
403 | end Init_Digits_Value; | |
404 | ||
405 | procedure Init_Esize (Id : E) is | |
406 | begin | |
407 | Set_Esize (Id, Uint_0); | |
408 | end Init_Esize; | |
409 | ||
410 | procedure Init_Esize (Id : E; V : Int) is | |
411 | begin | |
412 | Set_Esize (Id, UI_From_Int (V)); | |
413 | end Init_Esize; | |
414 | ||
415 | procedure Init_Normalized_First_Bit (Id : E) is | |
416 | begin | |
417 | Set_Normalized_First_Bit (Id, No_Uint); | |
418 | end Init_Normalized_First_Bit; | |
419 | ||
420 | procedure Init_Normalized_First_Bit (Id : E; V : Int) is | |
421 | begin | |
422 | Set_Normalized_First_Bit (Id, UI_From_Int (V)); | |
423 | end Init_Normalized_First_Bit; | |
424 | ||
425 | procedure Init_Normalized_Position (Id : E) is | |
426 | begin | |
427 | Set_Normalized_Position (Id, No_Uint); | |
428 | end Init_Normalized_Position; | |
429 | ||
430 | procedure Init_Normalized_Position (Id : E; V : Int) is | |
431 | begin | |
432 | Set_Normalized_Position (Id, UI_From_Int (V)); | |
433 | end Init_Normalized_Position; | |
434 | ||
435 | procedure Init_Normalized_Position_Max (Id : E) is | |
436 | begin | |
437 | Set_Normalized_Position_Max (Id, No_Uint); | |
438 | end Init_Normalized_Position_Max; | |
439 | ||
440 | procedure Init_Normalized_Position_Max (Id : E; V : Int) is | |
441 | begin | |
442 | Set_Normalized_Position_Max (Id, UI_From_Int (V)); | |
443 | end Init_Normalized_Position_Max; | |
444 | ||
445 | procedure Init_RM_Size (Id : E) is | |
446 | begin | |
447 | Set_RM_Size (Id, Uint_0); | |
448 | end Init_RM_Size; | |
449 | ||
450 | procedure Init_RM_Size (Id : E; V : Int) is | |
451 | begin | |
452 | Set_RM_Size (Id, UI_From_Int (V)); | |
453 | end Init_RM_Size; | |
454 | ||
0c8ff35e BD |
455 | procedure Copy_Alignment (To, From : E) is |
456 | begin | |
457 | if Known_Alignment (From) then | |
458 | Set_Alignment (To, Alignment (From)); | |
459 | else | |
460 | Init_Alignment (To); | |
461 | end if; | |
462 | end Copy_Alignment; | |
463 | ||
76f9c7f4 BD |
464 | ----------------------------- |
465 | -- Init_Component_Location -- | |
466 | ----------------------------- | |
467 | ||
468 | procedure Init_Component_Location (Id : E) is | |
469 | begin | |
470 | Set_Normalized_First_Bit (Id, No_Uint); | |
471 | Set_Normalized_Position_Max (Id, No_Uint); | |
472 | Set_Component_Bit_Offset (Id, No_Uint); | |
473 | Set_Esize (Id, Uint_0); | |
474 | Set_Normalized_Position (Id, No_Uint); | |
475 | end Init_Component_Location; | |
476 | ||
477 | ---------------------------- | |
478 | -- Init_Object_Size_Align -- | |
479 | ---------------------------- | |
480 | ||
481 | procedure Init_Object_Size_Align (Id : E) is | |
482 | begin | |
0c8ff35e BD |
483 | Init_Esize (Id); |
484 | Init_Alignment (Id); | |
76f9c7f4 BD |
485 | end Init_Object_Size_Align; |
486 | ||
487 | --------------- | |
488 | -- Init_Size -- | |
489 | --------------- | |
490 | ||
491 | procedure Init_Size (Id : E; V : Int) is | |
492 | begin | |
a547eea2 BD |
493 | pragma Assert (Is_Type (Id)); |
494 | pragma Assert | |
495 | (not Known_Esize (Id) or else Esize (Id) = V); | |
496 | pragma Assert | |
497 | (RM_Size (Id) = No_Uint | |
498 | or else RM_Size (Id) = Uint_0 | |
499 | or else RM_Size (Id) = V); | |
76f9c7f4 BD |
500 | Set_Esize (Id, UI_From_Int (V)); |
501 | Set_RM_Size (Id, UI_From_Int (V)); | |
502 | end Init_Size; | |
503 | ||
504 | --------------------- | |
505 | -- Init_Size_Align -- | |
506 | --------------------- | |
507 | ||
508 | procedure Init_Size_Align (Id : E) is | |
509 | begin | |
a547eea2 | 510 | pragma Assert (Ekind (Id) in Type_Kind | E_Void); |
0c8ff35e BD |
511 | Init_Esize (Id); |
512 | Init_RM_Size (Id); | |
513 | Init_Alignment (Id); | |
76f9c7f4 BD |
514 | end Init_Size_Align; |
515 | ||
516 | ---------------------------------------------- | |
517 | -- Type Representation Attribute Predicates -- | |
518 | ---------------------------------------------- | |
519 | ||
520 | function Known_Alignment (E : Entity_Id) return B is | |
0c8ff35e | 521 | Result : constant B := not Field_Is_Initial_Zero (E, F_Alignment); |
76f9c7f4 | 522 | begin |
0c8ff35e | 523 | return Result; |
76f9c7f4 BD |
524 | end Known_Alignment; |
525 | ||
526 | function Known_Component_Bit_Offset (E : Entity_Id) return B is | |
527 | begin | |
528 | return Component_Bit_Offset (E) /= No_Uint; | |
529 | end Known_Component_Bit_Offset; | |
530 | ||
531 | function Known_Component_Size (E : Entity_Id) return B is | |
532 | begin | |
b9ec951f BD |
533 | return Component_Size (E) /= Uint_0 |
534 | and then Component_Size (E) /= No_Uint; | |
76f9c7f4 BD |
535 | end Known_Component_Size; |
536 | ||
537 | function Known_Esize (E : Entity_Id) return B is | |
538 | begin | |
539 | return Esize (E) /= Uint_0 | |
540 | and then Esize (E) /= No_Uint; | |
541 | end Known_Esize; | |
542 | ||
543 | function Known_Normalized_First_Bit (E : Entity_Id) return B is | |
544 | begin | |
545 | return Normalized_First_Bit (E) /= No_Uint; | |
546 | end Known_Normalized_First_Bit; | |
547 | ||
548 | function Known_Normalized_Position (E : Entity_Id) return B is | |
549 | begin | |
550 | return Normalized_Position (E) /= No_Uint; | |
551 | end Known_Normalized_Position; | |
552 | ||
553 | function Known_Normalized_Position_Max (E : Entity_Id) return B is | |
554 | begin | |
555 | return Normalized_Position_Max (E) /= No_Uint; | |
556 | end Known_Normalized_Position_Max; | |
557 | ||
558 | function Known_RM_Size (E : Entity_Id) return B is | |
559 | begin | |
560 | return RM_Size (E) /= No_Uint | |
561 | and then (RM_Size (E) /= Uint_0 | |
562 | or else Is_Discrete_Type (E) | |
563 | or else Is_Fixed_Point_Type (E)); | |
564 | end Known_RM_Size; | |
565 | ||
566 | function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is | |
567 | begin | |
568 | return Component_Bit_Offset (E) /= No_Uint | |
569 | and then Component_Bit_Offset (E) >= Uint_0; | |
570 | end Known_Static_Component_Bit_Offset; | |
571 | ||
572 | function Known_Static_Component_Size (E : Entity_Id) return B is | |
573 | begin | |
b9ec951f | 574 | return Component_Size (E) > Uint_0; |
76f9c7f4 BD |
575 | end Known_Static_Component_Size; |
576 | ||
577 | function Known_Static_Esize (E : Entity_Id) return B is | |
578 | begin | |
579 | return Esize (E) > Uint_0 | |
580 | and then not Is_Generic_Type (E); | |
581 | end Known_Static_Esize; | |
582 | ||
583 | function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is | |
584 | begin | |
585 | return Normalized_First_Bit (E) /= No_Uint | |
586 | and then Normalized_First_Bit (E) >= Uint_0; | |
587 | end Known_Static_Normalized_First_Bit; | |
588 | ||
589 | function Known_Static_Normalized_Position (E : Entity_Id) return B is | |
590 | begin | |
591 | return Normalized_Position (E) /= No_Uint | |
592 | and then Normalized_Position (E) >= Uint_0; | |
593 | end Known_Static_Normalized_Position; | |
594 | ||
595 | function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is | |
596 | begin | |
597 | return Normalized_Position_Max (E) /= No_Uint | |
598 | and then Normalized_Position_Max (E) >= Uint_0; | |
599 | end Known_Static_Normalized_Position_Max; | |
600 | ||
601 | function Known_Static_RM_Size (E : Entity_Id) return B is | |
602 | begin | |
603 | return (RM_Size (E) > Uint_0 | |
604 | or else Is_Discrete_Type (E) | |
605 | or else Is_Fixed_Point_Type (E)) | |
606 | and then not Is_Generic_Type (E); | |
607 | end Known_Static_RM_Size; | |
608 | ||
76f9c7f4 BD |
609 | -------------------- |
610 | -- Address_Clause -- | |
611 | -------------------- | |
612 | ||
613 | function Address_Clause (Id : E) return N is | |
614 | begin | |
615 | return Get_Attribute_Definition_Clause (Id, Attribute_Address); | |
616 | end Address_Clause; | |
617 | ||
618 | --------------- | |
619 | -- Aft_Value -- | |
620 | --------------- | |
621 | ||
622 | function Aft_Value (Id : E) return U is | |
623 | Result : Nat := 1; | |
624 | Delta_Val : Ureal := Delta_Value (Id); | |
625 | begin | |
626 | while Delta_Val < Ureal_Tenth loop | |
627 | Delta_Val := Delta_Val * Ureal_10; | |
628 | Result := Result + 1; | |
629 | end loop; | |
630 | ||
631 | return UI_From_Int (Result); | |
632 | end Aft_Value; | |
633 | ||
634 | ---------------------- | |
635 | -- Alignment_Clause -- | |
636 | ---------------------- | |
637 | ||
638 | function Alignment_Clause (Id : E) return N is | |
639 | begin | |
640 | return Get_Attribute_Definition_Clause (Id, Attribute_Alignment); | |
641 | end Alignment_Clause; | |
642 | ||
643 | ------------------- | |
644 | -- Append_Entity -- | |
645 | ------------------- | |
646 | ||
647 | procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id) is | |
648 | Last : constant Entity_Id := Last_Entity (Scop); | |
649 | ||
650 | begin | |
651 | Set_Scope (Id, Scop); | |
652 | Set_Prev_Entity (Id, Empty); -- Empty <-- Id | |
653 | ||
654 | -- The entity chain is empty | |
655 | ||
656 | if No (Last) then | |
657 | Set_First_Entity (Scop, Id); | |
658 | ||
659 | -- Otherwise the entity chain has at least one element | |
660 | ||
661 | else | |
662 | Link_Entities (Last, Id); -- Last <-- Id, Last --> Id | |
663 | end if; | |
664 | ||
665 | -- NOTE: The setting of the Next_Entity attribute of Id must happen | |
666 | -- here as opposed to at the beginning of the routine because doing | |
667 | -- so causes the binder to hang. It is not clear why ??? | |
668 | ||
669 | Set_Next_Entity (Id, Empty); -- Id --> Empty | |
670 | ||
671 | Set_Last_Entity (Scop, Id); | |
672 | end Append_Entity; | |
673 | ||
674 | --------------- | |
675 | -- Base_Type -- | |
676 | --------------- | |
677 | ||
678 | function Base_Type (Id : E) return E is | |
679 | begin | |
680 | if Is_Base_Type (Id) then | |
681 | return Id; | |
682 | else | |
683 | pragma Assert (Is_Type (Id)); | |
684 | return Etype (Id); | |
685 | end if; | |
686 | end Base_Type; | |
687 | ||
688 | ---------------------- | |
689 | -- Declaration_Node -- | |
690 | ---------------------- | |
691 | ||
692 | function Declaration_Node (Id : E) return N is | |
693 | P : Node_Id; | |
694 | ||
695 | begin | |
696 | if Ekind (Id) = E_Incomplete_Type | |
697 | and then Present (Full_View (Id)) | |
698 | then | |
699 | P := Parent (Full_View (Id)); | |
700 | else | |
701 | P := Parent (Id); | |
702 | end if; | |
703 | ||
704 | loop | |
705 | if Nkind (P) in N_Selected_Component | N_Expanded_Name | |
706 | or else (Nkind (P) = N_Defining_Program_Unit_Name | |
707 | and then Is_Child_Unit (Id)) | |
708 | then | |
709 | P := Parent (P); | |
710 | else | |
711 | return P; | |
712 | end if; | |
713 | end loop; | |
714 | end Declaration_Node; | |
715 | ||
716 | --------------------- | |
717 | -- Designated_Type -- | |
718 | --------------------- | |
719 | ||
720 | function Designated_Type (Id : E) return E is | |
721 | Desig_Type : Entity_Id; | |
722 | ||
723 | begin | |
724 | Desig_Type := Directly_Designated_Type (Id); | |
725 | ||
726 | if No (Desig_Type) then | |
727 | pragma Assert (Error_Posted (Id)); | |
728 | return Any_Type; | |
729 | end if; | |
730 | ||
731 | if Is_Incomplete_Type (Desig_Type) | |
732 | and then Present (Full_View (Desig_Type)) | |
733 | then | |
734 | return Full_View (Desig_Type); | |
735 | end if; | |
736 | ||
737 | if Is_Class_Wide_Type (Desig_Type) | |
738 | and then Is_Incomplete_Type (Etype (Desig_Type)) | |
739 | and then Present (Full_View (Etype (Desig_Type))) | |
740 | and then Present (Class_Wide_Type (Full_View (Etype (Desig_Type)))) | |
741 | then | |
742 | return Class_Wide_Type (Full_View (Etype (Desig_Type))); | |
743 | end if; | |
744 | ||
745 | return Desig_Type; | |
746 | end Designated_Type; | |
747 | ||
748 | ---------------------- | |
749 | -- Entry_Index_Type -- | |
750 | ---------------------- | |
751 | ||
752 | function Entry_Index_Type (Id : E) return N is | |
753 | begin | |
754 | pragma Assert (Ekind (Id) = E_Entry_Family); | |
755 | return Etype (Discrete_Subtype_Definition (Parent (Id))); | |
756 | end Entry_Index_Type; | |
757 | ||
758 | --------------------- | |
759 | -- First_Component -- | |
760 | --------------------- | |
761 | ||
762 | function First_Component (Id : E) return E is | |
763 | Comp_Id : Entity_Id; | |
764 | ||
765 | begin | |
766 | pragma Assert | |
767 | (Is_Concurrent_Type (Id) | |
768 | or else Is_Incomplete_Or_Private_Type (Id) | |
769 | or else Is_Record_Type (Id)); | |
770 | ||
771 | Comp_Id := First_Entity (Id); | |
772 | while Present (Comp_Id) loop | |
773 | exit when Ekind (Comp_Id) = E_Component; | |
774 | Next_Entity (Comp_Id); | |
775 | end loop; | |
776 | ||
777 | return Comp_Id; | |
778 | end First_Component; | |
779 | ||
780 | ------------------------------------- | |
781 | -- First_Component_Or_Discriminant -- | |
782 | ------------------------------------- | |
783 | ||
784 | function First_Component_Or_Discriminant (Id : E) return E is | |
785 | Comp_Id : Entity_Id; | |
786 | ||
787 | begin | |
788 | pragma Assert | |
789 | (Is_Concurrent_Type (Id) | |
790 | or else Is_Incomplete_Or_Private_Type (Id) | |
791 | or else Is_Record_Type (Id) | |
792 | or else Has_Discriminants (Id)); | |
793 | ||
794 | Comp_Id := First_Entity (Id); | |
795 | while Present (Comp_Id) loop | |
796 | exit when Ekind (Comp_Id) in E_Component | E_Discriminant; | |
797 | Next_Entity (Comp_Id); | |
798 | end loop; | |
799 | ||
800 | return Comp_Id; | |
801 | end First_Component_Or_Discriminant; | |
802 | ||
803 | ------------------ | |
804 | -- First_Formal -- | |
805 | ------------------ | |
806 | ||
807 | function First_Formal (Id : E) return E is | |
808 | Formal : Entity_Id; | |
809 | ||
810 | begin | |
811 | pragma Assert | |
812 | (Is_Generic_Subprogram (Id) | |
813 | or else Is_Overloadable (Id) | |
814 | or else Ekind (Id) in E_Entry_Family | |
815 | | E_Subprogram_Body | |
816 | | E_Subprogram_Type); | |
817 | ||
818 | if Ekind (Id) = E_Enumeration_Literal then | |
819 | return Empty; | |
820 | ||
821 | else | |
822 | Formal := First_Entity (Id); | |
823 | ||
824 | -- Deal with the common, non-generic case first | |
825 | ||
826 | if No (Formal) or else Is_Formal (Formal) then | |
827 | return Formal; | |
828 | end if; | |
829 | ||
830 | -- The first/next entity chain of a generic subprogram contains all | |
831 | -- generic formal parameters, followed by the formal parameters. | |
832 | ||
833 | if Is_Generic_Subprogram (Id) then | |
834 | while Present (Formal) and then not Is_Formal (Formal) loop | |
835 | Next_Entity (Formal); | |
836 | end loop; | |
837 | return Formal; | |
838 | else | |
839 | return Empty; | |
840 | end if; | |
841 | end if; | |
842 | end First_Formal; | |
843 | ||
844 | ------------------------------ | |
845 | -- First_Formal_With_Extras -- | |
846 | ------------------------------ | |
847 | ||
848 | function First_Formal_With_Extras (Id : E) return E is | |
849 | Formal : Entity_Id; | |
850 | ||
851 | begin | |
852 | pragma Assert | |
853 | (Is_Generic_Subprogram (Id) | |
854 | or else Is_Overloadable (Id) | |
855 | or else Ekind (Id) in E_Entry_Family | |
856 | | E_Subprogram_Body | |
857 | | E_Subprogram_Type); | |
858 | ||
859 | if Ekind (Id) = E_Enumeration_Literal then | |
860 | return Empty; | |
861 | ||
862 | else | |
863 | Formal := First_Entity (Id); | |
864 | ||
865 | -- The first/next entity chain of a generic subprogram contains all | |
866 | -- generic formal parameters, followed by the formal parameters. Go | |
867 | -- directly to the parameters by skipping the formal part. | |
868 | ||
869 | if Is_Generic_Subprogram (Id) then | |
870 | while Present (Formal) and then not Is_Formal (Formal) loop | |
871 | Next_Entity (Formal); | |
872 | end loop; | |
873 | end if; | |
874 | ||
875 | if Present (Formal) and then Is_Formal (Formal) then | |
876 | return Formal; | |
877 | else | |
878 | return Extra_Formals (Id); -- Empty if no extra formals | |
879 | end if; | |
880 | end if; | |
881 | end First_Formal_With_Extras; | |
882 | ||
9324e07d BD |
883 | --------------- |
884 | -- Float_Rep -- | |
885 | --------------- | |
886 | ||
887 | function Float_Rep (N : Entity_Id) return Float_Rep_Kind is | |
888 | pragma Unreferenced (N); | |
889 | pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last); | |
890 | ||
891 | -- There is only one value, so we don't need to store it, see types.ads. | |
892 | ||
893 | Val : constant Float_Rep_Kind := IEEE_Binary; | |
894 | ||
895 | begin | |
896 | return Val; | |
897 | end Float_Rep; | |
898 | ||
76f9c7f4 BD |
899 | ------------------------------------- |
900 | -- Get_Attribute_Definition_Clause -- | |
901 | ------------------------------------- | |
902 | ||
903 | function Get_Attribute_Definition_Clause | |
904 | (E : Entity_Id; | |
905 | Id : Attribute_Id) return Node_Id | |
906 | is | |
907 | N : Node_Id; | |
908 | ||
909 | begin | |
910 | N := First_Rep_Item (E); | |
911 | while Present (N) loop | |
912 | if Nkind (N) = N_Attribute_Definition_Clause | |
913 | and then Get_Attribute_Id (Chars (N)) = Id | |
914 | then | |
915 | return N; | |
916 | else | |
917 | Next_Rep_Item (N); | |
918 | end if; | |
919 | end loop; | |
920 | ||
921 | return Empty; | |
922 | end Get_Attribute_Definition_Clause; | |
923 | ||
924 | --------------------------- | |
925 | -- Get_Class_Wide_Pragma -- | |
926 | --------------------------- | |
927 | ||
928 | function Get_Class_Wide_Pragma | |
929 | (E : Entity_Id; | |
930 | Id : Pragma_Id) return Node_Id | |
931 | is | |
932 | Item : Node_Id; | |
933 | Items : Node_Id; | |
934 | ||
935 | begin | |
936 | Items := Contract (E); | |
937 | ||
938 | if No (Items) then | |
939 | return Empty; | |
940 | end if; | |
941 | ||
942 | Item := Pre_Post_Conditions (Items); | |
943 | while Present (Item) loop | |
944 | if Nkind (Item) = N_Pragma | |
945 | and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id | |
946 | and then Class_Present (Item) | |
947 | then | |
948 | return Item; | |
949 | end if; | |
950 | ||
951 | Item := Next_Pragma (Item); | |
952 | end loop; | |
953 | ||
954 | return Empty; | |
955 | end Get_Class_Wide_Pragma; | |
956 | ||
957 | ------------------- | |
958 | -- Get_Full_View -- | |
959 | ------------------- | |
960 | ||
961 | function Get_Full_View (T : Entity_Id) return Entity_Id is | |
962 | begin | |
963 | if Is_Incomplete_Type (T) and then Present (Full_View (T)) then | |
964 | return Full_View (T); | |
965 | ||
966 | elsif Is_Class_Wide_Type (T) | |
967 | and then Is_Incomplete_Type (Root_Type (T)) | |
968 | and then Present (Full_View (Root_Type (T))) | |
969 | then | |
970 | return Class_Wide_Type (Full_View (Root_Type (T))); | |
971 | ||
972 | else | |
973 | return T; | |
974 | end if; | |
975 | end Get_Full_View; | |
976 | ||
977 | ---------------- | |
978 | -- Get_Pragma -- | |
979 | ---------------- | |
980 | ||
981 | function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id is | |
982 | ||
983 | -- Classification pragmas | |
984 | ||
985 | Is_CLS : constant Boolean := | |
986 | Id = Pragma_Abstract_State or else | |
987 | Id = Pragma_Attach_Handler or else | |
988 | Id = Pragma_Async_Readers or else | |
989 | Id = Pragma_Async_Writers or else | |
990 | Id = Pragma_Constant_After_Elaboration or else | |
991 | Id = Pragma_Depends or else | |
992 | Id = Pragma_Effective_Reads or else | |
993 | Id = Pragma_Effective_Writes or else | |
994 | Id = Pragma_Extensions_Visible or else | |
995 | Id = Pragma_Global or else | |
996 | Id = Pragma_Initial_Condition or else | |
997 | Id = Pragma_Initializes or else | |
998 | Id = Pragma_Interrupt_Handler or else | |
999 | Id = Pragma_No_Caching or else | |
1000 | Id = Pragma_Part_Of or else | |
1001 | Id = Pragma_Refined_Depends or else | |
1002 | Id = Pragma_Refined_Global or else | |
1003 | Id = Pragma_Refined_State or else | |
1004 | Id = Pragma_Volatile_Function; | |
1005 | ||
1006 | -- Contract / subprogram variant / test case pragmas | |
1007 | ||
1008 | Is_CTC : constant Boolean := | |
1009 | Id = Pragma_Contract_Cases or else | |
1010 | Id = Pragma_Subprogram_Variant or else | |
1011 | Id = Pragma_Test_Case; | |
1012 | ||
1013 | -- Pre / postcondition pragmas | |
1014 | ||
1015 | Is_PPC : constant Boolean := | |
1016 | Id = Pragma_Precondition or else | |
1017 | Id = Pragma_Postcondition or else | |
1018 | Id = Pragma_Refined_Post; | |
1019 | ||
1020 | In_Contract : constant Boolean := Is_CLS or Is_CTC or Is_PPC; | |
1021 | ||
1022 | Item : Node_Id; | |
1023 | Items : Node_Id; | |
1024 | ||
1025 | begin | |
1026 | -- Handle pragmas that appear in N_Contract nodes. Those have to be | |
1027 | -- extracted from their specialized list. | |
1028 | ||
1029 | if In_Contract then | |
1030 | Items := Contract (E); | |
1031 | ||
1032 | if No (Items) then | |
1033 | return Empty; | |
1034 | ||
1035 | elsif Is_CLS then | |
1036 | Item := Classifications (Items); | |
1037 | ||
1038 | elsif Is_CTC then | |
1039 | Item := Contract_Test_Cases (Items); | |
1040 | ||
1041 | else | |
1042 | Item := Pre_Post_Conditions (Items); | |
1043 | end if; | |
1044 | ||
1045 | -- Regular pragmas | |
1046 | ||
1047 | else | |
1048 | Item := First_Rep_Item (E); | |
1049 | end if; | |
1050 | ||
1051 | while Present (Item) loop | |
1052 | if Nkind (Item) = N_Pragma | |
1053 | and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id | |
1054 | then | |
1055 | return Item; | |
1056 | ||
1057 | -- All nodes in N_Contract are chained using Next_Pragma | |
1058 | ||
1059 | elsif In_Contract then | |
1060 | Item := Next_Pragma (Item); | |
1061 | ||
1062 | -- Regular pragmas | |
1063 | ||
1064 | else | |
1065 | Next_Rep_Item (Item); | |
1066 | end if; | |
1067 | end loop; | |
1068 | ||
1069 | return Empty; | |
1070 | end Get_Pragma; | |
1071 | ||
1072 | -------------------------------------- | |
1073 | -- Get_Record_Representation_Clause -- | |
1074 | -------------------------------------- | |
1075 | ||
1076 | function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is | |
1077 | N : Node_Id; | |
1078 | ||
1079 | begin | |
1080 | N := First_Rep_Item (E); | |
1081 | while Present (N) loop | |
1082 | if Nkind (N) = N_Record_Representation_Clause then | |
1083 | return N; | |
1084 | end if; | |
1085 | ||
1086 | Next_Rep_Item (N); | |
1087 | end loop; | |
1088 | ||
1089 | return Empty; | |
1090 | end Get_Record_Representation_Clause; | |
1091 | ||
1092 | ------------------------ | |
1093 | -- Has_Attach_Handler -- | |
1094 | ------------------------ | |
1095 | ||
1096 | function Has_Attach_Handler (Id : E) return B is | |
1097 | Ritem : Node_Id; | |
1098 | ||
1099 | begin | |
1100 | pragma Assert (Is_Protected_Type (Id)); | |
1101 | ||
1102 | Ritem := First_Rep_Item (Id); | |
1103 | while Present (Ritem) loop | |
1104 | if Nkind (Ritem) = N_Pragma | |
1105 | and then Pragma_Name (Ritem) = Name_Attach_Handler | |
1106 | then | |
1107 | return True; | |
1108 | else | |
1109 | Next_Rep_Item (Ritem); | |
1110 | end if; | |
1111 | end loop; | |
1112 | ||
1113 | return False; | |
1114 | end Has_Attach_Handler; | |
1115 | ||
1116 | ------------- | |
1117 | -- Has_DIC -- | |
1118 | ------------- | |
1119 | ||
1120 | function Has_DIC (Id : E) return B is | |
1121 | begin | |
1122 | return Has_Own_DIC (Id) or else Has_Inherited_DIC (Id); | |
1123 | end Has_DIC; | |
1124 | ||
1125 | ----------------- | |
1126 | -- Has_Entries -- | |
1127 | ----------------- | |
1128 | ||
1129 | function Has_Entries (Id : E) return B is | |
1130 | Ent : Entity_Id; | |
1131 | ||
1132 | begin | |
1133 | pragma Assert (Is_Concurrent_Type (Id)); | |
1134 | ||
1135 | Ent := First_Entity (Id); | |
1136 | while Present (Ent) loop | |
1137 | if Is_Entry (Ent) then | |
1138 | return True; | |
1139 | end if; | |
1140 | ||
1141 | Next_Entity (Ent); | |
1142 | end loop; | |
1143 | ||
1144 | return False; | |
1145 | end Has_Entries; | |
1146 | ||
1147 | ---------------------------- | |
1148 | -- Has_Foreign_Convention -- | |
1149 | ---------------------------- | |
1150 | ||
1151 | function Has_Foreign_Convention (Id : E) return B is | |
1152 | begin | |
1153 | -- While regular Intrinsics such as the Standard operators fit in the | |
1154 | -- "Ada" convention, those with an Interface_Name materialize GCC | |
1155 | -- builtin imports for which Ada special treatments shouldn't apply. | |
1156 | ||
1157 | return Convention (Id) in Foreign_Convention | |
1158 | or else (Convention (Id) = Convention_Intrinsic | |
1159 | and then Present (Interface_Name (Id))); | |
1160 | end Has_Foreign_Convention; | |
1161 | ||
1162 | --------------------------- | |
1163 | -- Has_Interrupt_Handler -- | |
1164 | --------------------------- | |
1165 | ||
1166 | function Has_Interrupt_Handler (Id : E) return B is | |
1167 | Ritem : Node_Id; | |
1168 | ||
1169 | begin | |
1170 | pragma Assert (Is_Protected_Type (Id)); | |
1171 | ||
1172 | Ritem := First_Rep_Item (Id); | |
1173 | while Present (Ritem) loop | |
1174 | if Nkind (Ritem) = N_Pragma | |
1175 | and then Pragma_Name (Ritem) = Name_Interrupt_Handler | |
1176 | then | |
1177 | return True; | |
1178 | else | |
1179 | Next_Rep_Item (Ritem); | |
1180 | end if; | |
1181 | end loop; | |
1182 | ||
1183 | return False; | |
1184 | end Has_Interrupt_Handler; | |
1185 | ||
1186 | -------------------- | |
1187 | -- Has_Invariants -- | |
1188 | -------------------- | |
1189 | ||
1190 | function Has_Invariants (Id : E) return B is | |
1191 | begin | |
1192 | return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id); | |
1193 | end Has_Invariants; | |
1194 | ||
1195 | -------------------------- | |
1196 | -- Has_Limited_View -- | |
1197 | -------------------------- | |
1198 | ||
1199 | function Has_Limited_View (Id : E) return B is | |
1200 | begin | |
1201 | return Ekind (Id) = E_Package | |
1202 | and then not Is_Generic_Instance (Id) | |
1203 | and then Present (Limited_View (Id)); | |
1204 | end Has_Limited_View; | |
1205 | ||
1206 | -------------------------- | |
1207 | -- Has_Non_Limited_View -- | |
1208 | -------------------------- | |
1209 | ||
1210 | function Has_Non_Limited_View (Id : E) return B is | |
1211 | begin | |
1212 | return (Ekind (Id) in Incomplete_Kind | |
1213 | or else Ekind (Id) in Class_Wide_Kind | |
1214 | or else Ekind (Id) = E_Abstract_State) | |
1215 | and then Present (Non_Limited_View (Id)); | |
1216 | end Has_Non_Limited_View; | |
1217 | ||
1218 | --------------------------------- | |
1219 | -- Has_Non_Null_Abstract_State -- | |
1220 | --------------------------------- | |
1221 | ||
1222 | function Has_Non_Null_Abstract_State (Id : E) return B is | |
1223 | begin | |
1224 | pragma Assert (Is_Package_Or_Generic_Package (Id)); | |
1225 | ||
1226 | return | |
1227 | Present (Abstract_States (Id)) | |
1228 | and then | |
1229 | not Is_Null_State (Node (First_Elmt (Abstract_States (Id)))); | |
1230 | end Has_Non_Null_Abstract_State; | |
1231 | ||
1232 | ------------------------------------- | |
1233 | -- Has_Non_Null_Visible_Refinement -- | |
1234 | ------------------------------------- | |
1235 | ||
1236 | function Has_Non_Null_Visible_Refinement (Id : E) return B is | |
1237 | Constits : Elist_Id; | |
1238 | ||
1239 | begin | |
1240 | -- "Refinement" is a concept applicable only to abstract states | |
1241 | ||
1242 | pragma Assert (Ekind (Id) = E_Abstract_State); | |
1243 | Constits := Refinement_Constituents (Id); | |
1244 | ||
1245 | -- A partial refinement is always non-null. For a full refinement to be | |
1246 | -- non-null, the first constituent must be anything other than null. | |
1247 | ||
1248 | return | |
1249 | Has_Partial_Visible_Refinement (Id) | |
1250 | or else (Has_Visible_Refinement (Id) | |
1251 | and then Present (Constits) | |
1252 | and then Nkind (Node (First_Elmt (Constits))) /= N_Null); | |
1253 | end Has_Non_Null_Visible_Refinement; | |
1254 | ||
1255 | ----------------------------- | |
1256 | -- Has_Null_Abstract_State -- | |
1257 | ----------------------------- | |
1258 | ||
1259 | function Has_Null_Abstract_State (Id : E) return B is | |
1260 | pragma Assert (Is_Package_Or_Generic_Package (Id)); | |
1261 | ||
1262 | States : constant Elist_Id := Abstract_States (Id); | |
1263 | ||
1264 | begin | |
1265 | -- Check first available state of related package. A null abstract | |
1266 | -- state always appears as the sole element of the state list. | |
1267 | ||
1268 | return | |
1269 | Present (States) | |
1270 | and then Is_Null_State (Node (First_Elmt (States))); | |
1271 | end Has_Null_Abstract_State; | |
1272 | ||
1273 | --------------------------------- | |
1274 | -- Has_Null_Visible_Refinement -- | |
1275 | --------------------------------- | |
1276 | ||
1277 | function Has_Null_Visible_Refinement (Id : E) return B is | |
1278 | Constits : Elist_Id; | |
1279 | ||
1280 | begin | |
1281 | -- "Refinement" is a concept applicable only to abstract states | |
1282 | ||
1283 | pragma Assert (Ekind (Id) = E_Abstract_State); | |
1284 | Constits := Refinement_Constituents (Id); | |
1285 | ||
1286 | -- For a refinement to be null, the state's sole constituent must be a | |
1287 | -- null. | |
1288 | ||
1289 | return | |
1290 | Has_Visible_Refinement (Id) | |
1291 | and then Present (Constits) | |
1292 | and then Nkind (Node (First_Elmt (Constits))) = N_Null; | |
1293 | end Has_Null_Visible_Refinement; | |
1294 | ||
1295 | -------------------- | |
1296 | -- Has_Unmodified -- | |
1297 | -------------------- | |
1298 | ||
1299 | function Has_Unmodified (E : Entity_Id) return Boolean is | |
1300 | begin | |
1301 | if Has_Pragma_Unmodified (E) then | |
1302 | return True; | |
1303 | elsif Warnings_Off (E) then | |
1304 | Set_Warnings_Off_Used_Unmodified (E); | |
1305 | return True; | |
1306 | else | |
1307 | return False; | |
1308 | end if; | |
1309 | end Has_Unmodified; | |
1310 | ||
1311 | --------------------- | |
1312 | -- Has_Unreferenced -- | |
1313 | --------------------- | |
1314 | ||
1315 | function Has_Unreferenced (E : Entity_Id) return Boolean is | |
1316 | begin | |
1317 | if Has_Pragma_Unreferenced (E) then | |
1318 | return True; | |
1319 | elsif Warnings_Off (E) then | |
1320 | Set_Warnings_Off_Used_Unreferenced (E); | |
1321 | return True; | |
1322 | else | |
1323 | return False; | |
1324 | end if; | |
1325 | end Has_Unreferenced; | |
1326 | ||
1327 | ---------------------- | |
1328 | -- Has_Warnings_Off -- | |
1329 | ---------------------- | |
1330 | ||
1331 | function Has_Warnings_Off (E : Entity_Id) return Boolean is | |
1332 | begin | |
1333 | if Warnings_Off (E) then | |
1334 | Set_Warnings_Off_Used (E); | |
1335 | return True; | |
1336 | else | |
1337 | return False; | |
1338 | end if; | |
1339 | end Has_Warnings_Off; | |
1340 | ||
1341 | ------------------------------ | |
1342 | -- Implementation_Base_Type -- | |
1343 | ------------------------------ | |
1344 | ||
1345 | function Implementation_Base_Type (Id : E) return E is | |
1346 | Bastyp : Entity_Id; | |
1347 | Imptyp : Entity_Id; | |
1348 | ||
1349 | begin | |
1350 | Bastyp := Base_Type (Id); | |
1351 | ||
1352 | if Is_Incomplete_Or_Private_Type (Bastyp) then | |
1353 | Imptyp := Underlying_Type (Bastyp); | |
1354 | ||
1355 | -- If we have an implementation type, then just return it, | |
1356 | -- otherwise we return the Base_Type anyway. This can only | |
1357 | -- happen in error situations and should avoid some error bombs. | |
1358 | ||
1359 | if Present (Imptyp) then | |
1360 | return Base_Type (Imptyp); | |
1361 | else | |
1362 | return Bastyp; | |
1363 | end if; | |
1364 | ||
1365 | else | |
1366 | return Bastyp; | |
1367 | end if; | |
1368 | end Implementation_Base_Type; | |
1369 | ||
1370 | ------------------------- | |
1371 | -- Invariant_Procedure -- | |
1372 | ------------------------- | |
1373 | ||
1374 | function Invariant_Procedure (Id : E) return E is | |
1375 | Subp_Elmt : Elmt_Id; | |
1376 | Subp_Id : Entity_Id; | |
1377 | Subps : Elist_Id; | |
1378 | ||
1379 | begin | |
1380 | pragma Assert (Is_Type (Id)); | |
1381 | ||
1382 | Subps := Subprograms_For_Type (Base_Type (Id)); | |
1383 | ||
1384 | if Present (Subps) then | |
1385 | Subp_Elmt := First_Elmt (Subps); | |
1386 | while Present (Subp_Elmt) loop | |
1387 | Subp_Id := Node (Subp_Elmt); | |
1388 | ||
1389 | if Is_Invariant_Procedure (Subp_Id) then | |
1390 | return Subp_Id; | |
1391 | end if; | |
1392 | ||
1393 | Next_Elmt (Subp_Elmt); | |
1394 | end loop; | |
1395 | end if; | |
1396 | ||
1397 | return Empty; | |
1398 | end Invariant_Procedure; | |
1399 | ||
1400 | ------------------ | |
1401 | -- Is_Base_Type -- | |
1402 | ------------------ | |
1403 | ||
1404 | -- Global flag table allowing rapid computation of this function | |
1405 | ||
1406 | Entity_Is_Base_Type : constant array (Entity_Kind) of Boolean := | |
1407 | (E_Enumeration_Subtype | | |
1408 | E_Incomplete_Subtype | | |
1409 | E_Signed_Integer_Subtype | | |
1410 | E_Modular_Integer_Subtype | | |
1411 | E_Floating_Point_Subtype | | |
1412 | E_Ordinary_Fixed_Point_Subtype | | |
1413 | E_Decimal_Fixed_Point_Subtype | | |
1414 | E_Array_Subtype | | |
1415 | E_Record_Subtype | | |
1416 | E_Private_Subtype | | |
1417 | E_Record_Subtype_With_Private | | |
1418 | E_Limited_Private_Subtype | | |
1419 | E_Access_Subtype | | |
1420 | E_Protected_Subtype | | |
1421 | E_Task_Subtype | | |
1422 | E_String_Literal_Subtype | | |
1423 | E_Class_Wide_Subtype => False, | |
1424 | others => True); | |
1425 | ||
1426 | function Is_Base_Type (Id : E) return Boolean is | |
1427 | begin | |
76f9c7f4 BD |
1428 | return Entity_Is_Base_Type (Ekind (Id)); |
1429 | end Is_Base_Type; | |
1430 | ||
1431 | --------------------- | |
1432 | -- Is_Boolean_Type -- | |
1433 | --------------------- | |
1434 | ||
1435 | function Is_Boolean_Type (Id : E) return B is | |
1436 | begin | |
1437 | return Root_Type (Id) = Standard_Boolean; | |
1438 | end Is_Boolean_Type; | |
1439 | ||
1440 | ------------------------ | |
1441 | -- Is_Constant_Object -- | |
1442 | ------------------------ | |
1443 | ||
1444 | function Is_Constant_Object (Id : E) return B is | |
1445 | begin | |
1446 | return Ekind (Id) in E_Constant | E_In_Parameter | E_Loop_Parameter; | |
1447 | end Is_Constant_Object; | |
1448 | ||
1449 | ------------------- | |
1450 | -- Is_Controlled -- | |
1451 | ------------------- | |
1452 | ||
1453 | function Is_Controlled (Id : E) return B is | |
1454 | begin | |
1455 | return Is_Controlled_Active (Id) and then not Disable_Controlled (Id); | |
1456 | end Is_Controlled; | |
1457 | ||
1458 | -------------------- | |
1459 | -- Is_Discriminal -- | |
1460 | -------------------- | |
1461 | ||
1462 | function Is_Discriminal (Id : E) return B is | |
1463 | begin | |
1464 | return Ekind (Id) in E_Constant | E_In_Parameter | |
1465 | and then Present (Discriminal_Link (Id)); | |
1466 | end Is_Discriminal; | |
1467 | ||
1468 | ---------------------- | |
1469 | -- Is_Dynamic_Scope -- | |
1470 | ---------------------- | |
1471 | ||
1472 | function Is_Dynamic_Scope (Id : E) return B is | |
1473 | begin | |
1474 | return | |
1475 | Ekind (Id) = E_Block | |
1476 | or else | |
1477 | Ekind (Id) = E_Function | |
1478 | or else | |
1479 | Ekind (Id) = E_Procedure | |
1480 | or else | |
1481 | Ekind (Id) = E_Subprogram_Body | |
1482 | or else | |
1483 | Ekind (Id) = E_Task_Type | |
1484 | or else | |
1485 | (Ekind (Id) = E_Limited_Private_Type | |
1486 | and then Present (Full_View (Id)) | |
1487 | and then Ekind (Full_View (Id)) = E_Task_Type) | |
1488 | or else | |
1489 | Ekind (Id) = E_Entry | |
1490 | or else | |
1491 | Ekind (Id) = E_Entry_Family | |
1492 | or else | |
1493 | Ekind (Id) = E_Return_Statement; | |
1494 | end Is_Dynamic_Scope; | |
1495 | ||
1496 | -------------------- | |
1497 | -- Is_Entity_Name -- | |
1498 | -------------------- | |
1499 | ||
1500 | function Is_Entity_Name (N : Node_Id) return Boolean is | |
1501 | Kind : constant Node_Kind := Nkind (N); | |
1502 | ||
1503 | begin | |
1504 | -- Identifiers, operator symbols, expanded names are entity names | |
1505 | ||
1506 | return Kind = N_Identifier | |
1507 | or else Kind = N_Operator_Symbol | |
1508 | or else Kind = N_Expanded_Name | |
1509 | ||
1510 | -- Attribute references are entity names if they refer to an entity. | |
1511 | -- Note that we don't do this by testing for the presence of the | |
1512 | -- Entity field in the N_Attribute_Reference node, since it may not | |
1513 | -- have been set yet. | |
1514 | ||
1515 | or else (Kind = N_Attribute_Reference | |
1516 | and then Is_Entity_Attribute_Name (Attribute_Name (N))); | |
1517 | end Is_Entity_Name; | |
1518 | ||
1519 | --------------------------- | |
1520 | -- Is_Elaboration_Target -- | |
1521 | --------------------------- | |
1522 | ||
1523 | function Is_Elaboration_Target (Id : Entity_Id) return Boolean is | |
1524 | begin | |
1525 | return | |
1526 | Ekind (Id) in E_Constant | E_Package | E_Variable | |
1527 | or else Is_Entry (Id) | |
1528 | or else Is_Generic_Unit (Id) | |
1529 | or else Is_Subprogram (Id) | |
1530 | or else Is_Task_Type (Id); | |
1531 | end Is_Elaboration_Target; | |
1532 | ||
1533 | ----------------------- | |
1534 | -- Is_External_State -- | |
1535 | ----------------------- | |
1536 | ||
1537 | function Is_External_State (Id : E) return B is | |
1538 | begin | |
1539 | -- To qualify, the abstract state must appear with option "external" or | |
1540 | -- "synchronous" (SPARK RM 7.1.4(7) and (9)). | |
1541 | ||
1542 | return | |
1543 | Ekind (Id) = E_Abstract_State | |
1544 | and then (Has_Option (Id, Name_External) | |
1545 | or else | |
1546 | Has_Option (Id, Name_Synchronous)); | |
1547 | end Is_External_State; | |
1548 | ||
1549 | ------------------ | |
1550 | -- Is_Finalizer -- | |
1551 | ------------------ | |
1552 | ||
1553 | function Is_Finalizer (Id : E) return B is | |
1554 | begin | |
1555 | return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; | |
1556 | end Is_Finalizer; | |
1557 | ||
1558 | ---------------------- | |
1559 | -- Is_Full_Access -- | |
1560 | ---------------------- | |
1561 | ||
1562 | function Is_Full_Access (Id : E) return B is | |
1563 | begin | |
1564 | return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id); | |
1565 | end Is_Full_Access; | |
1566 | ||
1567 | ------------------- | |
1568 | -- Is_Null_State -- | |
1569 | ------------------- | |
1570 | ||
1571 | function Is_Null_State (Id : E) return B is | |
1572 | begin | |
1573 | return | |
1574 | Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null; | |
1575 | end Is_Null_State; | |
1576 | ||
1577 | ----------------------------------- | |
1578 | -- Is_Package_Or_Generic_Package -- | |
1579 | ----------------------------------- | |
1580 | ||
1581 | function Is_Package_Or_Generic_Package (Id : E) return B is | |
1582 | begin | |
1583 | return Ekind (Id) in E_Generic_Package | E_Package; | |
1584 | end Is_Package_Or_Generic_Package; | |
1585 | ||
1586 | --------------------- | |
1587 | -- Is_Packed_Array -- | |
1588 | --------------------- | |
1589 | ||
1590 | function Is_Packed_Array (Id : E) return B is | |
1591 | begin | |
1592 | return Is_Array_Type (Id) and then Is_Packed (Id); | |
1593 | end Is_Packed_Array; | |
1594 | ||
1595 | --------------- | |
1596 | -- Is_Prival -- | |
1597 | --------------- | |
1598 | ||
1599 | function Is_Prival (Id : E) return B is | |
1600 | begin | |
1601 | return Ekind (Id) in E_Constant | E_Variable | |
1602 | and then Present (Prival_Link (Id)); | |
1603 | end Is_Prival; | |
1604 | ||
1605 | ---------------------------- | |
1606 | -- Is_Protected_Component -- | |
1607 | ---------------------------- | |
1608 | ||
1609 | function Is_Protected_Component (Id : E) return B is | |
1610 | begin | |
1611 | return Ekind (Id) = E_Component and then Is_Protected_Type (Scope (Id)); | |
1612 | end Is_Protected_Component; | |
1613 | ||
1614 | ---------------------------- | |
1615 | -- Is_Protected_Interface -- | |
1616 | ---------------------------- | |
1617 | ||
1618 | function Is_Protected_Interface (Id : E) return B is | |
1619 | Typ : constant Entity_Id := Base_Type (Id); | |
1620 | begin | |
1621 | if not Is_Interface (Typ) then | |
1622 | return False; | |
1623 | elsif Is_Class_Wide_Type (Typ) then | |
1624 | return Is_Protected_Interface (Etype (Typ)); | |
1625 | else | |
1626 | return Protected_Present (Type_Definition (Parent (Typ))); | |
1627 | end if; | |
1628 | end Is_Protected_Interface; | |
1629 | ||
1630 | ------------------------------ | |
1631 | -- Is_Protected_Record_Type -- | |
1632 | ------------------------------ | |
1633 | ||
1634 | function Is_Protected_Record_Type (Id : E) return B is | |
1635 | begin | |
1636 | return | |
1637 | Is_Concurrent_Record_Type (Id) | |
1638 | and then Is_Protected_Type (Corresponding_Concurrent_Type (Id)); | |
1639 | end Is_Protected_Record_Type; | |
1640 | ||
1641 | ------------------------------------- | |
1642 | -- Is_Relaxed_Initialization_State -- | |
1643 | ------------------------------------- | |
1644 | ||
1645 | function Is_Relaxed_Initialization_State (Id : E) return B is | |
1646 | begin | |
1647 | -- To qualify, the abstract state must appear with simple option | |
1648 | -- "Relaxed_Initialization" (SPARK RM 6.10). | |
1649 | ||
1650 | return | |
1651 | Ekind (Id) = E_Abstract_State | |
1652 | and then Has_Option (Id, Name_Relaxed_Initialization); | |
1653 | end Is_Relaxed_Initialization_State; | |
1654 | ||
1655 | -------------------------------- | |
1656 | -- Is_Standard_Character_Type -- | |
1657 | -------------------------------- | |
1658 | ||
1659 | function Is_Standard_Character_Type (Id : E) return B is | |
1660 | begin | |
1661 | return Is_Type (Id) | |
1662 | and then Root_Type (Id) in Standard_Character | |
1663 | | Standard_Wide_Character | |
1664 | | Standard_Wide_Wide_Character; | |
1665 | end Is_Standard_Character_Type; | |
1666 | ||
1667 | ----------------------------- | |
1668 | -- Is_Standard_String_Type -- | |
1669 | ----------------------------- | |
1670 | ||
1671 | function Is_Standard_String_Type (Id : E) return B is | |
1672 | begin | |
1673 | return Is_Type (Id) | |
1674 | and then Root_Type (Id) in Standard_String | |
1675 | | Standard_Wide_String | |
1676 | | Standard_Wide_Wide_String; | |
1677 | end Is_Standard_String_Type; | |
1678 | ||
1679 | -------------------- | |
1680 | -- Is_String_Type -- | |
1681 | -------------------- | |
1682 | ||
1683 | function Is_String_Type (Id : E) return B is | |
1684 | begin | |
1685 | return Is_Array_Type (Id) | |
1686 | and then Id /= Any_Composite | |
1687 | and then Number_Dimensions (Id) = 1 | |
1688 | and then Is_Character_Type (Component_Type (Id)); | |
1689 | end Is_String_Type; | |
1690 | ||
1691 | ------------------------------- | |
1692 | -- Is_Synchronized_Interface -- | |
1693 | ------------------------------- | |
1694 | ||
1695 | function Is_Synchronized_Interface (Id : E) return B is | |
1696 | Typ : constant Entity_Id := Base_Type (Id); | |
1697 | ||
1698 | begin | |
1699 | if not Is_Interface (Typ) then | |
1700 | return False; | |
1701 | ||
1702 | elsif Is_Class_Wide_Type (Typ) then | |
1703 | return Is_Synchronized_Interface (Etype (Typ)); | |
1704 | ||
1705 | else | |
1706 | return Protected_Present (Type_Definition (Parent (Typ))) | |
1707 | or else Synchronized_Present (Type_Definition (Parent (Typ))) | |
1708 | or else Task_Present (Type_Definition (Parent (Typ))); | |
1709 | end if; | |
1710 | end Is_Synchronized_Interface; | |
1711 | ||
1712 | --------------------------- | |
1713 | -- Is_Synchronized_State -- | |
1714 | --------------------------- | |
1715 | ||
1716 | function Is_Synchronized_State (Id : E) return B is | |
1717 | begin | |
1718 | -- To qualify, the abstract state must appear with simple option | |
1719 | -- "synchronous" (SPARK RM 7.1.4(9)). | |
1720 | ||
1721 | return | |
1722 | Ekind (Id) = E_Abstract_State | |
1723 | and then Has_Option (Id, Name_Synchronous); | |
1724 | end Is_Synchronized_State; | |
1725 | ||
1726 | ----------------------- | |
1727 | -- Is_Task_Interface -- | |
1728 | ----------------------- | |
1729 | ||
1730 | function Is_Task_Interface (Id : E) return B is | |
1731 | Typ : constant Entity_Id := Base_Type (Id); | |
1732 | begin | |
1733 | if not Is_Interface (Typ) then | |
1734 | return False; | |
1735 | elsif Is_Class_Wide_Type (Typ) then | |
1736 | return Is_Task_Interface (Etype (Typ)); | |
1737 | else | |
1738 | return Task_Present (Type_Definition (Parent (Typ))); | |
1739 | end if; | |
1740 | end Is_Task_Interface; | |
1741 | ||
1742 | ------------------------- | |
1743 | -- Is_Task_Record_Type -- | |
1744 | ------------------------- | |
1745 | ||
1746 | function Is_Task_Record_Type (Id : E) return B is | |
1747 | begin | |
1748 | return | |
1749 | Is_Concurrent_Record_Type (Id) | |
1750 | and then Is_Task_Type (Corresponding_Concurrent_Type (Id)); | |
1751 | end Is_Task_Record_Type; | |
1752 | ||
1753 | ------------------------ | |
1754 | -- Is_Wrapper_Package -- | |
1755 | ------------------------ | |
1756 | ||
1757 | function Is_Wrapper_Package (Id : E) return B is | |
1758 | begin | |
1759 | return Ekind (Id) = E_Package and then Present (Related_Instance (Id)); | |
1760 | end Is_Wrapper_Package; | |
1761 | ||
1762 | ----------------- | |
1763 | -- Last_Formal -- | |
1764 | ----------------- | |
1765 | ||
1766 | function Last_Formal (Id : E) return E is | |
1767 | Formal : Entity_Id; | |
1768 | ||
1769 | begin | |
1770 | pragma Assert | |
1771 | (Is_Overloadable (Id) | |
1772 | or else Ekind (Id) in E_Entry_Family | |
1773 | | E_Subprogram_Body | |
1774 | | E_Subprogram_Type); | |
1775 | ||
1776 | if Ekind (Id) = E_Enumeration_Literal then | |
1777 | return Empty; | |
1778 | ||
1779 | else | |
1780 | Formal := First_Formal (Id); | |
1781 | ||
1782 | if Present (Formal) then | |
1783 | while Present (Next_Formal (Formal)) loop | |
1784 | Next_Formal (Formal); | |
1785 | end loop; | |
1786 | end if; | |
1787 | ||
1788 | return Formal; | |
1789 | end if; | |
1790 | end Last_Formal; | |
1791 | ||
1792 | ------------------- | |
1793 | -- Link_Entities -- | |
1794 | ------------------- | |
1795 | ||
1796 | procedure Link_Entities (First : Entity_Id; Second : Node_Id) is | |
1797 | begin | |
1798 | if Present (Second) then | |
1799 | Set_Prev_Entity (Second, First); -- First <-- Second | |
1800 | end if; | |
1801 | ||
1802 | Set_Next_Entity (First, Second); -- First --> Second | |
1803 | end Link_Entities; | |
1804 | ||
1805 | ------------------------ | |
1806 | -- Machine_Emax_Value -- | |
1807 | ------------------------ | |
1808 | ||
1809 | function Machine_Emax_Value (Id : E) return Uint is | |
1810 | Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id))); | |
1811 | ||
1812 | begin | |
1813 | case Float_Rep (Id) is | |
1814 | when IEEE_Binary => | |
1815 | case Digs is | |
1816 | when 1 .. 6 => return Uint_128; | |
1817 | when 7 .. 15 => return 2**10; | |
1818 | when 16 .. 33 => return 2**14; | |
1819 | when others => return No_Uint; | |
1820 | end case; | |
76f9c7f4 BD |
1821 | end case; |
1822 | end Machine_Emax_Value; | |
1823 | ||
1824 | ------------------------ | |
1825 | -- Machine_Emin_Value -- | |
1826 | ------------------------ | |
1827 | ||
1828 | function Machine_Emin_Value (Id : E) return Uint is | |
1829 | begin | |
1830 | case Float_Rep (Id) is | |
1831 | when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id); | |
76f9c7f4 BD |
1832 | end case; |
1833 | end Machine_Emin_Value; | |
1834 | ||
1835 | ---------------------------- | |
1836 | -- Machine_Mantissa_Value -- | |
1837 | ---------------------------- | |
1838 | ||
1839 | function Machine_Mantissa_Value (Id : E) return Uint is | |
1840 | Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id))); | |
1841 | ||
1842 | begin | |
1843 | case Float_Rep (Id) is | |
1844 | when IEEE_Binary => | |
1845 | case Digs is | |
1846 | when 1 .. 6 => return Uint_24; | |
1847 | when 7 .. 15 => return UI_From_Int (53); | |
1848 | when 16 .. 18 => return Uint_64; | |
1849 | when 19 .. 33 => return UI_From_Int (113); | |
1850 | when others => return No_Uint; | |
1851 | end case; | |
76f9c7f4 BD |
1852 | end case; |
1853 | end Machine_Mantissa_Value; | |
1854 | ||
1855 | ------------------------- | |
1856 | -- Machine_Radix_Value -- | |
1857 | ------------------------- | |
1858 | ||
1859 | function Machine_Radix_Value (Id : E) return U is | |
1860 | begin | |
1861 | case Float_Rep (Id) is | |
9324e07d | 1862 | when IEEE_Binary => |
76f9c7f4 BD |
1863 | return Uint_2; |
1864 | end case; | |
1865 | end Machine_Radix_Value; | |
1866 | ||
1867 | ---------------------- | |
1868 | -- Model_Emin_Value -- | |
1869 | ---------------------- | |
1870 | ||
1871 | function Model_Emin_Value (Id : E) return Uint is | |
1872 | begin | |
1873 | return Machine_Emin_Value (Id); | |
1874 | end Model_Emin_Value; | |
1875 | ||
1876 | ------------------------- | |
1877 | -- Model_Epsilon_Value -- | |
1878 | ------------------------- | |
1879 | ||
1880 | function Model_Epsilon_Value (Id : E) return Ureal is | |
1881 | Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id)); | |
1882 | begin | |
1883 | return Radix ** (1 - Model_Mantissa_Value (Id)); | |
1884 | end Model_Epsilon_Value; | |
1885 | ||
1886 | -------------------------- | |
1887 | -- Model_Mantissa_Value -- | |
1888 | -------------------------- | |
1889 | ||
1890 | function Model_Mantissa_Value (Id : E) return Uint is | |
1891 | begin | |
1892 | return Machine_Mantissa_Value (Id); | |
1893 | end Model_Mantissa_Value; | |
1894 | ||
1895 | ----------------------- | |
1896 | -- Model_Small_Value -- | |
1897 | ----------------------- | |
1898 | ||
1899 | function Model_Small_Value (Id : E) return Ureal is | |
1900 | Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id)); | |
1901 | begin | |
1902 | return Radix ** (Model_Emin_Value (Id) - 1); | |
1903 | end Model_Small_Value; | |
1904 | ||
1905 | -------------------- | |
1906 | -- Next_Component -- | |
1907 | -------------------- | |
1908 | ||
1909 | function Next_Component (Id : E) return E is | |
1910 | Comp_Id : Entity_Id; | |
1911 | ||
1912 | begin | |
1913 | Comp_Id := Next_Entity (Id); | |
1914 | while Present (Comp_Id) loop | |
1915 | exit when Ekind (Comp_Id) = E_Component; | |
1916 | Next_Entity (Comp_Id); | |
1917 | end loop; | |
1918 | ||
1919 | return Comp_Id; | |
1920 | end Next_Component; | |
1921 | ||
1922 | ------------------------------------ | |
1923 | -- Next_Component_Or_Discriminant -- | |
1924 | ------------------------------------ | |
1925 | ||
1926 | function Next_Component_Or_Discriminant (Id : E) return E is | |
1927 | Comp_Id : Entity_Id; | |
1928 | ||
1929 | begin | |
1930 | Comp_Id := Next_Entity (Id); | |
1931 | while Present (Comp_Id) loop | |
1932 | exit when Ekind (Comp_Id) in E_Component | E_Discriminant; | |
1933 | Next_Entity (Comp_Id); | |
1934 | end loop; | |
1935 | ||
1936 | return Comp_Id; | |
1937 | end Next_Component_Or_Discriminant; | |
1938 | ||
1939 | ----------------------- | |
1940 | -- Next_Discriminant -- | |
1941 | ----------------------- | |
1942 | ||
1943 | -- This function actually implements both Next_Discriminant and | |
1944 | -- Next_Stored_Discriminant by making sure that the Discriminant | |
1945 | -- returned is of the same variety as Id. | |
1946 | ||
1947 | function Next_Discriminant (Id : E) return E is | |
1948 | ||
1949 | -- Derived Tagged types with private extensions look like this... | |
1950 | ||
1951 | -- E_Discriminant d1 | |
1952 | -- E_Discriminant d2 | |
1953 | -- E_Component _tag | |
1954 | -- E_Discriminant d1 | |
1955 | -- E_Discriminant d2 | |
1956 | -- ... | |
1957 | ||
1958 | -- so it is critical not to go past the leading discriminants | |
1959 | ||
1960 | D : E := Id; | |
1961 | ||
1962 | begin | |
1963 | pragma Assert (Ekind (Id) = E_Discriminant); | |
1964 | ||
1965 | loop | |
1966 | Next_Entity (D); | |
1967 | if No (D) | |
1968 | or else (Ekind (D) /= E_Discriminant | |
1969 | and then not Is_Itype (D)) | |
1970 | then | |
1971 | return Empty; | |
1972 | end if; | |
1973 | ||
1974 | exit when Ekind (D) = E_Discriminant | |
1975 | and then (Is_Completely_Hidden (D) = Is_Completely_Hidden (Id)); | |
1976 | end loop; | |
1977 | ||
1978 | return D; | |
1979 | end Next_Discriminant; | |
1980 | ||
1981 | ----------------- | |
1982 | -- Next_Formal -- | |
1983 | ----------------- | |
1984 | ||
1985 | function Next_Formal (Id : E) return E is | |
1986 | P : Entity_Id; | |
1987 | ||
1988 | begin | |
1989 | -- Follow the chain of declared entities as long as the kind of the | |
1990 | -- entity corresponds to a formal parameter. Skip internal entities | |
1991 | -- that may have been created for implicit subtypes, in the process | |
1992 | -- of analyzing default expressions. | |
1993 | ||
1994 | P := Id; | |
1995 | loop | |
1996 | Next_Entity (P); | |
1997 | ||
1998 | if No (P) or else Is_Formal (P) then | |
1999 | return P; | |
2000 | elsif not Is_Internal (P) then | |
2001 | return Empty; | |
2002 | end if; | |
2003 | end loop; | |
2004 | end Next_Formal; | |
2005 | ||
2006 | ----------------------------- | |
2007 | -- Next_Formal_With_Extras -- | |
2008 | ----------------------------- | |
2009 | ||
2010 | function Next_Formal_With_Extras (Id : E) return E is | |
2011 | begin | |
2012 | if Present (Extra_Formal (Id)) then | |
2013 | return Extra_Formal (Id); | |
2014 | else | |
2015 | return Next_Formal (Id); | |
2016 | end if; | |
2017 | end Next_Formal_With_Extras; | |
2018 | ||
2019 | ---------------- | |
2020 | -- Next_Index -- | |
2021 | ---------------- | |
2022 | ||
2023 | function Next_Index (Id : Node_Id) return Node_Id is | |
2024 | begin | |
2025 | return Next (Id); | |
2026 | end Next_Index; | |
2027 | ||
2028 | ------------------ | |
2029 | -- Next_Literal -- | |
2030 | ------------------ | |
2031 | ||
2032 | function Next_Literal (Id : E) return E is | |
2033 | begin | |
2034 | pragma Assert (Nkind (Id) in N_Entity); | |
2035 | return Next (Id); | |
2036 | end Next_Literal; | |
2037 | ||
2038 | ------------------------------ | |
2039 | -- Next_Stored_Discriminant -- | |
2040 | ------------------------------ | |
2041 | ||
2042 | function Next_Stored_Discriminant (Id : E) return E is | |
2043 | begin | |
2044 | -- See comment in Next_Discriminant | |
2045 | ||
2046 | return Next_Discriminant (Id); | |
2047 | end Next_Stored_Discriminant; | |
2048 | ||
2049 | ----------------------- | |
2050 | -- Number_Dimensions -- | |
2051 | ----------------------- | |
2052 | ||
2053 | function Number_Dimensions (Id : E) return Pos is | |
2054 | N : Int; | |
2055 | T : Node_Id; | |
2056 | ||
2057 | begin | |
2058 | if Ekind (Id) = E_String_Literal_Subtype then | |
2059 | return 1; | |
2060 | ||
2061 | else | |
2062 | N := 0; | |
2063 | T := First_Index (Id); | |
2064 | while Present (T) loop | |
2065 | N := N + 1; | |
2066 | Next_Index (T); | |
2067 | end loop; | |
2068 | ||
2069 | return N; | |
2070 | end if; | |
2071 | end Number_Dimensions; | |
2072 | ||
2073 | -------------------- | |
2074 | -- Number_Entries -- | |
2075 | -------------------- | |
2076 | ||
2077 | function Number_Entries (Id : E) return Nat is | |
2078 | N : Int; | |
2079 | Ent : Entity_Id; | |
2080 | ||
2081 | begin | |
2082 | pragma Assert (Is_Concurrent_Type (Id)); | |
2083 | ||
2084 | N := 0; | |
2085 | Ent := First_Entity (Id); | |
2086 | while Present (Ent) loop | |
2087 | if Is_Entry (Ent) then | |
2088 | N := N + 1; | |
2089 | end if; | |
2090 | ||
2091 | Next_Entity (Ent); | |
2092 | end loop; | |
2093 | ||
2094 | return N; | |
2095 | end Number_Entries; | |
2096 | ||
2097 | -------------------- | |
2098 | -- Number_Formals -- | |
2099 | -------------------- | |
2100 | ||
2101 | function Number_Formals (Id : E) return Pos is | |
2102 | N : Int; | |
2103 | Formal : Entity_Id; | |
2104 | ||
2105 | begin | |
2106 | N := 0; | |
2107 | Formal := First_Formal (Id); | |
2108 | while Present (Formal) loop | |
2109 | N := N + 1; | |
2110 | Next_Formal (Formal); | |
2111 | end loop; | |
2112 | ||
2113 | return N; | |
2114 | end Number_Formals; | |
2115 | ||
2116 | ------------------------ | |
2117 | -- Object_Size_Clause -- | |
2118 | ------------------------ | |
2119 | ||
2120 | function Object_Size_Clause (Id : E) return N is | |
2121 | begin | |
2122 | return Get_Attribute_Definition_Clause (Id, Attribute_Object_Size); | |
2123 | end Object_Size_Clause; | |
2124 | ||
2125 | -------------------- | |
2126 | -- Parameter_Mode -- | |
2127 | -------------------- | |
2128 | ||
2129 | function Parameter_Mode (Id : E) return Formal_Kind is | |
2130 | begin | |
2131 | return Ekind (Id); | |
2132 | end Parameter_Mode; | |
2133 | ||
2134 | ------------------- | |
2135 | -- DIC_Procedure -- | |
2136 | ------------------- | |
2137 | ||
2138 | function DIC_Procedure (Id : E) return E is | |
2139 | Subp_Elmt : Elmt_Id; | |
2140 | Subp_Id : Entity_Id; | |
2141 | Subps : Elist_Id; | |
2142 | ||
2143 | begin | |
2144 | pragma Assert (Is_Type (Id)); | |
2145 | ||
2146 | Subps := Subprograms_For_Type (Base_Type (Id)); | |
2147 | ||
2148 | if Present (Subps) then | |
2149 | Subp_Elmt := First_Elmt (Subps); | |
2150 | while Present (Subp_Elmt) loop | |
2151 | Subp_Id := Node (Subp_Elmt); | |
2152 | ||
2153 | -- Currently the flag Is_DIC_Procedure is set for both normal DIC | |
2154 | -- check procedures as well as for partial DIC check procedures, | |
2155 | -- and we don't have a flag for the partial procedures. | |
2156 | ||
2157 | if Is_DIC_Procedure (Subp_Id) | |
2158 | and then not Is_Partial_DIC_Procedure (Subp_Id) | |
2159 | then | |
2160 | return Subp_Id; | |
2161 | end if; | |
2162 | ||
2163 | Next_Elmt (Subp_Elmt); | |
2164 | end loop; | |
2165 | end if; | |
2166 | ||
2167 | return Empty; | |
2168 | end DIC_Procedure; | |
2169 | ||
2170 | function Partial_DIC_Procedure (Id : E) return E is | |
2171 | Subp_Elmt : Elmt_Id; | |
2172 | Subp_Id : Entity_Id; | |
2173 | Subps : Elist_Id; | |
2174 | ||
2175 | begin | |
2176 | pragma Assert (Is_Type (Id)); | |
2177 | ||
2178 | Subps := Subprograms_For_Type (Base_Type (Id)); | |
2179 | ||
2180 | if Present (Subps) then | |
2181 | Subp_Elmt := First_Elmt (Subps); | |
2182 | while Present (Subp_Elmt) loop | |
2183 | Subp_Id := Node (Subp_Elmt); | |
2184 | ||
2185 | if Is_Partial_DIC_Procedure (Subp_Id) then | |
2186 | return Subp_Id; | |
2187 | end if; | |
2188 | ||
2189 | Next_Elmt (Subp_Elmt); | |
2190 | end loop; | |
2191 | end if; | |
2192 | ||
2193 | return Empty; | |
2194 | end Partial_DIC_Procedure; | |
2195 | ||
2196 | function Is_Partial_DIC_Procedure (Id : E) return B is | |
2197 | Partial_DIC_Suffix : constant String := "Partial_DIC"; | |
2198 | DIC_Nam : constant String := Get_Name_String (Chars (Id)); | |
2199 | ||
2200 | begin | |
2201 | pragma Assert (Ekind (Id) in E_Function | E_Procedure); | |
2202 | ||
2203 | -- Instead of adding a new Entity_Id flag (which are in short supply), | |
2204 | -- we test the form of the subprogram name. When the node field and flag | |
2205 | -- situation is eased, this should be replaced with a flag. ??? | |
2206 | ||
2207 | if DIC_Nam'Length > Partial_DIC_Suffix'Length | |
2208 | and then | |
2209 | DIC_Nam | |
2210 | (DIC_Nam'Last - Partial_DIC_Suffix'Length + 1 .. DIC_Nam'Last) = | |
2211 | Partial_DIC_Suffix | |
2212 | then | |
2213 | return True; | |
2214 | else | |
2215 | return False; | |
2216 | end if; | |
2217 | end Is_Partial_DIC_Procedure; | |
2218 | ||
2219 | --------------------------------- | |
2220 | -- Partial_Invariant_Procedure -- | |
2221 | --------------------------------- | |
2222 | ||
2223 | function Partial_Invariant_Procedure (Id : E) return E is | |
2224 | Subp_Elmt : Elmt_Id; | |
2225 | Subp_Id : Entity_Id; | |
2226 | Subps : Elist_Id; | |
2227 | ||
2228 | begin | |
2229 | pragma Assert (Is_Type (Id)); | |
2230 | ||
2231 | Subps := Subprograms_For_Type (Base_Type (Id)); | |
2232 | ||
2233 | if Present (Subps) then | |
2234 | Subp_Elmt := First_Elmt (Subps); | |
2235 | while Present (Subp_Elmt) loop | |
2236 | Subp_Id := Node (Subp_Elmt); | |
2237 | ||
2238 | if Is_Partial_Invariant_Procedure (Subp_Id) then | |
2239 | return Subp_Id; | |
2240 | end if; | |
2241 | ||
2242 | Next_Elmt (Subp_Elmt); | |
2243 | end loop; | |
2244 | end if; | |
2245 | ||
2246 | return Empty; | |
2247 | end Partial_Invariant_Procedure; | |
2248 | ||
2249 | ------------------------------------- | |
2250 | -- Partial_Refinement_Constituents -- | |
2251 | ------------------------------------- | |
2252 | ||
2253 | function Partial_Refinement_Constituents (Id : E) return L is | |
2254 | Constits : Elist_Id := No_Elist; | |
2255 | ||
2256 | procedure Add_Usable_Constituents (Item : E); | |
2257 | -- Add global item Item and/or its constituents to list Constits when | |
2258 | -- they can be used in a global refinement within the current scope. The | |
2259 | -- criteria are: | |
2260 | -- 1) If Item is an abstract state with full refinement visible, add | |
2261 | -- its constituents. | |
2262 | -- 2) If Item is an abstract state with only partial refinement | |
2263 | -- visible, add both Item and its constituents. | |
2264 | -- 3) If Item is an abstract state without a visible refinement, add | |
2265 | -- it. | |
2266 | -- 4) If Id is not an abstract state, add it. | |
2267 | ||
2268 | procedure Add_Usable_Constituents (List : Elist_Id); | |
2269 | -- Apply Add_Usable_Constituents to every constituent in List | |
2270 | ||
2271 | ----------------------------- | |
2272 | -- Add_Usable_Constituents -- | |
2273 | ----------------------------- | |
2274 | ||
2275 | procedure Add_Usable_Constituents (Item : E) is | |
2276 | begin | |
2277 | if Ekind (Item) = E_Abstract_State then | |
2278 | if Has_Visible_Refinement (Item) then | |
2279 | Add_Usable_Constituents (Refinement_Constituents (Item)); | |
2280 | ||
2281 | elsif Has_Partial_Visible_Refinement (Item) then | |
2282 | Append_New_Elmt (Item, Constits); | |
2283 | Add_Usable_Constituents (Part_Of_Constituents (Item)); | |
2284 | ||
2285 | else | |
2286 | Append_New_Elmt (Item, Constits); | |
2287 | end if; | |
2288 | ||
2289 | else | |
2290 | Append_New_Elmt (Item, Constits); | |
2291 | end if; | |
2292 | end Add_Usable_Constituents; | |
2293 | ||
2294 | procedure Add_Usable_Constituents (List : Elist_Id) is | |
2295 | Constit_Elmt : Elmt_Id; | |
2296 | begin | |
2297 | if Present (List) then | |
2298 | Constit_Elmt := First_Elmt (List); | |
2299 | while Present (Constit_Elmt) loop | |
2300 | Add_Usable_Constituents (Node (Constit_Elmt)); | |
2301 | Next_Elmt (Constit_Elmt); | |
2302 | end loop; | |
2303 | end if; | |
2304 | end Add_Usable_Constituents; | |
2305 | ||
2306 | -- Start of processing for Partial_Refinement_Constituents | |
2307 | ||
2308 | begin | |
2309 | -- "Refinement" is a concept applicable only to abstract states | |
2310 | ||
2311 | pragma Assert (Ekind (Id) = E_Abstract_State); | |
2312 | ||
2313 | if Has_Visible_Refinement (Id) then | |
2314 | Constits := Refinement_Constituents (Id); | |
2315 | ||
2316 | -- A refinement may be partially visible when objects declared in the | |
2317 | -- private part of a package are subject to a Part_Of indicator. | |
2318 | ||
2319 | elsif Has_Partial_Visible_Refinement (Id) then | |
2320 | Add_Usable_Constituents (Part_Of_Constituents (Id)); | |
2321 | ||
2322 | -- Function should only be called when full or partial refinement is | |
2323 | -- visible. | |
2324 | ||
2325 | else | |
2326 | raise Program_Error; | |
2327 | end if; | |
2328 | ||
2329 | return Constits; | |
2330 | end Partial_Refinement_Constituents; | |
2331 | ||
2332 | ------------------------ | |
2333 | -- Predicate_Function -- | |
2334 | ------------------------ | |
2335 | ||
2336 | function Predicate_Function (Id : E) return E is | |
2337 | Subp_Elmt : Elmt_Id; | |
2338 | Subp_Id : Entity_Id; | |
2339 | Subps : Elist_Id; | |
2340 | Typ : Entity_Id; | |
2341 | ||
2342 | begin | |
2343 | pragma Assert (Is_Type (Id)); | |
2344 | ||
2345 | -- If type is private and has a completion, predicate may be defined on | |
2346 | -- the full view. | |
2347 | ||
2348 | if Is_Private_Type (Id) | |
2349 | and then | |
2350 | (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id))) | |
2351 | and then Present (Full_View (Id)) | |
2352 | then | |
2353 | Typ := Full_View (Id); | |
2354 | ||
2355 | elsif Ekind (Id) in E_Array_Subtype | |
2356 | | E_Record_Subtype | |
2357 | | E_Record_Subtype_With_Private | |
2358 | and then Present (Predicated_Parent (Id)) | |
2359 | then | |
2360 | Typ := Predicated_Parent (Id); | |
2361 | ||
2362 | else | |
2363 | Typ := Id; | |
2364 | end if; | |
2365 | ||
2366 | Subps := Subprograms_For_Type (Typ); | |
2367 | ||
2368 | if Present (Subps) then | |
2369 | Subp_Elmt := First_Elmt (Subps); | |
2370 | while Present (Subp_Elmt) loop | |
2371 | Subp_Id := Node (Subp_Elmt); | |
2372 | ||
2373 | if Ekind (Subp_Id) = E_Function | |
2374 | and then Is_Predicate_Function (Subp_Id) | |
2375 | then | |
2376 | return Subp_Id; | |
2377 | end if; | |
2378 | ||
2379 | Next_Elmt (Subp_Elmt); | |
2380 | end loop; | |
2381 | end if; | |
2382 | ||
2383 | return Empty; | |
2384 | end Predicate_Function; | |
2385 | ||
2386 | -------------------------- | |
2387 | -- Predicate_Function_M -- | |
2388 | -------------------------- | |
2389 | ||
2390 | function Predicate_Function_M (Id : E) return E is | |
2391 | Subp_Elmt : Elmt_Id; | |
2392 | Subp_Id : Entity_Id; | |
2393 | Subps : Elist_Id; | |
2394 | Typ : Entity_Id; | |
2395 | ||
2396 | begin | |
2397 | pragma Assert (Is_Type (Id)); | |
2398 | ||
2399 | -- If type is private and has a completion, predicate may be defined on | |
2400 | -- the full view. | |
2401 | ||
2402 | if Is_Private_Type (Id) | |
2403 | and then | |
2404 | (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id))) | |
2405 | and then Present (Full_View (Id)) | |
2406 | then | |
2407 | Typ := Full_View (Id); | |
2408 | ||
2409 | else | |
2410 | Typ := Id; | |
2411 | end if; | |
2412 | ||
2413 | Subps := Subprograms_For_Type (Typ); | |
2414 | ||
2415 | if Present (Subps) then | |
2416 | Subp_Elmt := First_Elmt (Subps); | |
2417 | while Present (Subp_Elmt) loop | |
2418 | Subp_Id := Node (Subp_Elmt); | |
2419 | ||
2420 | if Ekind (Subp_Id) = E_Function | |
2421 | and then Is_Predicate_Function_M (Subp_Id) | |
2422 | then | |
2423 | return Subp_Id; | |
2424 | end if; | |
2425 | ||
2426 | Next_Elmt (Subp_Elmt); | |
2427 | end loop; | |
2428 | end if; | |
2429 | ||
2430 | return Empty; | |
2431 | end Predicate_Function_M; | |
2432 | ||
2433 | ------------------------- | |
2434 | -- Present_In_Rep_Item -- | |
2435 | ------------------------- | |
2436 | ||
2437 | function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is | |
2438 | Ritem : Node_Id; | |
2439 | ||
2440 | begin | |
2441 | Ritem := First_Rep_Item (E); | |
2442 | ||
2443 | while Present (Ritem) loop | |
2444 | if Ritem = N then | |
2445 | return True; | |
2446 | end if; | |
2447 | ||
2448 | Next_Rep_Item (Ritem); | |
2449 | end loop; | |
2450 | ||
2451 | return False; | |
2452 | end Present_In_Rep_Item; | |
2453 | ||
2454 | -------------------------- | |
2455 | -- Primitive_Operations -- | |
2456 | -------------------------- | |
2457 | ||
2458 | function Primitive_Operations (Id : E) return L is | |
2459 | begin | |
2460 | if Is_Concurrent_Type (Id) then | |
2461 | if Present (Corresponding_Record_Type (Id)) then | |
2462 | return Direct_Primitive_Operations | |
2463 | (Corresponding_Record_Type (Id)); | |
2464 | ||
2c03e97c GD |
2465 | -- When expansion is disabled, the corresponding record type is |
2466 | -- absent, but if this is a tagged type with ancestors, or if the | |
2467 | -- extension of prefixed calls for untagged types is enabled, then | |
2468 | -- it may have associated primitive operations. | |
76f9c7f4 BD |
2469 | |
2470 | else | |
2c03e97c | 2471 | return Direct_Primitive_Operations (Id); |
76f9c7f4 | 2472 | end if; |
2c03e97c | 2473 | |
76f9c7f4 BD |
2474 | else |
2475 | return Direct_Primitive_Operations (Id); | |
2476 | end if; | |
2477 | end Primitive_Operations; | |
2478 | ||
2479 | --------------------- | |
2480 | -- Record_Rep_Item -- | |
2481 | --------------------- | |
2482 | ||
2483 | procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is | |
2484 | begin | |
2485 | Set_Next_Rep_Item (N, First_Rep_Item (E)); | |
2486 | Set_First_Rep_Item (E, N); | |
2487 | end Record_Rep_Item; | |
2488 | ||
2489 | ------------------- | |
2490 | -- Remove_Entity -- | |
2491 | ------------------- | |
2492 | ||
2493 | procedure Remove_Entity (Id : Entity_Id) is | |
2494 | Next : constant Entity_Id := Next_Entity (Id); | |
2495 | Prev : constant Entity_Id := Prev_Entity (Id); | |
2496 | Scop : constant Entity_Id := Scope (Id); | |
2497 | First : constant Entity_Id := First_Entity (Scop); | |
2498 | Last : constant Entity_Id := Last_Entity (Scop); | |
2499 | ||
2500 | begin | |
2501 | -- Eliminate any existing linkages from the entity | |
2502 | ||
2503 | Set_Prev_Entity (Id, Empty); -- Empty <-- Id | |
2504 | Set_Next_Entity (Id, Empty); -- Id --> Empty | |
2505 | ||
2506 | -- The eliminated entity was the only element in the entity chain | |
2507 | ||
2508 | if Id = First and then Id = Last then | |
2509 | Set_First_Entity (Scop, Empty); | |
2510 | Set_Last_Entity (Scop, Empty); | |
2511 | ||
2512 | -- The eliminated entity was the head of the entity chain | |
2513 | ||
2514 | elsif Id = First then | |
2515 | Set_First_Entity (Scop, Next); | |
2516 | ||
2517 | -- The eliminated entity was the tail of the entity chain | |
2518 | ||
2519 | elsif Id = Last then | |
2520 | Set_Last_Entity (Scop, Prev); | |
2521 | ||
2522 | -- Otherwise the eliminated entity comes from the middle of the entity | |
2523 | -- chain. | |
2524 | ||
2525 | else | |
2526 | Link_Entities (Prev, Next); -- Prev <-- Next, Prev --> Next | |
2527 | end if; | |
2528 | end Remove_Entity; | |
2529 | ||
2530 | --------------- | |
2531 | -- Root_Type -- | |
2532 | --------------- | |
2533 | ||
2534 | function Root_Type (Id : E) return E is | |
2535 | T, Etyp : Entity_Id; | |
2536 | ||
2537 | begin | |
2538 | pragma Assert (Nkind (Id) in N_Entity); | |
2539 | ||
2540 | T := Base_Type (Id); | |
2541 | ||
2542 | if Ekind (T) = E_Class_Wide_Type then | |
2543 | return Etype (T); | |
2544 | ||
2545 | -- Other cases | |
2546 | ||
2547 | else | |
2548 | loop | |
2549 | Etyp := Etype (T); | |
2550 | ||
2551 | if T = Etyp then | |
2552 | return T; | |
2553 | ||
2554 | -- Following test catches some error cases resulting from | |
2555 | -- previous errors. | |
2556 | ||
2557 | elsif No (Etyp) then | |
2558 | Check_Error_Detected; | |
2559 | return T; | |
2560 | ||
2561 | elsif Is_Private_Type (T) and then Etyp = Full_View (T) then | |
2562 | return T; | |
2563 | ||
2564 | elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then | |
2565 | return T; | |
2566 | end if; | |
2567 | ||
2568 | T := Etyp; | |
2569 | ||
2570 | -- Return if there is a circularity in the inheritance chain. This | |
2571 | -- happens in some error situations and we do not want to get | |
2572 | -- stuck in this loop. | |
2573 | ||
2574 | if T = Base_Type (Id) then | |
2575 | return T; | |
2576 | end if; | |
2577 | end loop; | |
2578 | end if; | |
2579 | end Root_Type; | |
2580 | ||
2581 | --------------------- | |
2582 | -- Safe_Emax_Value -- | |
2583 | --------------------- | |
2584 | ||
2585 | function Safe_Emax_Value (Id : E) return Uint is | |
2586 | begin | |
2587 | return Machine_Emax_Value (Id); | |
2588 | end Safe_Emax_Value; | |
2589 | ||
2590 | ---------------------- | |
2591 | -- Safe_First_Value -- | |
2592 | ---------------------- | |
2593 | ||
2594 | function Safe_First_Value (Id : E) return Ureal is | |
2595 | begin | |
2596 | return -Safe_Last_Value (Id); | |
2597 | end Safe_First_Value; | |
2598 | ||
2599 | --------------------- | |
2600 | -- Safe_Last_Value -- | |
2601 | --------------------- | |
2602 | ||
2603 | function Safe_Last_Value (Id : E) return Ureal is | |
2604 | Radix : constant Uint := Machine_Radix_Value (Id); | |
2605 | Mantissa : constant Uint := Machine_Mantissa_Value (Id); | |
2606 | Emax : constant Uint := Safe_Emax_Value (Id); | |
2607 | Significand : constant Uint := Radix ** Mantissa - 1; | |
2608 | Exponent : constant Uint := Emax - Mantissa; | |
2609 | ||
2610 | begin | |
2611 | if Radix = 2 then | |
2612 | return | |
2613 | UR_From_Components | |
2614 | (Num => Significand * 2 ** (Exponent mod 4), | |
2615 | Den => -Exponent / 4, | |
2616 | Rbase => 16); | |
2617 | else | |
2618 | return | |
2619 | UR_From_Components | |
2620 | (Num => Significand, | |
2621 | Den => -Exponent, | |
2622 | Rbase => 16); | |
2623 | end if; | |
2624 | end Safe_Last_Value; | |
2625 | ||
2626 | ----------------- | |
2627 | -- Scope_Depth -- | |
2628 | ----------------- | |
2629 | ||
2630 | function Scope_Depth (Id : E) return Uint is | |
2631 | Scop : Entity_Id; | |
2632 | ||
2633 | begin | |
2634 | Scop := Id; | |
2635 | while Is_Record_Type (Scop) loop | |
2636 | Scop := Scope (Scop); | |
2637 | end loop; | |
2638 | ||
2639 | return Scope_Depth_Value (Scop); | |
2640 | end Scope_Depth; | |
2641 | ||
2642 | --------------------- | |
2643 | -- Scope_Depth_Set -- | |
2644 | --------------------- | |
2645 | ||
2646 | function Scope_Depth_Set (Id : E) return B is | |
2647 | begin | |
2648 | return not Is_Record_Type (Id) | |
f54fb769 | 2649 | and then not Field_Is_Initial_Zero (Id, F_Scope_Depth_Value); |
76f9c7f4 BD |
2650 | -- We can't call Scope_Depth_Value here, because Empty is not a valid |
2651 | -- value of type Uint. | |
2652 | end Scope_Depth_Set; | |
2653 | ||
2654 | -------------------- | |
2655 | -- Set_Convention -- | |
2656 | -------------------- | |
2657 | ||
2658 | procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is | |
2659 | begin | |
2660 | Set_Basic_Convention (E, Val); | |
2661 | ||
a4613d9a | 2662 | if Ekind (E) in Access_Subprogram_Kind |
76f9c7f4 BD |
2663 | and then Has_Foreign_Convention (E) |
2664 | then | |
2665 | Set_Can_Use_Internal_Rep (E, False); | |
2666 | end if; | |
2667 | ||
2668 | -- If E is an object, including a component, and the type of E is an | |
2669 | -- anonymous access type with no convention set, then also set the | |
2670 | -- convention of the anonymous access type. We do not do this for | |
2671 | -- anonymous protected types, since protected types always have the | |
2672 | -- default convention. | |
2673 | ||
2674 | if Present (Etype (E)) | |
2675 | and then (Is_Object (E) | |
2676 | ||
2677 | -- Allow E_Void (happens for pragma Convention appearing | |
2678 | -- in the middle of a record applying to a component) | |
2679 | ||
2680 | or else Ekind (E) = E_Void) | |
2681 | then | |
2682 | declare | |
2683 | Typ : constant Entity_Id := Etype (E); | |
2684 | ||
2685 | begin | |
2686 | if Ekind (Typ) in E_Anonymous_Access_Type | |
2687 | | E_Anonymous_Access_Subprogram_Type | |
2688 | and then not Has_Convention_Pragma (Typ) | |
2689 | then | |
2690 | Set_Basic_Convention (Typ, Val); | |
2691 | Set_Has_Convention_Pragma (Typ); | |
2692 | ||
2693 | -- And for the access subprogram type, deal similarly with the | |
2694 | -- designated E_Subprogram_Type, which is always internal. | |
2695 | ||
2696 | if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then | |
2697 | declare | |
2698 | Dtype : constant Entity_Id := Designated_Type (Typ); | |
2699 | begin | |
2700 | if Ekind (Dtype) = E_Subprogram_Type | |
2701 | and then not Has_Convention_Pragma (Dtype) | |
2702 | then | |
2703 | Set_Basic_Convention (Dtype, Val); | |
2704 | Set_Has_Convention_Pragma (Dtype); | |
2705 | end if; | |
2706 | end; | |
2707 | end if; | |
2708 | end if; | |
2709 | end; | |
2710 | end if; | |
2711 | end Set_Convention; | |
2712 | ||
2713 | ----------------------- | |
2714 | -- Set_DIC_Procedure -- | |
2715 | ----------------------- | |
2716 | ||
2717 | procedure Set_DIC_Procedure (Id : E; V : E) is | |
2718 | Base_Typ : Entity_Id; | |
2719 | Subps : Elist_Id; | |
2720 | ||
2721 | begin | |
2722 | pragma Assert (Is_Type (Id)); | |
2723 | ||
2724 | Base_Typ := Base_Type (Id); | |
2725 | Subps := Subprograms_For_Type (Base_Typ); | |
2726 | ||
2727 | if No (Subps) then | |
2728 | Subps := New_Elmt_List; | |
2729 | Set_Subprograms_For_Type (Base_Typ, Subps); | |
2730 | end if; | |
2731 | ||
2732 | Prepend_Elmt (V, Subps); | |
2733 | end Set_DIC_Procedure; | |
2734 | ||
2735 | procedure Set_Partial_DIC_Procedure (Id : E; V : E) is | |
2736 | begin | |
2737 | Set_DIC_Procedure (Id, V); | |
2738 | end Set_Partial_DIC_Procedure; | |
2739 | ||
9324e07d BD |
2740 | ------------------- |
2741 | -- Set_Float_Rep -- | |
2742 | ------------------- | |
2743 | ||
2744 | procedure Set_Float_Rep | |
2745 | (Ignore_N : Entity_Id; Ignore_Val : Float_Rep_Kind) is | |
2746 | begin | |
2747 | pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last); | |
2748 | -- There is only one value, so we don't need to store it (see | |
2749 | -- types.ads). | |
2750 | end Set_Float_Rep; | |
2751 | ||
76f9c7f4 BD |
2752 | ----------------------------- |
2753 | -- Set_Invariant_Procedure -- | |
2754 | ----------------------------- | |
2755 | ||
2756 | procedure Set_Invariant_Procedure (Id : E; V : E) is | |
2757 | Base_Typ : Entity_Id; | |
2758 | Subp_Elmt : Elmt_Id; | |
2759 | Subp_Id : Entity_Id; | |
2760 | Subps : Elist_Id; | |
2761 | ||
2762 | begin | |
2763 | pragma Assert (Is_Type (Id)); | |
2764 | ||
2765 | Base_Typ := Base_Type (Id); | |
2766 | Subps := Subprograms_For_Type (Base_Typ); | |
2767 | ||
2768 | if No (Subps) then | |
2769 | Subps := New_Elmt_List; | |
2770 | Set_Subprograms_For_Type (Base_Typ, Subps); | |
2771 | end if; | |
2772 | ||
2773 | Subp_Elmt := First_Elmt (Subps); | |
2774 | Prepend_Elmt (V, Subps); | |
2775 | ||
2776 | -- Check for a duplicate invariant procedure | |
2777 | ||
2778 | while Present (Subp_Elmt) loop | |
2779 | Subp_Id := Node (Subp_Elmt); | |
2780 | ||
2781 | if Is_Invariant_Procedure (Subp_Id) then | |
2782 | raise Program_Error; | |
2783 | end if; | |
2784 | ||
2785 | Next_Elmt (Subp_Elmt); | |
2786 | end loop; | |
2787 | end Set_Invariant_Procedure; | |
2788 | ||
2789 | ------------------------------------- | |
2790 | -- Set_Partial_Invariant_Procedure -- | |
2791 | ------------------------------------- | |
2792 | ||
2793 | procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is | |
2794 | Base_Typ : Entity_Id; | |
2795 | Subp_Elmt : Elmt_Id; | |
2796 | Subp_Id : Entity_Id; | |
2797 | Subps : Elist_Id; | |
2798 | ||
2799 | begin | |
2800 | pragma Assert (Is_Type (Id)); | |
2801 | ||
2802 | Base_Typ := Base_Type (Id); | |
2803 | Subps := Subprograms_For_Type (Base_Typ); | |
2804 | ||
2805 | if No (Subps) then | |
2806 | Subps := New_Elmt_List; | |
2807 | Set_Subprograms_For_Type (Base_Typ, Subps); | |
2808 | end if; | |
2809 | ||
2810 | Subp_Elmt := First_Elmt (Subps); | |
2811 | Prepend_Elmt (V, Subps); | |
2812 | ||
2813 | -- Check for a duplicate partial invariant procedure | |
2814 | ||
2815 | while Present (Subp_Elmt) loop | |
2816 | Subp_Id := Node (Subp_Elmt); | |
2817 | ||
2818 | if Is_Partial_Invariant_Procedure (Subp_Id) then | |
2819 | raise Program_Error; | |
2820 | end if; | |
2821 | ||
2822 | Next_Elmt (Subp_Elmt); | |
2823 | end loop; | |
2824 | end Set_Partial_Invariant_Procedure; | |
2825 | ||
2826 | ---------------------------- | |
2827 | -- Set_Predicate_Function -- | |
2828 | ---------------------------- | |
2829 | ||
2830 | procedure Set_Predicate_Function (Id : E; V : E) is | |
2831 | Subp_Elmt : Elmt_Id; | |
2832 | Subp_Id : Entity_Id; | |
2833 | Subps : Elist_Id; | |
2834 | ||
2835 | begin | |
2836 | pragma Assert (Is_Type (Id) and then Has_Predicates (Id)); | |
2837 | ||
2838 | Subps := Subprograms_For_Type (Id); | |
2839 | ||
2840 | if No (Subps) then | |
2841 | Subps := New_Elmt_List; | |
2842 | Set_Subprograms_For_Type (Id, Subps); | |
2843 | end if; | |
2844 | ||
2845 | Subp_Elmt := First_Elmt (Subps); | |
2846 | Prepend_Elmt (V, Subps); | |
2847 | ||
2848 | -- Check for a duplicate predication function | |
2849 | ||
2850 | while Present (Subp_Elmt) loop | |
2851 | Subp_Id := Node (Subp_Elmt); | |
2852 | ||
2853 | if Ekind (Subp_Id) = E_Function | |
2854 | and then Is_Predicate_Function (Subp_Id) | |
2855 | then | |
2856 | raise Program_Error; | |
2857 | end if; | |
2858 | ||
2859 | Next_Elmt (Subp_Elmt); | |
2860 | end loop; | |
2861 | end Set_Predicate_Function; | |
2862 | ||
2863 | ------------------------------ | |
2864 | -- Set_Predicate_Function_M -- | |
2865 | ------------------------------ | |
2866 | ||
2867 | procedure Set_Predicate_Function_M (Id : E; V : E) is | |
2868 | Subp_Elmt : Elmt_Id; | |
2869 | Subp_Id : Entity_Id; | |
2870 | Subps : Elist_Id; | |
2871 | ||
2872 | begin | |
2873 | pragma Assert (Is_Type (Id) and then Has_Predicates (Id)); | |
2874 | ||
2875 | Subps := Subprograms_For_Type (Id); | |
2876 | ||
2877 | if No (Subps) then | |
2878 | Subps := New_Elmt_List; | |
2879 | Set_Subprograms_For_Type (Id, Subps); | |
2880 | end if; | |
2881 | ||
2882 | Subp_Elmt := First_Elmt (Subps); | |
2883 | Prepend_Elmt (V, Subps); | |
2884 | ||
2885 | -- Check for a duplicate predication function | |
2886 | ||
2887 | while Present (Subp_Elmt) loop | |
2888 | Subp_Id := Node (Subp_Elmt); | |
2889 | ||
2890 | if Ekind (Subp_Id) = E_Function | |
2891 | and then Is_Predicate_Function_M (Subp_Id) | |
2892 | then | |
2893 | raise Program_Error; | |
2894 | end if; | |
2895 | ||
2896 | Next_Elmt (Subp_Elmt); | |
2897 | end loop; | |
2898 | end Set_Predicate_Function_M; | |
2899 | ||
2900 | ----------------- | |
2901 | -- Size_Clause -- | |
2902 | ----------------- | |
2903 | ||
2904 | function Size_Clause (Id : E) return N is | |
a547eea2 | 2905 | Result : N := Get_Attribute_Definition_Clause (Id, Attribute_Size); |
76f9c7f4 | 2906 | begin |
a547eea2 BD |
2907 | if No (Result) then |
2908 | Result := Get_Attribute_Definition_Clause (Id, Attribute_Value_Size); | |
2909 | end if; | |
2910 | ||
2911 | return Result; | |
76f9c7f4 BD |
2912 | end Size_Clause; |
2913 | ||
2914 | ------------------------ | |
2915 | -- Stream_Size_Clause -- | |
2916 | ------------------------ | |
2917 | ||
2918 | function Stream_Size_Clause (Id : E) return N is | |
2919 | begin | |
2920 | return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size); | |
2921 | end Stream_Size_Clause; | |
2922 | ||
2923 | ------------------ | |
2924 | -- Subtype_Kind -- | |
2925 | ------------------ | |
2926 | ||
2927 | function Subtype_Kind (K : Entity_Kind) return Entity_Kind is | |
2928 | Kind : Entity_Kind; | |
2929 | ||
2930 | begin | |
2931 | case K is | |
2932 | when Access_Kind => | |
2933 | Kind := E_Access_Subtype; | |
2934 | ||
2935 | when E_Array_Subtype | |
2936 | | E_Array_Type | |
2937 | => | |
2938 | Kind := E_Array_Subtype; | |
2939 | ||
2940 | when E_Class_Wide_Subtype | |
2941 | | E_Class_Wide_Type | |
2942 | => | |
2943 | Kind := E_Class_Wide_Subtype; | |
2944 | ||
2945 | when E_Decimal_Fixed_Point_Subtype | |
2946 | | E_Decimal_Fixed_Point_Type | |
2947 | => | |
2948 | Kind := E_Decimal_Fixed_Point_Subtype; | |
2949 | ||
2950 | when E_Ordinary_Fixed_Point_Subtype | |
2951 | | E_Ordinary_Fixed_Point_Type | |
2952 | => | |
2953 | Kind := E_Ordinary_Fixed_Point_Subtype; | |
2954 | ||
2955 | when E_Private_Subtype | |
2956 | | E_Private_Type | |
2957 | => | |
2958 | Kind := E_Private_Subtype; | |
2959 | ||
2960 | when E_Limited_Private_Subtype | |
2961 | | E_Limited_Private_Type | |
2962 | => | |
2963 | Kind := E_Limited_Private_Subtype; | |
2964 | ||
2965 | when E_Record_Subtype_With_Private | |
2966 | | E_Record_Type_With_Private | |
2967 | => | |
2968 | Kind := E_Record_Subtype_With_Private; | |
2969 | ||
2970 | when E_Record_Subtype | |
2971 | | E_Record_Type | |
2972 | => | |
2973 | Kind := E_Record_Subtype; | |
2974 | ||
2975 | when Enumeration_Kind => | |
2976 | Kind := E_Enumeration_Subtype; | |
2977 | ||
2978 | when E_Incomplete_Type => | |
2979 | Kind := E_Incomplete_Subtype; | |
2980 | ||
2981 | when Float_Kind => | |
2982 | Kind := E_Floating_Point_Subtype; | |
2983 | ||
2984 | when Signed_Integer_Kind => | |
2985 | Kind := E_Signed_Integer_Subtype; | |
2986 | ||
2987 | when Modular_Integer_Kind => | |
2988 | Kind := E_Modular_Integer_Subtype; | |
2989 | ||
2990 | when Protected_Kind => | |
2991 | Kind := E_Protected_Subtype; | |
2992 | ||
2993 | when Task_Kind => | |
2994 | Kind := E_Task_Subtype; | |
2995 | ||
2996 | when others => | |
2997 | raise Program_Error; | |
2998 | end case; | |
2999 | ||
3000 | return Kind; | |
3001 | end Subtype_Kind; | |
3002 | ||
3003 | --------------------- | |
3004 | -- Type_High_Bound -- | |
3005 | --------------------- | |
3006 | ||
3007 | function Type_High_Bound (Id : E) return Node_Id is | |
3008 | Rng : constant Node_Id := Scalar_Range (Id); | |
3009 | begin | |
3010 | if Nkind (Rng) = N_Subtype_Indication then | |
3011 | return High_Bound (Range_Expression (Constraint (Rng))); | |
3012 | else | |
3013 | return High_Bound (Rng); | |
3014 | end if; | |
3015 | end Type_High_Bound; | |
3016 | ||
3017 | -------------------- | |
3018 | -- Type_Low_Bound -- | |
3019 | -------------------- | |
3020 | ||
3021 | function Type_Low_Bound (Id : E) return Node_Id is | |
3022 | Rng : constant Node_Id := Scalar_Range (Id); | |
3023 | begin | |
3024 | if Nkind (Rng) = N_Subtype_Indication then | |
3025 | return Low_Bound (Range_Expression (Constraint (Rng))); | |
3026 | else | |
3027 | return Low_Bound (Rng); | |
3028 | end if; | |
3029 | end Type_Low_Bound; | |
3030 | ||
3031 | --------------------- | |
3032 | -- Underlying_Type -- | |
3033 | --------------------- | |
3034 | ||
3035 | function Underlying_Type (Id : E) return E is | |
3036 | begin | |
3037 | -- For record_with_private the underlying type is always the direct full | |
3038 | -- view. Never try to take the full view of the parent it does not make | |
3039 | -- sense. | |
3040 | ||
3041 | if Ekind (Id) = E_Record_Type_With_Private then | |
3042 | return Full_View (Id); | |
3043 | ||
3044 | -- If we have a class-wide type that comes from the limited view then we | |
3045 | -- return the Underlying_Type of its nonlimited view. | |
3046 | ||
3047 | elsif Ekind (Id) = E_Class_Wide_Type | |
3048 | and then From_Limited_With (Id) | |
3049 | and then Present (Non_Limited_View (Id)) | |
3050 | then | |
3051 | return Underlying_Type (Non_Limited_View (Id)); | |
3052 | ||
3053 | elsif Ekind (Id) in Incomplete_Or_Private_Kind then | |
3054 | ||
3055 | -- If we have an incomplete or private type with a full view, then we | |
3056 | -- return the Underlying_Type of this full view. | |
3057 | ||
3058 | if Present (Full_View (Id)) then | |
3059 | if Id = Full_View (Id) then | |
3060 | ||
3061 | -- Previous error in declaration | |
3062 | ||
3063 | return Empty; | |
3064 | ||
3065 | else | |
3066 | return Underlying_Type (Full_View (Id)); | |
3067 | end if; | |
3068 | ||
3069 | -- If we have a private type with an underlying full view, then we | |
3070 | -- return the Underlying_Type of this underlying full view. | |
3071 | ||
3072 | elsif Ekind (Id) in Private_Kind | |
3073 | and then Present (Underlying_Full_View (Id)) | |
3074 | then | |
3075 | return Underlying_Type (Underlying_Full_View (Id)); | |
3076 | ||
3077 | -- If we have an incomplete entity that comes from the limited view | |
3078 | -- then we return the Underlying_Type of its nonlimited view. | |
3079 | ||
3080 | elsif From_Limited_With (Id) | |
3081 | and then Present (Non_Limited_View (Id)) | |
3082 | then | |
3083 | return Underlying_Type (Non_Limited_View (Id)); | |
3084 | ||
3085 | -- Otherwise check for the case where we have a derived type or | |
3086 | -- subtype, and if so get the Underlying_Type of the parent type. | |
3087 | ||
3088 | elsif Etype (Id) /= Id then | |
3089 | return Underlying_Type (Etype (Id)); | |
3090 | ||
3091 | -- Otherwise we have an incomplete or private type that has no full | |
3092 | -- view, which means that we have not encountered the completion, so | |
3093 | -- return Empty to indicate the underlying type is not yet known. | |
3094 | ||
3095 | else | |
3096 | return Empty; | |
3097 | end if; | |
3098 | ||
3099 | -- For non-incomplete, non-private types, return the type itself. Also | |
3100 | -- for entities that are not types at all return the entity itself. | |
3101 | ||
3102 | else | |
3103 | return Id; | |
3104 | end if; | |
3105 | end Underlying_Type; | |
3106 | ||
3107 | ------------------------ | |
3108 | -- Unlink_Next_Entity -- | |
3109 | ------------------------ | |
3110 | ||
3111 | procedure Unlink_Next_Entity (Id : Entity_Id) is | |
3112 | Next : constant Entity_Id := Next_Entity (Id); | |
3113 | ||
3114 | begin | |
3115 | if Present (Next) then | |
3116 | Set_Prev_Entity (Next, Empty); -- Empty <-- Next | |
3117 | end if; | |
3118 | ||
3119 | Set_Next_Entity (Id, Empty); -- Id --> Empty | |
3120 | end Unlink_Next_Entity; | |
3121 | ||
3122 | ---------------------------------- | |
3123 | -- Is_Volatile, Set_Is_Volatile -- | |
3124 | ---------------------------------- | |
3125 | ||
3126 | function Is_Volatile (Id : E) return B is | |
3127 | begin | |
76f9c7f4 BD |
3128 | pragma Assert (Nkind (Id) in N_Entity); |
3129 | ||
3130 | if Is_Type (Id) then | |
3131 | return Is_Volatile_Type (Base_Type (Id)); | |
3132 | else | |
3133 | return Is_Volatile_Object (Id); | |
3134 | end if; | |
3135 | end Is_Volatile; | |
3136 | ||
3137 | procedure Set_Is_Volatile (Id : E; V : B := True) is | |
3138 | begin | |
3139 | pragma Assert (Nkind (Id) in N_Entity); | |
3140 | ||
3141 | if Is_Type (Id) then | |
3142 | Set_Is_Volatile_Type (Id, V); | |
3143 | else | |
3144 | Set_Is_Volatile_Object (Id, V); | |
3145 | end if; | |
3146 | end Set_Is_Volatile; | |
3147 | ||
3148 | ----------------------- | |
3149 | -- Write_Entity_Info -- | |
3150 | ----------------------- | |
3151 | ||
3152 | procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is | |
3153 | ||
3154 | procedure Write_Attribute (Which : String; Nam : E); | |
3155 | -- Write attribute value with given string name | |
3156 | ||
3157 | procedure Write_Kind (Id : Entity_Id); | |
3158 | -- Write Ekind field of entity | |
3159 | ||
3160 | --------------------- | |
3161 | -- Write_Attribute -- | |
3162 | --------------------- | |
3163 | ||
3164 | procedure Write_Attribute (Which : String; Nam : E) is | |
3165 | begin | |
3166 | Write_Str (Prefix); | |
3167 | Write_Str (Which); | |
3168 | Write_Int (Int (Nam)); | |
3169 | Write_Str (" "); | |
3170 | Write_Name (Chars (Nam)); | |
3171 | Write_Str (" "); | |
3172 | end Write_Attribute; | |
3173 | ||
3174 | ---------------- | |
3175 | -- Write_Kind -- | |
3176 | ---------------- | |
3177 | ||
3178 | procedure Write_Kind (Id : Entity_Id) is | |
3179 | K : constant String := Entity_Kind'Image (Ekind (Id)); | |
3180 | ||
3181 | begin | |
3182 | Write_Str (Prefix); | |
3183 | Write_Str (" Kind "); | |
3184 | ||
3185 | if Is_Type (Id) and then Is_Tagged_Type (Id) then | |
3186 | Write_Str ("TAGGED "); | |
3187 | end if; | |
3188 | ||
3189 | Write_Str (K (3 .. K'Length)); | |
3190 | Write_Str (" "); | |
3191 | ||
3192 | if Is_Type (Id) and then Depends_On_Private (Id) then | |
3193 | Write_Str ("Depends_On_Private "); | |
3194 | end if; | |
3195 | end Write_Kind; | |
3196 | ||
3197 | -- Start of processing for Write_Entity_Info | |
3198 | ||
3199 | begin | |
3200 | Write_Eol; | |
3201 | Write_Attribute ("Name ", Id); | |
3202 | Write_Int (Int (Id)); | |
3203 | Write_Eol; | |
3204 | Write_Kind (Id); | |
3205 | Write_Eol; | |
3206 | Write_Attribute (" Type ", Etype (Id)); | |
3207 | Write_Eol; | |
3208 | if Id /= Standard_Standard then | |
3209 | Write_Attribute (" Scope ", Scope (Id)); | |
3210 | end if; | |
3211 | Write_Eol; | |
3212 | ||
3213 | case Ekind (Id) is | |
3214 | when Discrete_Kind => | |
3215 | Write_Str ("Bounds: Id = "); | |
3216 | ||
3217 | if Present (Scalar_Range (Id)) then | |
3218 | Write_Int (Int (Type_Low_Bound (Id))); | |
3219 | Write_Str (" .. Id = "); | |
3220 | Write_Int (Int (Type_High_Bound (Id))); | |
3221 | else | |
3222 | Write_Str ("Empty"); | |
3223 | end if; | |
3224 | ||
3225 | Write_Eol; | |
3226 | ||
3227 | when Array_Kind => | |
3228 | declare | |
3229 | Index : Entity_Id; | |
3230 | ||
3231 | begin | |
3232 | Write_Attribute | |
3233 | (" Component Type ", Component_Type (Id)); | |
3234 | Write_Eol; | |
3235 | Write_Str (Prefix); | |
3236 | Write_Str (" Indexes "); | |
3237 | ||
3238 | Index := First_Index (Id); | |
3239 | while Present (Index) loop | |
3240 | Write_Attribute (" ", Etype (Index)); | |
3241 | Index := Next_Index (Index); | |
3242 | end loop; | |
3243 | ||
3244 | Write_Eol; | |
3245 | end; | |
3246 | ||
3247 | when Access_Kind => | |
3248 | Write_Attribute | |
3249 | (" Directly Designated Type ", | |
3250 | Directly_Designated_Type (Id)); | |
3251 | Write_Eol; | |
3252 | ||
3253 | when Overloadable_Kind => | |
3254 | if Present (Homonym (Id)) then | |
3255 | Write_Str (" Homonym "); | |
3256 | Write_Name (Chars (Homonym (Id))); | |
3257 | Write_Str (" "); | |
3258 | Write_Int (Int (Homonym (Id))); | |
3259 | Write_Eol; | |
3260 | end if; | |
3261 | ||
3262 | Write_Eol; | |
3263 | ||
3264 | when E_Component => | |
3265 | if Ekind (Scope (Id)) in Record_Kind then | |
3266 | Write_Attribute ( | |
3267 | " Original_Record_Component ", | |
3268 | Original_Record_Component (Id)); | |
3269 | Write_Int (Int (Original_Record_Component (Id))); | |
3270 | Write_Eol; | |
3271 | end if; | |
3272 | ||
3273 | when others => | |
3274 | null; | |
3275 | end case; | |
3276 | end Write_Entity_Info; | |
3277 | ||
3278 | ------------------------- | |
3279 | -- Iterator Procedures -- | |
3280 | ------------------------- | |
3281 | ||
3282 | procedure Proc_Next_Component (N : in out Node_Id) is | |
3283 | begin | |
3284 | N := Next_Component (N); | |
3285 | end Proc_Next_Component; | |
3286 | ||
3287 | procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is | |
3288 | begin | |
3289 | N := Next_Entity (N); | |
3290 | while Present (N) loop | |
3291 | exit when Ekind (N) in E_Component | E_Discriminant; | |
3292 | N := Next_Entity (N); | |
3293 | end loop; | |
3294 | end Proc_Next_Component_Or_Discriminant; | |
3295 | ||
3296 | procedure Proc_Next_Discriminant (N : in out Node_Id) is | |
3297 | begin | |
3298 | N := Next_Discriminant (N); | |
3299 | end Proc_Next_Discriminant; | |
3300 | ||
3301 | procedure Proc_Next_Formal (N : in out Node_Id) is | |
3302 | begin | |
3303 | N := Next_Formal (N); | |
3304 | end Proc_Next_Formal; | |
3305 | ||
3306 | procedure Proc_Next_Formal_With_Extras (N : in out Node_Id) is | |
3307 | begin | |
3308 | N := Next_Formal_With_Extras (N); | |
3309 | end Proc_Next_Formal_With_Extras; | |
3310 | ||
3311 | procedure Proc_Next_Index (N : in out Node_Id) is | |
3312 | begin | |
3313 | N := Next_Index (N); | |
3314 | end Proc_Next_Index; | |
3315 | ||
3316 | procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id) is | |
3317 | begin | |
3318 | N := Next_Inlined_Subprogram (N); | |
3319 | end Proc_Next_Inlined_Subprogram; | |
3320 | ||
3321 | procedure Proc_Next_Literal (N : in out Node_Id) is | |
3322 | begin | |
3323 | N := Next_Literal (N); | |
3324 | end Proc_Next_Literal; | |
3325 | ||
3326 | procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is | |
3327 | begin | |
3328 | N := Next_Stored_Discriminant (N); | |
3329 | end Proc_Next_Stored_Discriminant; | |
3330 | ||
3331 | end Einfo.Utils; |