1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- E I N F O . U T I L S --
9 -- Copyright (C) 2020-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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
.Utils
; use Sinfo
.Utils
;
33 package body Einfo
.Utils
is
35 -----------------------
36 -- Local subprograms --
37 -----------------------
40 (State_Id
: Entity_Id
;
41 Option_Nam
: Name_Id
) return Boolean;
42 -- Determine whether abstract state State_Id has particular option denoted
43 -- by the name Option_Nam.
45 -------------------------------------------
46 -- Aliases/Renamings of Renamed_Or_Alias --
47 -------------------------------------------
49 function Alias
(N
: Entity_Id
) return Entity_Id
is
51 return Val
: constant Entity_Id
:= Renamed_Or_Alias
(N
) do
53 (Is_Overloadable
(N
) or else Ekind
(N
) = E_Subprogram_Type
);
54 pragma Assert
(Val
in N_Entity_Id | N_Empty_Id
);
58 procedure Set_Alias
(N
: Entity_Id
; Val
: Entity_Id
) is
61 (Is_Overloadable
(N
) or else Ekind
(N
) = E_Subprogram_Type
);
62 pragma Assert
(Val
in N_Entity_Id | N_Empty_Id
);
64 Set_Renamed_Or_Alias
(N
, Val
);
67 function Renamed_Entity
(N
: Entity_Id
) return Entity_Id
is
69 return Val
: constant Entity_Id
:= Renamed_Or_Alias
(N
) do
70 pragma Assert
(not Is_Object
(N
) or else Etype
(N
) = Any_Type
);
71 pragma Assert
(Val
in N_Entity_Id | N_Empty_Id
);
75 procedure Set_Renamed_Entity
(N
: Entity_Id
; Val
: Entity_Id
) is
77 pragma Assert
(not Is_Object
(N
));
78 pragma Assert
(Val
in N_Entity_Id
);
80 Set_Renamed_Or_Alias
(N
, Val
);
81 end Set_Renamed_Entity
;
83 function Renamed_Object
(N
: Entity_Id
) return Node_Id
is
85 return Val
: constant Node_Id
:= Renamed_Or_Alias
(N
) do
86 -- Formal_Kind uses the entity, not a name of it. This happens
87 -- in front-end inlining, which also sets to Empty. Also in
88 -- Exp_Ch9, where formals are renamed for the benefit of gdb.
90 if Ekind
(N
) not in Formal_Kind
then
91 pragma Assert
(Is_Object
(N
));
92 pragma Assert
(Val
in N_Subexpr_Id | N_Empty_Id
);
98 procedure Set_Renamed_Object
(N
: Entity_Id
; Val
: Node_Id
) is
100 if Ekind
(N
) not in Formal_Kind
then
101 pragma Assert
(Is_Object
(N
));
102 pragma Assert
(Val
in N_Subexpr_Id | N_Empty_Id
);
106 Set_Renamed_Or_Alias
(N
, Val
);
107 end Set_Renamed_Object
;
109 function Renamed_Entity_Or_Object
(N
: Entity_Id
) return Node_Id
is
111 if Is_Object
(N
) then
112 return Renamed_Object
(N
);
114 return Renamed_Entity
(N
);
116 end Renamed_Entity_Or_Object
;
118 procedure Set_Renamed_Object_Of_Possibly_Void
119 (N
: Entity_Id
; Val
: Node_Id
)
122 pragma Assert
(Val
in N_Subexpr_Id
);
123 Set_Renamed_Or_Alias
(N
, Val
);
124 end Set_Renamed_Object_Of_Possibly_Void
;
131 (State_Id
: Entity_Id
;
132 Option_Nam
: Name_Id
) return Boolean
134 Decl
: constant Node_Id
:= Parent
(State_Id
);
139 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
141 -- The declaration of abstract states with options appear as an
142 -- extension aggregate. If this is not the case, the option is not
145 if Nkind
(Decl
) /= N_Extension_Aggregate
then
151 Opt
:= First
(Expressions
(Decl
));
152 while Present
(Opt
) loop
153 if Nkind
(Opt
) = N_Identifier
and then Chars
(Opt
) = Option_Nam
then
160 -- Complex options with various specifiers
162 Opt
:= First
(Component_Associations
(Decl
));
163 while Present
(Opt
) loop
164 Opt_Nam
:= First
(Choices
(Opt
));
166 if Nkind
(Opt_Nam
) = N_Identifier
167 and then Chars
(Opt_Nam
) = Option_Nam
178 ------------------------------
179 -- Classification Functions --
180 ------------------------------
182 function Is_Access_Object_Type
(Id
: E
) return B
is
184 return Is_Access_Type
(Id
)
185 and then Ekind
(Directly_Designated_Type
(Id
)) /= E_Subprogram_Type
;
186 end Is_Access_Object_Type
;
188 function Is_Access_Type
(Id
: E
) return B
is
190 return Ekind
(Id
) in Access_Kind
;
193 function Is_Access_Protected_Subprogram_Type
(Id
: E
) return B
is
195 return Ekind
(Id
) in Access_Protected_Kind
;
196 end Is_Access_Protected_Subprogram_Type
;
198 function Is_Access_Subprogram_Type
(Id
: E
) return B
is
200 return Is_Access_Type
(Id
)
201 and then Ekind
(Directly_Designated_Type
(Id
)) = E_Subprogram_Type
;
202 end Is_Access_Subprogram_Type
;
204 function Is_Address_Compatible_Type
(Id
: E
) return B
is
206 return Is_Descendant_Of_Address
(Id
) or else Id
= Standard_Address
;
207 end Is_Address_Compatible_Type
;
209 function Is_Aggregate_Type
(Id
: E
) return B
is
211 return Ekind
(Id
) in Aggregate_Kind
;
212 end Is_Aggregate_Type
;
214 function Is_Anonymous_Access_Type
(Id
: E
) return B
is
216 return Ekind
(Id
) in Anonymous_Access_Kind
;
217 end Is_Anonymous_Access_Type
;
219 function Is_Array_Type
(Id
: E
) return B
is
221 return Ekind
(Id
) in Array_Kind
;
224 function Is_Assignable
(Id
: E
) return B
is
226 return Ekind
(Id
) in Assignable_Kind
;
229 function Is_Class_Wide_Type
(Id
: E
) return B
is
231 return Ekind
(Id
) in Class_Wide_Kind
;
232 end Is_Class_Wide_Type
;
234 function Is_Composite_Type
(Id
: E
) return B
is
236 return Ekind
(Id
) in Composite_Kind
;
237 end Is_Composite_Type
;
239 function Is_Concurrent_Body
(Id
: E
) return B
is
241 return Ekind
(Id
) in Concurrent_Body_Kind
;
242 end Is_Concurrent_Body
;
244 function Is_Concurrent_Type
(Id
: E
) return B
is
246 return Ekind
(Id
) in Concurrent_Kind
;
247 end Is_Concurrent_Type
;
249 function Is_Decimal_Fixed_Point_Type
(Id
: E
) return B
is
251 return Ekind
(Id
) in Decimal_Fixed_Point_Kind
;
252 end Is_Decimal_Fixed_Point_Type
;
254 function Is_Digits_Type
(Id
: E
) return B
is
256 return Ekind
(Id
) in Digits_Kind
;
259 function Is_Discrete_Or_Fixed_Point_Type
(Id
: E
) return B
is
261 return Ekind
(Id
) in Discrete_Or_Fixed_Point_Kind
;
262 end Is_Discrete_Or_Fixed_Point_Type
;
264 function Is_Discrete_Type
(Id
: E
) return B
is
266 return Ekind
(Id
) in Discrete_Kind
;
267 end Is_Discrete_Type
;
269 function Is_Elementary_Type
(Id
: E
) return B
is
271 return Ekind
(Id
) in Elementary_Kind
;
272 end Is_Elementary_Type
;
274 function Is_Entry
(Id
: E
) return B
is
276 return Ekind
(Id
) in Entry_Kind
;
279 function Is_Enumeration_Type
(Id
: E
) return B
is
281 return Ekind
(Id
) in Enumeration_Kind
;
282 end Is_Enumeration_Type
;
284 function Is_Fixed_Point_Type
(Id
: E
) return B
is
286 return Ekind
(Id
) in Fixed_Point_Kind
;
287 end Is_Fixed_Point_Type
;
289 function Is_Floating_Point_Type
(Id
: E
) return B
is
291 return Ekind
(Id
) in Float_Kind
;
292 end Is_Floating_Point_Type
;
294 function Is_Formal
(Id
: E
) return B
is
296 return Ekind
(Id
) in Formal_Kind
;
299 function Is_Formal_Object
(Id
: E
) return B
is
301 return Ekind
(Id
) in Formal_Object_Kind
;
302 end Is_Formal_Object
;
304 function Is_Generic_Subprogram
(Id
: E
) return B
is
306 return Ekind
(Id
) in Generic_Subprogram_Kind
;
307 end Is_Generic_Subprogram
;
309 function Is_Generic_Unit
(Id
: E
) return B
is
311 return Ekind
(Id
) in Generic_Unit_Kind
;
314 function Is_Ghost_Entity
(Id
: E
) return Boolean is
316 return Is_Checked_Ghost_Entity
(Id
) or else Is_Ignored_Ghost_Entity
(Id
);
319 function Is_Incomplete_Or_Private_Type
(Id
: E
) return B
is
321 return Ekind
(Id
) in Incomplete_Or_Private_Kind
;
322 end Is_Incomplete_Or_Private_Type
;
324 function Is_Incomplete_Type
(Id
: E
) return B
is
326 return Ekind
(Id
) in Incomplete_Kind
;
327 end Is_Incomplete_Type
;
329 function Is_Integer_Type
(Id
: E
) return B
is
331 return Ekind
(Id
) in Integer_Kind
;
334 function Is_Modular_Integer_Type
(Id
: E
) return B
is
336 return Ekind
(Id
) in Modular_Integer_Kind
;
337 end Is_Modular_Integer_Type
;
339 function Is_Named_Access_Type
(Id
: E
) return B
is
341 return Ekind
(Id
) in Named_Access_Kind
;
342 end Is_Named_Access_Type
;
344 function Is_Named_Number
(Id
: E
) return B
is
346 return Ekind
(Id
) in Named_Kind
;
349 function Is_Numeric_Type
(Id
: E
) return B
is
351 return Ekind
(Id
) in Numeric_Kind
;
354 function Is_Object
(Id
: E
) return B
is
356 return Ekind
(Id
) in Object_Kind
;
359 function Is_Ordinary_Fixed_Point_Type
(Id
: E
) return B
is
361 return Ekind
(Id
) in Ordinary_Fixed_Point_Kind
;
362 end Is_Ordinary_Fixed_Point_Type
;
364 function Is_Overloadable
(Id
: E
) return B
is
366 return Ekind
(Id
) in Overloadable_Kind
;
369 function Is_Private_Type
(Id
: E
) return B
is
371 return Ekind
(Id
) in Private_Kind
;
374 function Is_Protected_Type
(Id
: E
) return B
is
376 return Ekind
(Id
) in Protected_Kind
;
377 end Is_Protected_Type
;
379 function Is_Real_Type
(Id
: E
) return B
is
381 return Ekind
(Id
) in Real_Kind
;
384 function Is_Record_Type
(Id
: E
) return B
is
386 return Ekind
(Id
) in Record_Kind
;
389 function Is_Scalar_Type
(Id
: E
) return B
is
391 return Ekind
(Id
) in Scalar_Kind
;
394 function Is_Signed_Integer_Type
(Id
: E
) return B
is
396 return Ekind
(Id
) in Signed_Integer_Kind
;
397 end Is_Signed_Integer_Type
;
399 function Is_Subprogram
(Id
: E
) return B
is
401 return Ekind
(Id
) in Subprogram_Kind
;
404 function Is_Subprogram_Or_Entry
(Id
: E
) return B
is
406 return Ekind
(Id
) in Subprogram_Kind
408 Ekind
(Id
) in Entry_Kind
;
409 end Is_Subprogram_Or_Entry
;
411 function Is_Subprogram_Or_Generic_Subprogram
(Id
: E
) return B
is
413 return Ekind
(Id
) in Subprogram_Kind
415 Ekind
(Id
) in Generic_Subprogram_Kind
;
416 end Is_Subprogram_Or_Generic_Subprogram
;
418 function Is_Task_Type
(Id
: E
) return B
is
420 return Ekind
(Id
) in Task_Kind
;
423 function Is_Type
(Id
: E
) return B
is
425 return Ekind
(Id
) in Type_Kind
;
428 ------------------------------------------
429 -- Type Representation Attribute Fields --
430 ------------------------------------------
432 function Known_Alignment
(E
: Entity_Id
) return B
is
434 -- For some reason, Empty is passed to this sometimes
436 return No
(E
) or else not Field_Is_Initial_Zero
(E
, F_Alignment
);
439 procedure Reinit_Alignment
(Id
: E
) is
441 Reinit_Field_To_Zero
(Id
, F_Alignment
);
442 end Reinit_Alignment
;
444 procedure Copy_Alignment
(To
, From
: E
) is
446 if Known_Alignment
(From
) then
447 Set_Alignment
(To
, Alignment
(From
));
449 Reinit_Alignment
(To
);
453 function Known_Component_Bit_Offset
(E
: Entity_Id
) return B
is
455 return Present
(Component_Bit_Offset
(E
));
456 end Known_Component_Bit_Offset
;
458 function Known_Static_Component_Bit_Offset
(E
: Entity_Id
) return B
is
460 return Known_Component_Bit_Offset
(E
)
461 and then Component_Bit_Offset
(E
) >= Uint_0
;
462 end Known_Static_Component_Bit_Offset
;
464 function Known_Component_Size
(E
: Entity_Id
) return B
is
466 return Present
(Component_Size
(E
));
467 end Known_Component_Size
;
469 function Known_Static_Component_Size
(E
: Entity_Id
) return B
is
471 return Known_Component_Size
(E
) and then Component_Size
(E
) >= Uint_0
;
472 end Known_Static_Component_Size
;
474 function Known_Esize
(E
: Entity_Id
) return B
is
476 return Present
(Esize
(E
));
479 function Known_Static_Esize
(E
: Entity_Id
) return B
is
481 return Known_Esize
(E
)
482 and then Esize
(E
) >= Uint_0
483 and then not Is_Generic_Type
(E
);
484 end Known_Static_Esize
;
486 procedure Reinit_Esize
(Id
: E
) is
488 Reinit_Field_To_Zero
(Id
, F_Esize
);
491 procedure Copy_Esize
(To
, From
: E
) is
493 if Known_Esize
(From
) then
494 Set_Esize
(To
, Esize
(From
));
500 function Known_Normalized_First_Bit
(E
: Entity_Id
) return B
is
502 return Present
(Normalized_First_Bit
(E
));
503 end Known_Normalized_First_Bit
;
505 function Known_Static_Normalized_First_Bit
(E
: Entity_Id
) return B
is
507 return Known_Normalized_First_Bit
(E
)
508 and then Normalized_First_Bit
(E
) >= Uint_0
;
509 end Known_Static_Normalized_First_Bit
;
511 function Known_Normalized_Position
(E
: Entity_Id
) return B
is
513 return Present
(Normalized_Position
(E
));
514 end Known_Normalized_Position
;
516 function Known_Static_Normalized_Position
(E
: Entity_Id
) return B
is
518 return Known_Normalized_Position
(E
)
519 and then Normalized_Position
(E
) >= Uint_0
;
520 end Known_Static_Normalized_Position
;
522 function Known_RM_Size
(E
: Entity_Id
) return B
is
524 return Present
(RM_Size
(E
));
527 function Known_Static_RM_Size
(E
: Entity_Id
) return B
is
529 return Known_RM_Size
(E
)
530 and then RM_Size
(E
) >= Uint_0
531 and then not Is_Generic_Type
(E
);
532 end Known_Static_RM_Size
;
534 procedure Reinit_RM_Size
(Id
: E
) is
536 Reinit_Field_To_Zero
(Id
, F_RM_Size
);
539 procedure Copy_RM_Size
(To
, From
: E
) is
541 if Known_RM_Size
(From
) then
542 Set_RM_Size
(To
, RM_Size
(From
));
548 -------------------------------
549 -- Reinit_Component_Location --
550 -------------------------------
552 procedure Reinit_Component_Location
(Id
: E
) is
554 Set_Normalized_First_Bit
(Id
, No_Uint
);
555 Set_Component_Bit_Offset
(Id
, No_Uint
);
557 Set_Normalized_Position
(Id
, No_Uint
);
558 end Reinit_Component_Location
;
560 ------------------------------
561 -- Reinit_Object_Size_Align --
562 ------------------------------
564 procedure Reinit_Object_Size_Align
(Id
: E
) is
567 Reinit_Alignment
(Id
);
568 end Reinit_Object_Size_Align
;
574 procedure Init_Size
(Id
: E
; V
: Int
) is
576 pragma Assert
(Is_Type
(Id
));
577 pragma Assert
(not Known_Esize
(Id
) or else Esize
(Id
) = V
);
578 pragma Assert
(not Known_RM_Size
(Id
) or else RM_Size
(Id
) = V
);
580 Set_Esize
(Id
, UI_From_Int
(V
));
581 Set_RM_Size
(Id
, UI_From_Int
(V
));
584 -----------------------
585 -- Reinit_Size_Align --
586 -----------------------
588 procedure Reinit_Size_Align
(Id
: E
) is
590 pragma Assert
(Ekind
(Id
) in Type_Kind | E_Void
);
593 Reinit_Alignment
(Id
);
594 end Reinit_Size_Align
;
600 function Address_Clause
(Id
: E
) return Node_Id
is
602 return Get_Attribute_Definition_Clause
(Id
, Attribute_Address
);
609 function Aft_Value
(Id
: E
) return U
is
611 Delta_Val
: Ureal
:= Delta_Value
(Id
);
613 while Delta_Val
< Ureal_Tenth
loop
614 Delta_Val
:= Delta_Val
* Ureal_10
;
615 Result
:= Result
+ 1;
618 return UI_From_Int
(Result
);
621 ----------------------
622 -- Alignment_Clause --
623 ----------------------
625 function Alignment_Clause
(Id
: E
) return Node_Id
is
627 return Get_Attribute_Definition_Clause
(Id
, Attribute_Alignment
);
628 end Alignment_Clause
;
634 procedure Append_Entity
(Id
: Entity_Id
; Scop
: Entity_Id
) is
635 Last
: constant Entity_Id
:= Last_Entity
(Scop
);
638 Set_Scope
(Id
, Scop
);
639 Set_Prev_Entity
(Id
, Empty
); -- Empty <-- Id
641 -- The entity chain is empty
644 Set_First_Entity
(Scop
, Id
);
646 -- Otherwise the entity chain has at least one element
649 Link_Entities
(Last
, Id
); -- Last <-- Id, Last --> Id
652 -- NOTE: The setting of the Next_Entity attribute of Id must happen
653 -- here as opposed to at the beginning of the routine because doing
654 -- so causes the binder to hang. It is not clear why ???
656 Set_Next_Entity
(Id
, Empty
); -- Id --> Empty
658 Set_Last_Entity
(Scop
, Id
);
665 function Base_Type
(Id
: E
) return E
is
667 if Is_Base_Type
(Id
) then
670 pragma Assert
(Is_Type
(Id
));
675 ----------------------
676 -- Declaration_Node --
677 ----------------------
679 function Declaration_Node
(Id
: E
) return Node_Id
is
683 if Ekind
(Id
) = E_Incomplete_Type
684 and then Present
(Full_View
(Id
))
686 P
:= Parent
(Full_View
(Id
));
691 while Nkind
(P
) in N_Selected_Component | N_Expanded_Name
692 or else (Nkind
(P
) = N_Defining_Program_Unit_Name
693 and then Is_Child_Unit
(Id
))
699 and then Nkind
(P
) not in
700 N_Full_Type_Declaration | N_Subtype_Declaration
705 -- Declarations are sometimes removed by replacing them with other
706 -- irrelevant nodes. For example, a declare expression can be turned
707 -- into a literal by constant folding. In these cases we want to
711 N_Assignment_Statement
713 | N_Procedure_Call_Statement
714 | N_Subtype_Indication
720 -- The following Assert indicates what kinds of nodes can be returned;
721 -- they are not all "declarations".
723 if Serious_Errors_Detected
= 0 then
725 (Nkind
(P
) in N_Is_Decl | N_Empty
,
726 "Declaration_Node incorrect kind: " & Node_Kind
'Image (Nkind
(P
)));
730 end Declaration_Node
;
732 ---------------------
733 -- Designated_Type --
734 ---------------------
736 function Designated_Type
(Id
: E
) return E
is
737 Desig_Type
: Entity_Id
;
740 Desig_Type
:= Directly_Designated_Type
(Id
);
742 if No
(Desig_Type
) then
743 pragma Assert
(Error_Posted
(Id
));
747 if Is_Incomplete_Type
(Desig_Type
)
748 and then Present
(Full_View
(Desig_Type
))
750 return Full_View
(Desig_Type
);
753 if Is_Class_Wide_Type
(Desig_Type
)
754 and then Is_Incomplete_Type
(Etype
(Desig_Type
))
755 and then Present
(Full_View
(Etype
(Desig_Type
)))
756 and then Present
(Class_Wide_Type
(Full_View
(Etype
(Desig_Type
))))
758 return Class_Wide_Type
(Full_View
(Etype
(Desig_Type
)));
764 ----------------------
765 -- Entry_Index_Type --
766 ----------------------
768 function Entry_Index_Type
(Id
: E
) return E
is
770 pragma Assert
(Ekind
(Id
) = E_Entry_Family
);
771 return Etype
(Discrete_Subtype_Definition
(Parent
(Id
)));
772 end Entry_Index_Type
;
774 ---------------------
775 -- First_Component --
776 ---------------------
778 function First_Component
(Id
: E
) return Entity_Id
is
783 (Is_Concurrent_Type
(Id
)
784 or else Is_Incomplete_Or_Private_Type
(Id
)
785 or else Is_Record_Type
(Id
));
787 Comp_Id
:= First_Entity
(Id
);
788 while Present
(Comp_Id
) loop
789 exit when Ekind
(Comp_Id
) = E_Component
;
790 Next_Entity
(Comp_Id
);
796 -------------------------------------
797 -- First_Component_Or_Discriminant --
798 -------------------------------------
800 function First_Component_Or_Discriminant
(Id
: E
) return Entity_Id
is
805 (Is_Concurrent_Type
(Id
)
806 or else Is_Incomplete_Or_Private_Type
(Id
)
807 or else Is_Record_Type
(Id
)
808 or else Has_Discriminants
(Id
));
810 Comp_Id
:= First_Entity
(Id
);
811 while Present
(Comp_Id
) loop
812 exit when Ekind
(Comp_Id
) in E_Component | E_Discriminant
;
813 Next_Entity
(Comp_Id
);
817 end First_Component_Or_Discriminant
;
823 function First_Formal
(Id
: E
) return Entity_Id
is
828 (Is_Generic_Subprogram
(Id
)
829 or else Is_Overloadable
(Id
)
830 or else Ekind
(Id
) in E_Entry_Family
832 | E_Subprogram_Type
);
834 if Ekind
(Id
) = E_Enumeration_Literal
then
838 Formal
:= First_Entity
(Id
);
840 -- Deal with the common, non-generic case first
842 if No
(Formal
) or else Is_Formal
(Formal
) then
846 -- The first/next entity chain of a generic subprogram contains all
847 -- generic formal parameters, followed by the formal parameters.
849 if Is_Generic_Subprogram
(Id
) then
850 while Present
(Formal
) and then not Is_Formal
(Formal
) loop
851 Next_Entity
(Formal
);
860 ------------------------------
861 -- First_Formal_With_Extras --
862 ------------------------------
864 function First_Formal_With_Extras
(Id
: E
) return Entity_Id
is
869 (Is_Generic_Subprogram
(Id
)
870 or else Is_Overloadable
(Id
)
871 or else Ekind
(Id
) in E_Entry_Family
873 | E_Subprogram_Type
);
875 if Ekind
(Id
) = E_Enumeration_Literal
then
879 Formal
:= First_Entity
(Id
);
881 -- The first/next entity chain of a generic subprogram contains all
882 -- generic formal parameters, followed by the formal parameters. Go
883 -- directly to the parameters by skipping the formal part.
885 if Is_Generic_Subprogram
(Id
) then
886 while Present
(Formal
) and then not Is_Formal
(Formal
) loop
887 Next_Entity
(Formal
);
891 if Present
(Formal
) and then Is_Formal
(Formal
) then
894 return Extra_Formals
(Id
); -- Empty if no extra formals
897 end First_Formal_With_Extras
;
903 function Float_Rep
(N
: Entity_Id
) return Float_Rep_Kind
is
904 pragma Unreferenced
(N
);
905 pragma Assert
(Float_Rep_Kind
'First = Float_Rep_Kind
'Last);
907 -- There is only one value, so we don't need to store it, see types.ads.
909 Val
: constant Float_Rep_Kind
:= IEEE_Binary
;
915 -------------------------------------
916 -- Get_Attribute_Definition_Clause --
917 -------------------------------------
919 function Get_Attribute_Definition_Clause
921 Id
: Attribute_Id
) return Node_Id
926 N
:= First_Rep_Item
(E
);
927 while Present
(N
) loop
928 if Nkind
(N
) = N_Attribute_Definition_Clause
929 and then Get_Attribute_Id
(Chars
(N
)) = Id
938 end Get_Attribute_Definition_Clause
;
940 ---------------------------
941 -- Get_Class_Wide_Pragma --
942 ---------------------------
944 function Get_Class_Wide_Pragma
946 Id
: Pragma_Id
) return Node_Id
952 Items
:= Contract
(E
);
958 Item
:= Pre_Post_Conditions
(Items
);
959 while Present
(Item
) loop
960 if Nkind
(Item
) = N_Pragma
961 and then Get_Pragma_Id
(Pragma_Name_Unmapped
(Item
)) = Id
962 and then Class_Present
(Item
)
967 Item
:= Next_Pragma
(Item
);
971 end Get_Class_Wide_Pragma
;
977 function Get_Full_View
(T
: Entity_Id
) return Entity_Id
is
979 if Is_Incomplete_Type
(T
) and then Present
(Full_View
(T
)) then
980 return Full_View
(T
);
982 elsif Is_Class_Wide_Type
(T
)
983 and then Is_Incomplete_Type
(Root_Type
(T
))
984 and then Present
(Full_View
(Root_Type
(T
)))
986 return Class_Wide_Type
(Full_View
(Root_Type
(T
)));
997 function Get_Pragma
(E
: Entity_Id
; Id
: Pragma_Id
) return Node_Id
is
999 -- Classification pragmas
1001 Is_CLS
: constant Boolean :=
1002 Id
= Pragma_Abstract_State
or else
1003 Id
= Pragma_Attach_Handler
or else
1004 Id
= Pragma_Async_Readers
or else
1005 Id
= Pragma_Async_Writers
or else
1006 Id
= Pragma_Constant_After_Elaboration
or else
1007 Id
= Pragma_Depends
or else
1008 Id
= Pragma_Effective_Reads
or else
1009 Id
= Pragma_Effective_Writes
or else
1010 Id
= Pragma_Extensions_Visible
or else
1011 Id
= Pragma_Global
or else
1012 Id
= Pragma_Initial_Condition
or else
1013 Id
= Pragma_Initializes
or else
1014 Id
= Pragma_Interrupt_Handler
or else
1015 Id
= Pragma_No_Caching
or else
1016 Id
= Pragma_Part_Of
or else
1017 Id
= Pragma_Refined_Depends
or else
1018 Id
= Pragma_Refined_Global
or else
1019 Id
= Pragma_Refined_State
or else
1020 Id
= Pragma_Side_Effects
or else
1021 Id
= Pragma_Volatile_Function
;
1023 -- Contract / subprogram variant / test case pragmas
1025 Is_CTC
: constant Boolean :=
1026 Id
= Pragma_Always_Terminates
or else
1027 Id
= Pragma_Contract_Cases
or else
1028 Id
= Pragma_Exceptional_Cases
or else
1029 Id
= Pragma_Subprogram_Variant
or else
1030 Id
= Pragma_Test_Case
;
1032 -- Pre / postcondition pragmas
1034 Is_PPC
: constant Boolean :=
1035 Id
= Pragma_Precondition
or else
1036 Id
= Pragma_Postcondition
or else
1037 Id
= Pragma_Refined_Post
;
1039 In_Contract
: constant Boolean := Is_CLS
or Is_CTC
or Is_PPC
;
1045 -- Handle pragmas that appear in N_Contract nodes. Those have to be
1046 -- extracted from their specialized list.
1049 Items
:= Contract
(E
);
1055 Item
:= Classifications
(Items
);
1058 Item
:= Contract_Test_Cases
(Items
);
1061 Item
:= Pre_Post_Conditions
(Items
);
1067 Item
:= First_Rep_Item
(E
);
1070 while Present
(Item
) loop
1071 if Nkind
(Item
) = N_Pragma
1072 and then Get_Pragma_Id
(Pragma_Name_Unmapped
(Item
)) = Id
1076 -- All nodes in N_Contract are chained using Next_Pragma
1078 elsif In_Contract
then
1079 Item
:= Next_Pragma
(Item
);
1084 Next_Rep_Item
(Item
);
1091 --------------------------------------
1092 -- Get_Record_Representation_Clause --
1093 --------------------------------------
1095 function Get_Record_Representation_Clause
(E
: Entity_Id
) return Node_Id
is
1099 N
:= First_Rep_Item
(E
);
1100 while Present
(N
) loop
1101 if Nkind
(N
) = N_Record_Representation_Clause
then
1109 end Get_Record_Representation_Clause
;
1111 ------------------------
1112 -- Has_Attach_Handler --
1113 ------------------------
1115 function Has_Attach_Handler
(Id
: E
) return B
is
1119 pragma Assert
(Is_Protected_Type
(Id
));
1121 Ritem
:= First_Rep_Item
(Id
);
1122 while Present
(Ritem
) loop
1123 if Nkind
(Ritem
) = N_Pragma
1124 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
1128 Next_Rep_Item
(Ritem
);
1133 end Has_Attach_Handler
;
1139 function Has_DIC
(Id
: E
) return B
is
1141 return Has_Own_DIC
(Id
) or else Has_Inherited_DIC
(Id
);
1148 function Has_Entries
(Id
: E
) return B
is
1152 pragma Assert
(Is_Concurrent_Type
(Id
));
1154 Ent
:= First_Entity
(Id
);
1155 while Present
(Ent
) loop
1156 if Is_Entry
(Ent
) then
1166 ----------------------------
1167 -- Has_Foreign_Convention --
1168 ----------------------------
1170 function Has_Foreign_Convention
(Id
: E
) return B
is
1172 -- While regular Intrinsics such as the Standard operators fit in the
1173 -- "Ada" convention, those with an Interface_Name materialize GCC
1174 -- builtin imports for which Ada special treatments shouldn't apply.
1176 return Convention
(Id
) in Foreign_Convention
1177 or else (Convention
(Id
) = Convention_Intrinsic
1178 and then Present
(Interface_Name
(Id
)));
1179 end Has_Foreign_Convention
;
1181 ---------------------------
1182 -- Has_Interrupt_Handler --
1183 ---------------------------
1185 function Has_Interrupt_Handler
(Id
: E
) return B
is
1189 pragma Assert
(Is_Protected_Type
(Id
));
1191 Ritem
:= First_Rep_Item
(Id
);
1192 while Present
(Ritem
) loop
1193 if Nkind
(Ritem
) = N_Pragma
1194 and then Pragma_Name
(Ritem
) = Name_Interrupt_Handler
1198 Next_Rep_Item
(Ritem
);
1203 end Has_Interrupt_Handler
;
1205 --------------------
1206 -- Has_Invariants --
1207 --------------------
1209 function Has_Invariants
(Id
: E
) return B
is
1211 return Has_Own_Invariants
(Id
) or else Has_Inherited_Invariants
(Id
);
1214 --------------------------
1215 -- Has_Limited_View --
1216 --------------------------
1218 function Has_Limited_View
(Id
: E
) return B
is
1220 return Ekind
(Id
) = E_Package
1221 and then not Is_Generic_Instance
(Id
)
1222 and then Present
(Limited_View
(Id
));
1223 end Has_Limited_View
;
1225 --------------------------
1226 -- Has_Non_Limited_View --
1227 --------------------------
1229 function Has_Non_Limited_View
(Id
: E
) return B
is
1231 return (Ekind
(Id
) in Incomplete_Kind
1232 or else Ekind
(Id
) in Class_Wide_Kind
1233 or else Ekind
(Id
) = E_Abstract_State
)
1234 and then Present
(Non_Limited_View
(Id
));
1235 end Has_Non_Limited_View
;
1237 ---------------------------------
1238 -- Has_Non_Null_Abstract_State --
1239 ---------------------------------
1241 function Has_Non_Null_Abstract_State
(Id
: E
) return B
is
1243 pragma Assert
(Is_Package_Or_Generic_Package
(Id
));
1246 Present
(Abstract_States
(Id
))
1248 not Is_Null_State
(Node
(First_Elmt
(Abstract_States
(Id
))));
1249 end Has_Non_Null_Abstract_State
;
1251 -------------------------------------
1252 -- Has_Non_Null_Visible_Refinement --
1253 -------------------------------------
1255 function Has_Non_Null_Visible_Refinement
(Id
: E
) return B
is
1256 Constits
: Elist_Id
;
1259 -- "Refinement" is a concept applicable only to abstract states
1261 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
1262 Constits
:= Refinement_Constituents
(Id
);
1264 -- A partial refinement is always non-null. For a full refinement to be
1265 -- non-null, the first constituent must be anything other than null.
1268 Has_Partial_Visible_Refinement
(Id
)
1269 or else (Has_Visible_Refinement
(Id
)
1270 and then Present
(Constits
)
1271 and then Nkind
(Node
(First_Elmt
(Constits
))) /= N_Null
);
1272 end Has_Non_Null_Visible_Refinement
;
1274 -----------------------------
1275 -- Has_Null_Abstract_State --
1276 -----------------------------
1278 function Has_Null_Abstract_State
(Id
: E
) return B
is
1279 pragma Assert
(Is_Package_Or_Generic_Package
(Id
));
1281 States
: constant Elist_Id
:= Abstract_States
(Id
);
1284 -- Check first available state of related package. A null abstract
1285 -- state always appears as the sole element of the state list.
1289 and then Is_Null_State
(Node
(First_Elmt
(States
)));
1290 end Has_Null_Abstract_State
;
1292 ---------------------------------
1293 -- Has_Null_Visible_Refinement --
1294 ---------------------------------
1296 function Has_Null_Visible_Refinement
(Id
: E
) return B
is
1297 Constits
: Elist_Id
;
1300 -- "Refinement" is a concept applicable only to abstract states
1302 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
1303 Constits
:= Refinement_Constituents
(Id
);
1305 -- For a refinement to be null, the state's sole constituent must be a
1309 Has_Visible_Refinement
(Id
)
1310 and then Present
(Constits
)
1311 and then Nkind
(Node
(First_Elmt
(Constits
))) = N_Null
;
1312 end Has_Null_Visible_Refinement
;
1314 --------------------
1315 -- Has_Unmodified --
1316 --------------------
1318 function Has_Unmodified
(E
: Entity_Id
) return Boolean is
1320 if Has_Pragma_Unmodified
(E
) then
1322 elsif Warnings_Off
(E
) then
1323 Set_Warnings_Off_Used_Unmodified
(E
);
1330 ---------------------
1331 -- Has_Unreferenced --
1332 ---------------------
1334 function Has_Unreferenced
(E
: Entity_Id
) return Boolean is
1336 if Has_Pragma_Unreferenced
(E
) then
1338 elsif Warnings_Off
(E
) then
1339 Set_Warnings_Off_Used_Unreferenced
(E
);
1344 end Has_Unreferenced
;
1346 ----------------------
1347 -- Has_Warnings_Off --
1348 ----------------------
1350 function Has_Warnings_Off
(E
: Entity_Id
) return Boolean is
1352 if Warnings_Off
(E
) then
1353 Set_Warnings_Off_Used
(E
);
1358 end Has_Warnings_Off
;
1360 ------------------------------
1361 -- Implementation_Base_Type --
1362 ------------------------------
1364 function Implementation_Base_Type
(Id
: E
) return E
is
1369 Bastyp
:= Base_Type
(Id
);
1371 if Is_Incomplete_Or_Private_Type
(Bastyp
) then
1372 Imptyp
:= Underlying_Type
(Bastyp
);
1374 -- If we have an implementation type, then just return it,
1375 -- otherwise we return the Base_Type anyway. This can only
1376 -- happen in error situations and should avoid some error bombs.
1378 if Present
(Imptyp
) then
1379 return Base_Type
(Imptyp
);
1387 end Implementation_Base_Type
;
1389 -------------------------
1390 -- Invariant_Procedure --
1391 -------------------------
1393 function Invariant_Procedure
(Id
: E
) return Entity_Id
is
1394 Subp_Elmt
: Elmt_Id
;
1395 Subp_Id
: Entity_Id
;
1399 pragma Assert
(Is_Type
(Id
));
1401 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
1403 if Present
(Subps
) then
1404 Subp_Elmt
:= First_Elmt
(Subps
);
1405 while Present
(Subp_Elmt
) loop
1406 Subp_Id
:= Node
(Subp_Elmt
);
1408 if Is_Invariant_Procedure
(Subp_Id
) then
1412 Next_Elmt
(Subp_Elmt
);
1417 end Invariant_Procedure
;
1423 -- Global flag table allowing rapid computation of this function
1425 Entity_Is_Base_Type
: constant array (Entity_Kind
) of Boolean :=
1426 (E_Enumeration_Subtype |
1427 E_Incomplete_Subtype |
1428 E_Signed_Integer_Subtype |
1429 E_Modular_Integer_Subtype |
1430 E_Floating_Point_Subtype |
1431 E_Ordinary_Fixed_Point_Subtype |
1432 E_Decimal_Fixed_Point_Subtype |
1436 E_Record_Subtype_With_Private |
1437 E_Limited_Private_Subtype |
1439 E_Protected_Subtype |
1441 E_String_Literal_Subtype |
1442 E_Class_Wide_Subtype
=> False,
1445 function Is_Base_Type
(Id
: E
) return Boolean is
1447 return Entity_Is_Base_Type
(Ekind
(Id
));
1450 ---------------------
1451 -- Is_Boolean_Type --
1452 ---------------------
1454 function Is_Boolean_Type
(Id
: E
) return B
is
1456 return Root_Type
(Id
) = Standard_Boolean
;
1457 end Is_Boolean_Type
;
1459 ------------------------
1460 -- Is_Constant_Object --
1461 ------------------------
1463 function Is_Constant_Object
(Id
: E
) return B
is
1465 return Ekind
(Id
) in E_Constant | E_In_Parameter | E_Loop_Parameter
;
1466 end Is_Constant_Object
;
1472 function Is_Controlled
(Id
: E
) return B
is
1474 return Is_Controlled_Active
(Id
) and then not Disable_Controlled
(Id
);
1477 --------------------
1478 -- Is_Discriminal --
1479 --------------------
1481 function Is_Discriminal
(Id
: E
) return B
is
1483 return Ekind
(Id
) in E_Constant | E_In_Parameter
1484 and then Present
(Discriminal_Link
(Id
));
1487 ----------------------
1488 -- Is_Dynamic_Scope --
1489 ----------------------
1491 function Is_Dynamic_Scope
(Id
: E
) return B
is
1493 return Ekind
(Id
) in E_Block
1494 -- Including an E_Block that came from an N_Expression_With_Actions
1499 | E_Return_Statement
1503 (Ekind
(Id
) = E_Limited_Private_Type
1504 and then Present
(Full_View
(Id
))
1505 and then Ekind
(Full_View
(Id
)) = E_Task_Type
);
1506 end Is_Dynamic_Scope
;
1508 --------------------
1509 -- Is_Entity_Name --
1510 --------------------
1512 function Is_Entity_Name
(N
: Node_Id
) return Boolean is
1513 Kind
: constant Node_Kind
:= Nkind
(N
);
1516 -- Identifiers, operator symbols, expanded names are entity names.
1517 -- (But not N_Character_Literal.)
1519 return Kind
in N_Identifier | N_Operator_Symbol | N_Expanded_Name
1521 -- Attribute references are entity names if they refer to an entity.
1522 -- Note that we don't do this by testing for the presence of the
1523 -- Entity field in the N_Attribute_Reference node, since it may not
1524 -- have been set yet.
1526 or else (Kind
= N_Attribute_Reference
1527 and then Is_Entity_Attribute_Name
(Attribute_Name
(N
)));
1530 ---------------------------
1531 -- Is_Elaboration_Target --
1532 ---------------------------
1534 function Is_Elaboration_Target
(Id
: E
) return Boolean is
1537 Ekind
(Id
) in E_Constant | E_Package | E_Variable
1538 or else Is_Entry
(Id
)
1539 or else Is_Generic_Unit
(Id
)
1540 or else Is_Subprogram
(Id
)
1541 or else Is_Task_Type
(Id
);
1542 end Is_Elaboration_Target
;
1544 -----------------------
1545 -- Is_External_State --
1546 -----------------------
1548 function Is_External_State
(Id
: E
) return B
is
1550 -- To qualify, the abstract state must appear with option "external" or
1551 -- "synchronous" (SPARK RM 7.1.4(7) and (9)).
1554 Ekind
(Id
) = E_Abstract_State
1555 and then (Has_Option
(Id
, Name_External
)
1557 Has_Option
(Id
, Name_Synchronous
));
1558 end Is_External_State
;
1564 function Is_Finalizer
(Id
: E
) return B
is
1566 return Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uFinalizer
;
1569 ----------------------
1570 -- Is_Full_Access --
1571 ----------------------
1573 function Is_Full_Access
(Id
: E
) return B
is
1575 return Is_Atomic
(Id
) or else Is_Volatile_Full_Access
(Id
);
1582 function Is_Null_State
(Id
: E
) return B
is
1585 Ekind
(Id
) = E_Abstract_State
and then Nkind
(Parent
(Id
)) = N_Null
;
1588 -----------------------------------
1589 -- Is_Package_Or_Generic_Package --
1590 -----------------------------------
1592 function Is_Package_Or_Generic_Package
(Id
: E
) return B
is
1594 return Ekind
(Id
) in E_Generic_Package | E_Package
;
1595 end Is_Package_Or_Generic_Package
;
1597 ---------------------
1598 -- Is_Packed_Array --
1599 ---------------------
1601 function Is_Packed_Array
(Id
: E
) return B
is
1603 return Is_Array_Type
(Id
) and then Is_Packed
(Id
);
1604 end Is_Packed_Array
;
1610 function Is_Prival
(Id
: E
) return B
is
1612 return Ekind
(Id
) in E_Constant | E_Variable
1613 and then Present
(Prival_Link
(Id
));
1616 ----------------------------
1617 -- Is_Protected_Component --
1618 ----------------------------
1620 function Is_Protected_Component
(Id
: E
) return B
is
1622 return Ekind
(Id
) = E_Component
and then Is_Protected_Type
(Scope
(Id
));
1623 end Is_Protected_Component
;
1625 ----------------------------
1626 -- Is_Protected_Interface --
1627 ----------------------------
1629 function Is_Protected_Interface
(Id
: E
) return B
is
1630 Typ
: constant Entity_Id
:= Base_Type
(Id
);
1632 if not Is_Interface
(Typ
) then
1634 elsif Is_Class_Wide_Type
(Typ
) then
1635 return Is_Protected_Interface
(Etype
(Typ
));
1637 return Protected_Present
(Type_Definition
(Parent
(Typ
)));
1639 end Is_Protected_Interface
;
1641 ------------------------------
1642 -- Is_Protected_Record_Type --
1643 ------------------------------
1645 function Is_Protected_Record_Type
(Id
: E
) return B
is
1648 Is_Concurrent_Record_Type
(Id
)
1649 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Id
));
1650 end Is_Protected_Record_Type
;
1652 -------------------------------------
1653 -- Is_Relaxed_Initialization_State --
1654 -------------------------------------
1656 function Is_Relaxed_Initialization_State
(Id
: E
) return B
is
1658 -- To qualify, the abstract state must appear with simple option
1659 -- "Relaxed_Initialization" (SPARK RM 6.10).
1662 Ekind
(Id
) = E_Abstract_State
1663 and then Has_Option
(Id
, Name_Relaxed_Initialization
);
1664 end Is_Relaxed_Initialization_State
;
1666 --------------------------------
1667 -- Is_Standard_Character_Type --
1668 --------------------------------
1670 function Is_Standard_Character_Type
(Id
: E
) return B
is
1673 and then Root_Type
(Id
) in Standard_Character
1674 | Standard_Wide_Character
1675 | Standard_Wide_Wide_Character
;
1676 end Is_Standard_Character_Type
;
1678 -----------------------------
1679 -- Is_Standard_String_Type --
1680 -----------------------------
1682 function Is_Standard_String_Type
(Id
: E
) return B
is
1685 and then Root_Type
(Id
) in Standard_String
1686 | Standard_Wide_String
1687 | Standard_Wide_Wide_String
;
1688 end Is_Standard_String_Type
;
1690 --------------------
1691 -- Is_String_Type --
1692 --------------------
1694 function Is_String_Type
(Id
: E
) return B
is
1696 return Is_Array_Type
(Id
)
1697 and then Id
/= Any_Composite
1698 and then Number_Dimensions
(Id
) = 1
1699 and then Is_Character_Type
(Component_Type
(Id
));
1702 -------------------------------
1703 -- Is_Synchronized_Interface --
1704 -------------------------------
1706 function Is_Synchronized_Interface
(Id
: E
) return B
is
1707 Typ
: constant Entity_Id
:= Base_Type
(Id
);
1710 if not Is_Interface
(Typ
) then
1713 elsif Is_Class_Wide_Type
(Typ
) then
1714 return Is_Synchronized_Interface
(Etype
(Typ
));
1717 return Protected_Present
(Type_Definition
(Parent
(Typ
)))
1718 or else Synchronized_Present
(Type_Definition
(Parent
(Typ
)))
1719 or else Task_Present
(Type_Definition
(Parent
(Typ
)));
1721 end Is_Synchronized_Interface
;
1723 ---------------------------
1724 -- Is_Synchronized_State --
1725 ---------------------------
1727 function Is_Synchronized_State
(Id
: E
) return B
is
1729 -- To qualify, the abstract state must appear with simple option
1730 -- "synchronous" (SPARK RM 7.1.4(9)).
1733 Ekind
(Id
) = E_Abstract_State
1734 and then Has_Option
(Id
, Name_Synchronous
);
1735 end Is_Synchronized_State
;
1737 -----------------------
1738 -- Is_Task_Interface --
1739 -----------------------
1741 function Is_Task_Interface
(Id
: E
) return B
is
1742 Typ
: constant Entity_Id
:= Base_Type
(Id
);
1744 if not Is_Interface
(Typ
) then
1746 elsif Is_Class_Wide_Type
(Typ
) then
1747 return Is_Task_Interface
(Etype
(Typ
));
1749 return Task_Present
(Type_Definition
(Parent
(Typ
)));
1751 end Is_Task_Interface
;
1753 -------------------------
1754 -- Is_Task_Record_Type --
1755 -------------------------
1757 function Is_Task_Record_Type
(Id
: E
) return B
is
1760 Is_Concurrent_Record_Type
(Id
)
1761 and then Is_Task_Type
(Corresponding_Concurrent_Type
(Id
));
1762 end Is_Task_Record_Type
;
1764 ------------------------
1765 -- Is_Wrapper_Package --
1766 ------------------------
1768 function Is_Wrapper_Package
(Id
: E
) return B
is
1770 return Ekind
(Id
) = E_Package
and then Present
(Related_Instance
(Id
));
1771 end Is_Wrapper_Package
;
1777 function Last_Formal
(Id
: E
) return Entity_Id
is
1782 (Is_Overloadable
(Id
)
1783 or else Ekind
(Id
) in E_Entry_Family
1785 | E_Subprogram_Type
);
1787 if Ekind
(Id
) = E_Enumeration_Literal
then
1791 Formal
:= First_Formal
(Id
);
1793 if Present
(Formal
) then
1794 while Present
(Next_Formal
(Formal
)) loop
1795 Next_Formal
(Formal
);
1807 procedure Link_Entities
(First
, Second
: Entity_Id
) is
1809 if Present
(Second
) then
1810 Set_Prev_Entity
(Second
, First
); -- First <-- Second
1813 Set_Next_Entity
(First
, Second
); -- First --> Second
1816 ------------------------
1817 -- Machine_Emax_Value --
1818 ------------------------
1820 function Machine_Emax_Value
(Id
: E
) return Uint
is
1821 Digs
: constant Pos
:= UI_To_Int
(Digits_Value
(Base_Type
(Id
)));
1824 case Float_Rep
(Id
) is
1827 when 1 .. 6 => return Uint_128
;
1828 when 7 .. 15 => return 2**10;
1829 when 16 .. 33 => return 2**14;
1830 when others => return No_Uint
;
1833 end Machine_Emax_Value
;
1835 ------------------------
1836 -- Machine_Emin_Value --
1837 ------------------------
1839 function Machine_Emin_Value
(Id
: E
) return Uint
is
1841 case Float_Rep
(Id
) is
1842 when IEEE_Binary
=> return Uint_3
- Machine_Emax_Value
(Id
);
1844 end Machine_Emin_Value
;
1846 ----------------------------
1847 -- Machine_Mantissa_Value --
1848 ----------------------------
1850 function Machine_Mantissa_Value
(Id
: E
) return Uint
is
1851 Digs
: constant Pos
:= UI_To_Int
(Digits_Value
(Base_Type
(Id
)));
1854 case Float_Rep
(Id
) is
1857 when 1 .. 6 => return Uint_24
;
1858 when 7 .. 15 => return UI_From_Int
(53);
1859 when 16 .. 18 => return Uint_64
;
1860 when 19 .. 33 => return UI_From_Int
(113);
1861 when others => return No_Uint
;
1864 end Machine_Mantissa_Value
;
1866 -------------------------
1867 -- Machine_Radix_Value --
1868 -------------------------
1870 function Machine_Radix_Value
(Id
: E
) return U
is
1872 case Float_Rep
(Id
) is
1876 end Machine_Radix_Value
;
1878 ----------------------
1879 -- Model_Emin_Value --
1880 ----------------------
1882 function Model_Emin_Value
(Id
: E
) return Uint
is
1884 return Machine_Emin_Value
(Id
);
1885 end Model_Emin_Value
;
1887 -------------------------
1888 -- Model_Epsilon_Value --
1889 -------------------------
1891 function Model_Epsilon_Value
(Id
: E
) return Ureal
is
1892 Radix
: constant Ureal
:= UR_From_Uint
(Machine_Radix_Value
(Id
));
1894 return Radix
** (1 - Model_Mantissa_Value
(Id
));
1895 end Model_Epsilon_Value
;
1897 --------------------------
1898 -- Model_Mantissa_Value --
1899 --------------------------
1901 function Model_Mantissa_Value
(Id
: E
) return Uint
is
1903 return Machine_Mantissa_Value
(Id
);
1904 end Model_Mantissa_Value
;
1906 -----------------------
1907 -- Model_Small_Value --
1908 -----------------------
1910 function Model_Small_Value
(Id
: E
) return Ureal
is
1911 Radix
: constant Ureal
:= UR_From_Uint
(Machine_Radix_Value
(Id
));
1913 return Radix
** (Model_Emin_Value
(Id
) - 1);
1914 end Model_Small_Value
;
1916 --------------------
1917 -- Next_Component --
1918 --------------------
1920 function Next_Component
(Id
: E
) return Entity_Id
is
1921 Comp_Id
: Entity_Id
;
1924 Comp_Id
:= Next_Entity
(Id
);
1925 while Present
(Comp_Id
) loop
1926 exit when Ekind
(Comp_Id
) = E_Component
;
1927 Next_Entity
(Comp_Id
);
1933 ------------------------------------
1934 -- Next_Component_Or_Discriminant --
1935 ------------------------------------
1937 function Next_Component_Or_Discriminant
(Id
: E
) return Entity_Id
is
1938 Comp_Id
: Entity_Id
;
1941 Comp_Id
:= Next_Entity
(Id
);
1942 while Present
(Comp_Id
) loop
1943 exit when Ekind
(Comp_Id
) in E_Component | E_Discriminant
;
1944 Next_Entity
(Comp_Id
);
1948 end Next_Component_Or_Discriminant
;
1950 -----------------------
1951 -- Next_Discriminant --
1952 -----------------------
1954 -- This function actually implements both Next_Discriminant and
1955 -- Next_Stored_Discriminant by making sure that the Discriminant
1956 -- returned is of the same variety as Id.
1958 function Next_Discriminant
(Id
: E
) return Entity_Id
is
1960 -- Derived Tagged types with private extensions look like this...
1962 -- E_Discriminant d1
1963 -- E_Discriminant d2
1965 -- E_Discriminant d1
1966 -- E_Discriminant d2
1969 -- so it is critical not to go past the leading discriminants
1971 D
: Entity_Id
:= Id
;
1974 pragma Assert
(Ekind
(Id
) = E_Discriminant
);
1979 or else (Ekind
(D
) /= E_Discriminant
1980 and then not Is_Itype
(D
))
1985 exit when Ekind
(D
) = E_Discriminant
1986 and then Is_Completely_Hidden
(D
) = Is_Completely_Hidden
(Id
);
1990 end Next_Discriminant
;
1996 function Next_Formal
(Id
: E
) return Entity_Id
is
2000 -- Follow the chain of declared entities as long as the kind of the
2001 -- entity corresponds to a formal parameter. Skip internal entities
2002 -- that may have been created for implicit subtypes, in the process
2003 -- of analyzing default expressions.
2009 if No
(P
) or else Is_Formal
(P
) then
2011 elsif not Is_Internal
(P
) then
2017 -----------------------------
2018 -- Next_Formal_With_Extras --
2019 -----------------------------
2021 function Next_Formal_With_Extras
(Id
: E
) return Entity_Id
is
2023 if Present
(Extra_Formal
(Id
)) then
2024 return Extra_Formal
(Id
);
2026 return Next_Formal
(Id
);
2028 end Next_Formal_With_Extras
;
2034 function Next_Index
(Id
: N
) return Node_Id
is
2036 pragma Assert
(Nkind
(Id
) in N_Is_Index
);
2037 pragma Assert
(No
(Next
(Id
)) or else Nkind
(Next
(Id
)) in N_Is_Index
);
2045 function Next_Literal
(Id
: E
) return Entity_Id
is
2047 pragma Assert
(Nkind
(Id
) in N_Entity
);
2051 ------------------------------
2052 -- Next_Stored_Discriminant --
2053 ------------------------------
2055 function Next_Stored_Discriminant
(Id
: E
) return Entity_Id
is
2057 -- See comment in Next_Discriminant
2059 return Next_Discriminant
(Id
);
2060 end Next_Stored_Discriminant
;
2062 -----------------------
2063 -- Number_Dimensions --
2064 -----------------------
2066 function Number_Dimensions
(Id
: E
) return Pos
is
2071 if Ekind
(Id
) = E_String_Literal_Subtype
then
2076 T
:= First_Index
(Id
);
2077 while Present
(T
) loop
2084 end Number_Dimensions
;
2086 --------------------
2087 -- Number_Entries --
2088 --------------------
2090 function Number_Entries
(Id
: E
) return Nat
is
2095 pragma Assert
(Is_Concurrent_Type
(Id
));
2098 Ent
:= First_Entity
(Id
);
2099 while Present
(Ent
) loop
2100 if Is_Entry
(Ent
) then
2110 --------------------
2111 -- Number_Formals --
2112 --------------------
2114 function Number_Formals
(Id
: E
) return Nat
is
2120 Formal
:= First_Formal
(Id
);
2121 while Present
(Formal
) loop
2123 Next_Formal
(Formal
);
2129 ------------------------
2130 -- Object_Size_Clause --
2131 ------------------------
2133 function Object_Size_Clause
(Id
: E
) return Node_Id
is
2135 return Get_Attribute_Definition_Clause
(Id
, Attribute_Object_Size
);
2136 end Object_Size_Clause
;
2138 --------------------
2139 -- Parameter_Mode --
2140 --------------------
2142 function Parameter_Mode
(Id
: E
) return Formal_Kind
is
2151 function DIC_Procedure
(Id
: E
) return Entity_Id
is
2152 Subp_Elmt
: Elmt_Id
;
2153 Subp_Id
: Entity_Id
;
2157 pragma Assert
(Is_Type
(Id
));
2159 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
2161 if Present
(Subps
) then
2162 Subp_Elmt
:= First_Elmt
(Subps
);
2163 while Present
(Subp_Elmt
) loop
2164 Subp_Id
:= Node
(Subp_Elmt
);
2166 -- Currently the flag Is_DIC_Procedure is set for both normal DIC
2167 -- check procedures as well as for partial DIC check procedures,
2168 -- and we don't have a flag for the partial procedures.
2170 if Is_DIC_Procedure
(Subp_Id
)
2171 and then not Is_Partial_DIC_Procedure
(Subp_Id
)
2176 Next_Elmt
(Subp_Elmt
);
2183 function Partial_DIC_Procedure
(Id
: E
) return Entity_Id
is
2184 Subp_Elmt
: Elmt_Id
;
2185 Subp_Id
: Entity_Id
;
2189 pragma Assert
(Is_Type
(Id
));
2191 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
2193 if Present
(Subps
) then
2194 Subp_Elmt
:= First_Elmt
(Subps
);
2195 while Present
(Subp_Elmt
) loop
2196 Subp_Id
:= Node
(Subp_Elmt
);
2198 if Is_Partial_DIC_Procedure
(Subp_Id
) then
2202 Next_Elmt
(Subp_Elmt
);
2207 end Partial_DIC_Procedure
;
2209 function Is_Partial_DIC_Procedure
(Id
: E
) return B
is
2210 Partial_DIC_Suffix
: constant String := "Partial_DIC";
2211 DIC_Nam
: constant String := Get_Name_String
(Chars
(Id
));
2214 pragma Assert
(Ekind
(Id
) in E_Function | E_Procedure
);
2216 -- Instead of adding a new Entity_Id flag (which are in short supply),
2217 -- we test the form of the subprogram name. When the node field and flag
2218 -- situation is eased, this should be replaced with a flag. ???
2220 if DIC_Nam
'Length > Partial_DIC_Suffix
'Length
2223 (DIC_Nam
'Last - Partial_DIC_Suffix
'Length + 1 .. DIC_Nam
'Last) =
2230 end Is_Partial_DIC_Procedure
;
2232 ---------------------------------
2233 -- Partial_Invariant_Procedure --
2234 ---------------------------------
2236 function Partial_Invariant_Procedure
(Id
: E
) return Entity_Id
is
2237 Subp_Elmt
: Elmt_Id
;
2238 Subp_Id
: Entity_Id
;
2242 pragma Assert
(Is_Type
(Id
));
2244 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
2246 if Present
(Subps
) then
2247 Subp_Elmt
:= First_Elmt
(Subps
);
2248 while Present
(Subp_Elmt
) loop
2249 Subp_Id
:= Node
(Subp_Elmt
);
2251 if Is_Partial_Invariant_Procedure
(Subp_Id
) then
2255 Next_Elmt
(Subp_Elmt
);
2260 end Partial_Invariant_Procedure
;
2262 -------------------------------------
2263 -- Partial_Refinement_Constituents --
2264 -------------------------------------
2266 function Partial_Refinement_Constituents
(Id
: E
) return L
is
2267 Constits
: Elist_Id
:= No_Elist
;
2269 procedure Add_Usable_Constituents
(Item
: E
);
2270 -- Add global item Item and/or its constituents to list Constits when
2271 -- they can be used in a global refinement within the current scope. The
2273 -- 1) If Item is an abstract state with full refinement visible, add
2274 -- its constituents.
2275 -- 2) If Item is an abstract state with only partial refinement
2276 -- visible, add both Item and its constituents.
2277 -- 3) If Item is an abstract state without a visible refinement, add
2279 -- 4) If Id is not an abstract state, add it.
2281 procedure Add_Usable_Constituents
(List
: Elist_Id
);
2282 -- Apply Add_Usable_Constituents to every constituent in List
2284 -----------------------------
2285 -- Add_Usable_Constituents --
2286 -----------------------------
2288 procedure Add_Usable_Constituents
(Item
: E
) is
2290 if Ekind
(Item
) = E_Abstract_State
then
2291 if Has_Visible_Refinement
(Item
) then
2292 Add_Usable_Constituents
(Refinement_Constituents
(Item
));
2294 elsif Has_Partial_Visible_Refinement
(Item
) then
2295 Append_New_Elmt
(Item
, Constits
);
2296 Add_Usable_Constituents
(Part_Of_Constituents
(Item
));
2299 Append_New_Elmt
(Item
, Constits
);
2303 Append_New_Elmt
(Item
, Constits
);
2305 end Add_Usable_Constituents
;
2307 procedure Add_Usable_Constituents
(List
: Elist_Id
) is
2308 Constit_Elmt
: Elmt_Id
;
2310 if Present
(List
) then
2311 Constit_Elmt
:= First_Elmt
(List
);
2312 while Present
(Constit_Elmt
) loop
2313 Add_Usable_Constituents
(Node
(Constit_Elmt
));
2314 Next_Elmt
(Constit_Elmt
);
2317 end Add_Usable_Constituents
;
2319 -- Start of processing for Partial_Refinement_Constituents
2322 -- "Refinement" is a concept applicable only to abstract states
2324 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
2326 if Has_Visible_Refinement
(Id
) then
2327 Constits
:= Refinement_Constituents
(Id
);
2329 -- A refinement may be partially visible when objects declared in the
2330 -- private part of a package are subject to a Part_Of indicator.
2332 elsif Has_Partial_Visible_Refinement
(Id
) then
2333 Add_Usable_Constituents
(Part_Of_Constituents
(Id
));
2335 -- Function should only be called when full or partial refinement is
2339 raise Program_Error
;
2343 end Partial_Refinement_Constituents
;
2345 ------------------------
2346 -- Predicate_Function --
2347 ------------------------
2349 function Predicate_Function
(Id
: E
) return Entity_Id
is
2350 Subp_Elmt
: Elmt_Id
;
2351 Subp_Id
: Entity_Id
;
2356 pragma Assert
(Is_Type
(Id
));
2358 -- If type is private and has a completion, predicate may be defined on
2361 if Is_Private_Type
(Id
)
2363 (not Has_Predicates
(Id
) or else No
(Subprograms_For_Type
(Id
)))
2364 and then Present
(Full_View
(Id
))
2366 Typ
:= Full_View
(Id
);
2368 elsif Ekind
(Id
) in E_Array_Subtype
2370 | E_Record_Subtype_With_Private
2371 and then Present
(Predicated_Parent
(Id
))
2373 Typ
:= Predicated_Parent
(Id
);
2379 Subps
:= Subprograms_For_Type
(Typ
);
2381 if Present
(Subps
) then
2382 Subp_Elmt
:= First_Elmt
(Subps
);
2383 while Present
(Subp_Elmt
) loop
2384 Subp_Id
:= Node
(Subp_Elmt
);
2386 if Ekind
(Subp_Id
) = E_Function
2387 and then Is_Predicate_Function
(Subp_Id
)
2392 Next_Elmt
(Subp_Elmt
);
2397 end Predicate_Function
;
2399 -------------------------
2400 -- Present_In_Rep_Item --
2401 -------------------------
2403 function Present_In_Rep_Item
(E
: Entity_Id
; N
: Node_Id
) return Boolean is
2407 Ritem
:= First_Rep_Item
(E
);
2409 while Present
(Ritem
) loop
2414 Next_Rep_Item
(Ritem
);
2418 end Present_In_Rep_Item
;
2420 --------------------------
2421 -- Primitive_Operations --
2422 --------------------------
2424 function Primitive_Operations
(Id
: E
) return L
is
2426 if Is_Concurrent_Type
(Id
) then
2427 if Present
(Corresponding_Record_Type
(Id
)) then
2428 return Direct_Primitive_Operations
2429 (Corresponding_Record_Type
(Id
));
2431 -- When expansion is disabled, the corresponding record type is
2432 -- absent, but if this is a tagged type with ancestors, or if the
2433 -- extension of prefixed calls for untagged types is enabled, then
2434 -- it may have associated primitive operations.
2437 return Direct_Primitive_Operations
(Id
);
2441 return Direct_Primitive_Operations
(Id
);
2443 end Primitive_Operations
;
2445 ---------------------
2446 -- Record_Rep_Item --
2447 ---------------------
2449 procedure Record_Rep_Item
(E
: Entity_Id
; N
: Node_Id
) is
2451 Set_Next_Rep_Item
(N
, First_Rep_Item
(E
));
2452 Set_First_Rep_Item
(E
, N
);
2453 end Record_Rep_Item
;
2459 procedure Remove_Entity
(Id
: Entity_Id
) is
2460 Next
: constant Entity_Id
:= Next_Entity
(Id
);
2461 Prev
: constant Entity_Id
:= Prev_Entity
(Id
);
2462 Scop
: constant Entity_Id
:= Scope
(Id
);
2463 First
: constant Entity_Id
:= First_Entity
(Scop
);
2464 Last
: constant Entity_Id
:= Last_Entity
(Scop
);
2467 -- Eliminate any existing linkages from the entity
2469 Set_Prev_Entity
(Id
, Empty
); -- Empty <-- Id
2470 Set_Next_Entity
(Id
, Empty
); -- Id --> Empty
2472 -- The eliminated entity was the only element in the entity chain
2474 if Id
= First
and then Id
= Last
then
2475 Set_First_Entity
(Scop
, Empty
);
2476 Set_Last_Entity
(Scop
, Empty
);
2478 -- The eliminated entity was the head of the entity chain
2480 elsif Id
= First
then
2481 Set_First_Entity
(Scop
, Next
);
2482 Set_Prev_Entity
(Next
, Empty
); -- Empty <-- First_Entity
2484 -- The eliminated entity was the tail of the entity chain
2486 elsif Id
= Last
then
2487 Set_Last_Entity
(Scop
, Prev
);
2488 Set_Next_Entity
(Prev
, Empty
); -- Last_Entity --> Empty
2490 -- Otherwise the eliminated entity comes from the middle of the entity
2494 Link_Entities
(Prev
, Next
); -- Prev <-- Next, Prev --> Next
2502 function Root_Type
(Id
: E
) return E
is
2503 T
, Etyp
: Entity_Id
;
2506 pragma Assert
(Nkind
(Id
) in N_Entity
);
2508 T
:= Base_Type
(Id
);
2510 if Ekind
(T
) = E_Class_Wide_Type
then
2522 -- Following test catches some error cases resulting from
2525 elsif No
(Etyp
) then
2526 Check_Error_Detected
;
2529 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
2532 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
2538 -- Return if there is a circularity in the inheritance chain. This
2539 -- happens in some error situations and we do not want to get
2540 -- stuck in this loop.
2542 if T
= Base_Type
(Id
) then
2549 ---------------------
2550 -- Safe_Emax_Value --
2551 ---------------------
2553 function Safe_Emax_Value
(Id
: E
) return Uint
is
2555 return Machine_Emax_Value
(Id
);
2556 end Safe_Emax_Value
;
2558 ----------------------
2559 -- Safe_First_Value --
2560 ----------------------
2562 function Safe_First_Value
(Id
: E
) return Ureal
is
2564 return -Safe_Last_Value
(Id
);
2565 end Safe_First_Value
;
2567 ---------------------
2568 -- Safe_Last_Value --
2569 ---------------------
2571 function Safe_Last_Value
(Id
: E
) return Ureal
is
2572 Radix
: constant Uint
:= Machine_Radix_Value
(Id
);
2573 Mantissa
: constant Uint
:= Machine_Mantissa_Value
(Id
);
2574 Emax
: constant Uint
:= Safe_Emax_Value
(Id
);
2575 Significand
: constant Uint
:= Radix
** Mantissa
- 1;
2576 Exponent
: constant Uint
:= Emax
- Mantissa
;
2582 (Num
=> Significand
* 2 ** (Exponent
mod 4),
2583 Den
=> -Exponent
/ 4,
2588 (Num
=> Significand
,
2592 end Safe_Last_Value
;
2598 function Scope_Depth
(Id
: Scope_Kind_Id
) return Uint
is
2603 while Is_Record_Type
(Scop
) loop
2604 Scop
:= Scope
(Scop
);
2607 return Scope_Depth_Value
(Scop
);
2610 function Scope_Depth_Default_0
(Id
: Scope_Kind_Id
) return U
is
2612 if Scope_Depth_Set
(Id
) then
2613 return Scope_Depth
(Id
);
2618 end Scope_Depth_Default_0
;
2620 ---------------------
2621 -- Scope_Depth_Set --
2622 ---------------------
2624 function Scope_Depth_Set
(Id
: Scope_Kind_Id
) return B
is
2626 return not Is_Record_Type
(Id
)
2627 and then not Field_Is_Initial_Zero
(Id
, F_Scope_Depth_Value
);
2628 -- We can't call Scope_Depth_Value here, because Empty is not a valid
2629 -- value of type Uint.
2630 end Scope_Depth_Set
;
2632 --------------------
2633 -- Set_Convention --
2634 --------------------
2636 procedure Set_Convention
(E
: Entity_Id
; Val
: Snames
.Convention_Id
) is
2638 Set_Basic_Convention
(E
, Val
);
2640 if Ekind
(E
) in Access_Subprogram_Kind
2641 and then Has_Foreign_Convention
(E
)
2643 Set_Can_Use_Internal_Rep
(E
, False);
2646 -- If E is an object, including a component, and the type of E is an
2647 -- anonymous access type with no convention set, then also set the
2648 -- convention of the anonymous access type. We do not do this for
2649 -- anonymous protected types, since protected types always have the
2650 -- default convention.
2652 if Present
(Etype
(E
))
2653 and then (Is_Object
(E
)
2655 -- Allow E_Void (happens for pragma Convention appearing
2656 -- in the middle of a record applying to a component)
2658 or else Ekind
(E
) = E_Void
)
2661 Typ
: constant Entity_Id
:= Etype
(E
);
2664 if Ekind
(Typ
) in E_Anonymous_Access_Type
2665 | E_Anonymous_Access_Subprogram_Type
2666 and then not Has_Convention_Pragma
(Typ
)
2668 Set_Convention
(Typ
, Val
);
2669 Set_Has_Convention_Pragma
(Typ
);
2671 -- And for the access subprogram type, deal similarly with the
2672 -- designated E_Subprogram_Type, which is always internal.
2674 if Ekind
(Typ
) = E_Anonymous_Access_Subprogram_Type
then
2676 Dtype
: constant Entity_Id
:= Designated_Type
(Typ
);
2678 if Ekind
(Dtype
) = E_Subprogram_Type
then
2679 pragma Assert
(not Has_Convention_Pragma
(Dtype
));
2680 Set_Convention
(Dtype
, Val
);
2681 Set_Has_Convention_Pragma
(Dtype
);
2690 -----------------------
2691 -- Set_DIC_Procedure --
2692 -----------------------
2694 procedure Set_DIC_Procedure
(Id
: E
; V
: E
) is
2695 Base_Typ
: Entity_Id
;
2699 pragma Assert
(Is_Type
(Id
));
2701 Base_Typ
:= Base_Type
(Id
);
2702 Subps
:= Subprograms_For_Type
(Base_Typ
);
2705 Subps
:= New_Elmt_List
;
2706 Set_Subprograms_For_Type
(Base_Typ
, Subps
);
2709 Prepend_Elmt
(V
, Subps
);
2710 end Set_DIC_Procedure
;
2712 procedure Set_Partial_DIC_Procedure
(Id
: E
; V
: E
) is
2714 Set_DIC_Procedure
(Id
, V
);
2715 end Set_Partial_DIC_Procedure
;
2721 procedure Set_Float_Rep
2722 (Ignore_N
: Entity_Id
; Ignore_Val
: Float_Rep_Kind
) is
2724 pragma Assert
(Float_Rep_Kind
'First = Float_Rep_Kind
'Last);
2725 -- There is only one value, so we don't need to store it (see
2729 -----------------------------
2730 -- Set_Invariant_Procedure --
2731 -----------------------------
2733 procedure Set_Invariant_Procedure
(Id
: E
; V
: E
) is
2734 Base_Typ
: Entity_Id
;
2735 Subp_Elmt
: Elmt_Id
;
2736 Subp_Id
: Entity_Id
;
2740 pragma Assert
(Is_Type
(Id
));
2742 Base_Typ
:= Base_Type
(Id
);
2743 Subps
:= Subprograms_For_Type
(Base_Typ
);
2746 Subps
:= New_Elmt_List
;
2747 Set_Subprograms_For_Type
(Base_Typ
, Subps
);
2750 Subp_Elmt
:= First_Elmt
(Subps
);
2751 Prepend_Elmt
(V
, Subps
);
2753 -- Check for a duplicate invariant procedure
2755 while Present
(Subp_Elmt
) loop
2756 Subp_Id
:= Node
(Subp_Elmt
);
2758 if Is_Invariant_Procedure
(Subp_Id
) then
2759 raise Program_Error
;
2762 Next_Elmt
(Subp_Elmt
);
2764 end Set_Invariant_Procedure
;
2766 -------------------------------------
2767 -- Set_Partial_Invariant_Procedure --
2768 -------------------------------------
2770 procedure Set_Partial_Invariant_Procedure
(Id
: E
; V
: E
) is
2771 Base_Typ
: Entity_Id
;
2772 Subp_Elmt
: Elmt_Id
;
2773 Subp_Id
: Entity_Id
;
2777 pragma Assert
(Is_Type
(Id
));
2779 Base_Typ
:= Base_Type
(Id
);
2780 Subps
:= Subprograms_For_Type
(Base_Typ
);
2783 Subps
:= New_Elmt_List
;
2784 Set_Subprograms_For_Type
(Base_Typ
, Subps
);
2787 Subp_Elmt
:= First_Elmt
(Subps
);
2788 Prepend_Elmt
(V
, Subps
);
2790 -- Check for a duplicate partial invariant procedure
2792 while Present
(Subp_Elmt
) loop
2793 Subp_Id
:= Node
(Subp_Elmt
);
2795 if Is_Partial_Invariant_Procedure
(Subp_Id
) then
2796 raise Program_Error
;
2799 Next_Elmt
(Subp_Elmt
);
2801 end Set_Partial_Invariant_Procedure
;
2803 ----------------------------
2804 -- Set_Predicate_Function --
2805 ----------------------------
2807 procedure Set_Predicate_Function
(Id
: E
; V
: E
) is
2808 Subp_Elmt
: Elmt_Id
;
2809 Subp_Id
: Entity_Id
;
2813 pragma Assert
(Is_Type
(Id
) and then Has_Predicates
(Id
));
2815 Subps
:= Subprograms_For_Type
(Id
);
2818 Subps
:= New_Elmt_List
;
2819 Set_Subprograms_For_Type
(Id
, Subps
);
2822 Subp_Elmt
:= First_Elmt
(Subps
);
2823 Prepend_Elmt
(V
, Subps
);
2825 -- Check for a duplicate predication function
2827 while Present
(Subp_Elmt
) loop
2828 Subp_Id
:= Node
(Subp_Elmt
);
2830 if Ekind
(Subp_Id
) = E_Function
2831 and then Is_Predicate_Function
(Subp_Id
)
2833 raise Program_Error
;
2836 Next_Elmt
(Subp_Elmt
);
2838 end Set_Predicate_Function
;
2844 function Size_Clause
(Id
: E
) return Node_Id
is
2845 Result
: Node_Id
:= Get_Attribute_Definition_Clause
(Id
, Attribute_Size
);
2848 Result
:= Get_Attribute_Definition_Clause
(Id
, Attribute_Value_Size
);
2854 ------------------------
2855 -- Stream_Size_Clause --
2856 ------------------------
2858 function Stream_Size_Clause
(Id
: E
) return N
is
2860 return Get_Attribute_Definition_Clause
(Id
, Attribute_Stream_Size
);
2861 end Stream_Size_Clause
;
2867 function Subtype_Kind
(K
: Entity_Kind
) return Entity_Kind
is
2873 Kind
:= E_Access_Subtype
;
2875 when E_Array_Subtype
2878 Kind
:= E_Array_Subtype
;
2880 when E_Class_Wide_Subtype
2883 Kind
:= E_Class_Wide_Subtype
;
2885 when E_Decimal_Fixed_Point_Subtype
2886 | E_Decimal_Fixed_Point_Type
2888 Kind
:= E_Decimal_Fixed_Point_Subtype
;
2890 when E_Ordinary_Fixed_Point_Subtype
2891 | E_Ordinary_Fixed_Point_Type
2893 Kind
:= E_Ordinary_Fixed_Point_Subtype
;
2895 when E_Private_Subtype
2898 Kind
:= E_Private_Subtype
;
2900 when E_Limited_Private_Subtype
2901 | E_Limited_Private_Type
2903 Kind
:= E_Limited_Private_Subtype
;
2905 when E_Record_Subtype_With_Private
2906 | E_Record_Type_With_Private
2908 Kind
:= E_Record_Subtype_With_Private
;
2910 when E_Record_Subtype
2913 Kind
:= E_Record_Subtype
;
2915 when Enumeration_Kind
=>
2916 Kind
:= E_Enumeration_Subtype
;
2918 when E_Incomplete_Type
=>
2919 Kind
:= E_Incomplete_Subtype
;
2922 Kind
:= E_Floating_Point_Subtype
;
2924 when Signed_Integer_Kind
=>
2925 Kind
:= E_Signed_Integer_Subtype
;
2927 when Modular_Integer_Kind
=>
2928 Kind
:= E_Modular_Integer_Subtype
;
2930 when Protected_Kind
=>
2931 Kind
:= E_Protected_Subtype
;
2934 Kind
:= E_Task_Subtype
;
2937 raise Program_Error
;
2943 ---------------------
2944 -- Type_High_Bound --
2945 ---------------------
2947 function Type_High_Bound
(Id
: E
) return N
is
2948 Rng
: constant Node_Id
:= Scalar_Range
(Id
);
2950 if Nkind
(Rng
) = N_Subtype_Indication
then
2951 return High_Bound
(Range_Expression
(Constraint
(Rng
)));
2953 return High_Bound
(Rng
);
2955 end Type_High_Bound
;
2957 --------------------
2958 -- Type_Low_Bound --
2959 --------------------
2961 function Type_Low_Bound
(Id
: E
) return N
is
2962 Rng
: constant Node_Id
:= Scalar_Range
(Id
);
2964 if Nkind
(Rng
) = N_Subtype_Indication
then
2965 return Low_Bound
(Range_Expression
(Constraint
(Rng
)));
2967 return Low_Bound
(Rng
);
2971 ---------------------
2972 -- Underlying_Type --
2973 ---------------------
2975 function Underlying_Type
(Id
: E
) return Entity_Id
is
2977 -- For record_with_private the underlying type is always the direct full
2978 -- view. Never try to take the full view of the parent it does not make
2981 if Ekind
(Id
) = E_Record_Type_With_Private
then
2982 return Full_View
(Id
);
2984 -- If we have a class-wide type that comes from the limited view then we
2985 -- return the Underlying_Type of its nonlimited view.
2987 elsif Ekind
(Id
) = E_Class_Wide_Type
2988 and then From_Limited_With
(Id
)
2989 and then Present
(Non_Limited_View
(Id
))
2991 return Underlying_Type
(Non_Limited_View
(Id
));
2993 elsif Ekind
(Id
) in Incomplete_Or_Private_Kind
then
2995 -- If we have an incomplete or private type with a full view, then we
2996 -- return the Underlying_Type of this full view.
2998 if Present
(Full_View
(Id
)) then
2999 if Id
= Full_View
(Id
) then
3001 -- Previous error in declaration
3006 return Underlying_Type
(Full_View
(Id
));
3009 -- If we have a private type with an underlying full view, then we
3010 -- return the Underlying_Type of this underlying full view.
3012 elsif Ekind
(Id
) in Private_Kind
3013 and then Present
(Underlying_Full_View
(Id
))
3015 return Underlying_Type
(Underlying_Full_View
(Id
));
3017 -- If we have an incomplete entity that comes from the limited view
3018 -- then we return the Underlying_Type of its nonlimited view.
3020 elsif From_Limited_With
(Id
)
3021 and then Present
(Non_Limited_View
(Id
))
3023 return Underlying_Type
(Non_Limited_View
(Id
));
3025 -- Otherwise check for the case where we have a derived type or
3026 -- subtype, and if so get the Underlying_Type of the parent type.
3028 elsif Present
(Etype
(Id
)) and then Etype
(Id
) /= Id
then
3029 return Underlying_Type
(Etype
(Id
));
3031 -- Otherwise we have an incomplete or private type that has no full
3032 -- view, which means that we have not encountered the completion, so
3033 -- return Empty to indicate the underlying type is not yet known.
3039 -- For non-incomplete, non-private types, return the type itself. Also
3040 -- for entities that are not types at all return the entity itself.
3045 end Underlying_Type
;
3047 ------------------------
3048 -- Unlink_Next_Entity --
3049 ------------------------
3051 procedure Unlink_Next_Entity
(Id
: Entity_Id
) is
3052 Next
: constant Entity_Id
:= Next_Entity
(Id
);
3055 if Present
(Next
) then
3056 Set_Prev_Entity
(Next
, Empty
); -- Empty <-- Next
3059 Set_Next_Entity
(Id
, Empty
); -- Id --> Empty
3060 end Unlink_Next_Entity
;
3062 ----------------------------------
3063 -- Is_Volatile, Set_Is_Volatile --
3064 ----------------------------------
3066 function Is_Volatile
(Id
: E
) return B
is
3068 pragma Assert
(Nkind
(Id
) in N_Entity
);
3070 if Is_Type
(Id
) then
3071 return Is_Volatile_Type
(Base_Type
(Id
));
3073 return Is_Volatile_Object
(Id
);
3077 procedure Set_Is_Volatile
(Id
: E
; V
: B
:= True) is
3079 pragma Assert
(Nkind
(Id
) in N_Entity
);
3081 if Is_Type
(Id
) then
3082 Set_Is_Volatile_Type
(Id
, V
);
3084 Set_Is_Volatile_Object
(Id
, V
);
3086 end Set_Is_Volatile
;
3088 -----------------------
3089 -- Write_Entity_Info --
3090 -----------------------
3092 procedure Write_Entity_Info
(Id
: Entity_Id
; Prefix
: String) is
3094 procedure Write_Attribute
(Which
: String; Nam
: E
);
3095 -- Write attribute value with given string name
3097 procedure Write_Kind
(Id
: Entity_Id
);
3098 -- Write Ekind field of entity
3100 ---------------------
3101 -- Write_Attribute --
3102 ---------------------
3104 procedure Write_Attribute
(Which
: String; Nam
: E
) is
3108 Write_Int
(Int
(Nam
));
3110 Write_Name
(Chars
(Nam
));
3112 end Write_Attribute
;
3118 procedure Write_Kind
(Id
: Entity_Id
) is
3119 K
: constant String := Entity_Kind
'Image (Ekind
(Id
));
3123 Write_Str
(" Kind ");
3125 if Is_Type
(Id
) and then Is_Tagged_Type
(Id
) then
3126 Write_Str
("TAGGED ");
3129 Write_Str
(K
(3 .. K
'Length));
3132 if Is_Type
(Id
) and then Depends_On_Private
(Id
) then
3133 Write_Str
("Depends_On_Private ");
3137 -- Start of processing for Write_Entity_Info
3141 Write_Attribute
("Name ", Id
);
3142 Write_Int
(Int
(Id
));
3146 Write_Attribute
(" Type ", Etype
(Id
));
3148 if Id
/= Standard_Standard
then
3149 Write_Attribute
(" Scope ", Scope
(Id
));
3154 when Discrete_Kind
=>
3155 Write_Str
("Bounds: Id = ");
3157 if Present
(Scalar_Range
(Id
)) then
3158 Write_Int
(Int
(Type_Low_Bound
(Id
)));
3159 Write_Str
(" .. Id = ");
3160 Write_Int
(Int
(Type_High_Bound
(Id
)));
3162 Write_Str
("Empty");
3173 (" Component Type ", Component_Type
(Id
));
3176 Write_Str
(" Indexes ");
3178 Index
:= First_Index
(Id
);
3179 while Present
(Index
) loop
3180 Write_Attribute
(" ", Etype
(Index
));
3189 (" Directly Designated Type ",
3190 Directly_Designated_Type
(Id
));
3193 when Overloadable_Kind
=>
3194 if Present
(Homonym
(Id
)) then
3195 Write_Str
(" Homonym ");
3196 Write_Name
(Chars
(Homonym
(Id
)));
3198 Write_Int
(Int
(Homonym
(Id
)));
3205 if Ekind
(Scope
(Id
)) in Record_Kind
then
3207 " Original_Record_Component ",
3208 Original_Record_Component
(Id
));
3209 Write_Int
(Int
(Original_Record_Component
(Id
)));
3216 end Write_Entity_Info
;
3218 -------------------------
3219 -- Iterator Procedures --
3220 -------------------------
3222 procedure Next_Component
(N
: in out Node_Id
) is
3224 N
:= Next_Component
(N
);
3227 procedure Next_Component_Or_Discriminant
(N
: in out Node_Id
) is
3229 N
:= Next_Component_Or_Discriminant
(N
);
3230 end Next_Component_Or_Discriminant
;
3232 procedure Next_Discriminant
(N
: in out Node_Id
) is
3234 N
:= Next_Discriminant
(N
);
3235 end Next_Discriminant
;
3237 procedure Next_Formal
(N
: in out Node_Id
) is
3239 N
:= Next_Formal
(N
);
3242 procedure Next_Formal_With_Extras
(N
: in out Node_Id
) is
3244 N
:= Next_Formal_With_Extras
(N
);
3245 end Next_Formal_With_Extras
;
3247 procedure Next_Index
(N
: in out Node_Id
) is
3249 N
:= Next_Index
(N
);
3252 procedure Next_Inlined_Subprogram
(N
: in out Node_Id
) is
3254 N
:= Next_Inlined_Subprogram
(N
);
3255 end Next_Inlined_Subprogram
;
3257 procedure Next_Literal
(N
: in out Node_Id
) is
3259 N
:= Next_Literal
(N
);
3262 procedure Next_Stored_Discriminant
(N
: in out Node_Id
) is
3264 N
:= Next_Stored_Discriminant
(N
);
3265 end Next_Stored_Discriminant
;