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_Aggregate_Type
(Id
: E
) return B
is
206 return Ekind
(Id
) in Aggregate_Kind
;
207 end Is_Aggregate_Type
;
209 function Is_Anonymous_Access_Type
(Id
: E
) return B
is
211 return Ekind
(Id
) in Anonymous_Access_Kind
;
212 end Is_Anonymous_Access_Type
;
214 function Is_Array_Type
(Id
: E
) return B
is
216 return Ekind
(Id
) in Array_Kind
;
219 function Is_Assignable
(Id
: E
) return B
is
221 return Ekind
(Id
) in Assignable_Kind
;
224 function Is_Class_Wide_Type
(Id
: E
) return B
is
226 return Ekind
(Id
) in Class_Wide_Kind
;
227 end Is_Class_Wide_Type
;
229 function Is_Composite_Type
(Id
: E
) return B
is
231 return Ekind
(Id
) in Composite_Kind
;
232 end Is_Composite_Type
;
234 function Is_Concurrent_Body
(Id
: E
) return B
is
236 return Ekind
(Id
) in Concurrent_Body_Kind
;
237 end Is_Concurrent_Body
;
239 function Is_Concurrent_Type
(Id
: E
) return B
is
241 return Ekind
(Id
) in Concurrent_Kind
;
242 end Is_Concurrent_Type
;
244 function Is_Decimal_Fixed_Point_Type
(Id
: E
) return B
is
246 return Ekind
(Id
) in Decimal_Fixed_Point_Kind
;
247 end Is_Decimal_Fixed_Point_Type
;
249 function Is_Digits_Type
(Id
: E
) return B
is
251 return Ekind
(Id
) in Digits_Kind
;
254 function Is_Discrete_Or_Fixed_Point_Type
(Id
: E
) return B
is
256 return Ekind
(Id
) in Discrete_Or_Fixed_Point_Kind
;
257 end Is_Discrete_Or_Fixed_Point_Type
;
259 function Is_Discrete_Type
(Id
: E
) return B
is
261 return Ekind
(Id
) in Discrete_Kind
;
262 end Is_Discrete_Type
;
264 function Is_Elementary_Type
(Id
: E
) return B
is
266 return Ekind
(Id
) in Elementary_Kind
;
267 end Is_Elementary_Type
;
269 function Is_Entry
(Id
: E
) return B
is
271 return Ekind
(Id
) in Entry_Kind
;
274 function Is_Enumeration_Type
(Id
: E
) return B
is
276 return Ekind
(Id
) in Enumeration_Kind
;
277 end Is_Enumeration_Type
;
279 function Is_Fixed_Point_Type
(Id
: E
) return B
is
281 return Ekind
(Id
) in Fixed_Point_Kind
;
282 end Is_Fixed_Point_Type
;
284 function Is_Floating_Point_Type
(Id
: E
) return B
is
286 return Ekind
(Id
) in Float_Kind
;
287 end Is_Floating_Point_Type
;
289 function Is_Formal
(Id
: E
) return B
is
291 return Ekind
(Id
) in Formal_Kind
;
294 function Is_Formal_Object
(Id
: E
) return B
is
296 return Ekind
(Id
) in Formal_Object_Kind
;
297 end Is_Formal_Object
;
299 function Is_Generic_Subprogram
(Id
: E
) return B
is
301 return Ekind
(Id
) in Generic_Subprogram_Kind
;
302 end Is_Generic_Subprogram
;
304 function Is_Generic_Unit
(Id
: E
) return B
is
306 return Ekind
(Id
) in Generic_Unit_Kind
;
309 function Is_Ghost_Entity
(Id
: E
) return Boolean is
311 return Is_Checked_Ghost_Entity
(Id
) or else Is_Ignored_Ghost_Entity
(Id
);
314 function Is_Incomplete_Or_Private_Type
(Id
: E
) return B
is
316 return Ekind
(Id
) in Incomplete_Or_Private_Kind
;
317 end Is_Incomplete_Or_Private_Type
;
319 function Is_Incomplete_Type
(Id
: E
) return B
is
321 return Ekind
(Id
) in Incomplete_Kind
;
322 end Is_Incomplete_Type
;
324 function Is_Integer_Type
(Id
: E
) return B
is
326 return Ekind
(Id
) in Integer_Kind
;
329 function Is_Modular_Integer_Type
(Id
: E
) return B
is
331 return Ekind
(Id
) in Modular_Integer_Kind
;
332 end Is_Modular_Integer_Type
;
334 function Is_Named_Access_Type
(Id
: E
) return B
is
336 return Ekind
(Id
) in Named_Access_Kind
;
337 end Is_Named_Access_Type
;
339 function Is_Named_Number
(Id
: E
) return B
is
341 return Ekind
(Id
) in Named_Kind
;
344 function Is_Numeric_Type
(Id
: E
) return B
is
346 return Ekind
(Id
) in Numeric_Kind
;
349 function Is_Object
(Id
: E
) return B
is
351 return Ekind
(Id
) in Object_Kind
;
354 function Is_Ordinary_Fixed_Point_Type
(Id
: E
) return B
is
356 return Ekind
(Id
) in Ordinary_Fixed_Point_Kind
;
357 end Is_Ordinary_Fixed_Point_Type
;
359 function Is_Overloadable
(Id
: E
) return B
is
361 return Ekind
(Id
) in Overloadable_Kind
;
364 function Is_Private_Type
(Id
: E
) return B
is
366 return Ekind
(Id
) in Private_Kind
;
369 function Is_Protected_Type
(Id
: E
) return B
is
371 return Ekind
(Id
) in Protected_Kind
;
372 end Is_Protected_Type
;
374 function Is_Real_Type
(Id
: E
) return B
is
376 return Ekind
(Id
) in Real_Kind
;
379 function Is_Record_Type
(Id
: E
) return B
is
381 return Ekind
(Id
) in Record_Kind
;
384 function Is_Scalar_Type
(Id
: E
) return B
is
386 return Ekind
(Id
) in Scalar_Kind
;
389 function Is_Signed_Integer_Type
(Id
: E
) return B
is
391 return Ekind
(Id
) in Signed_Integer_Kind
;
392 end Is_Signed_Integer_Type
;
394 function Is_Subprogram
(Id
: E
) return B
is
396 return Ekind
(Id
) in Subprogram_Kind
;
399 function Is_Subprogram_Or_Entry
(Id
: E
) return B
is
401 return Ekind
(Id
) in Subprogram_Kind
403 Ekind
(Id
) in Entry_Kind
;
404 end Is_Subprogram_Or_Entry
;
406 function Is_Subprogram_Or_Generic_Subprogram
(Id
: E
) return B
is
408 return Ekind
(Id
) in Subprogram_Kind
410 Ekind
(Id
) in Generic_Subprogram_Kind
;
411 end Is_Subprogram_Or_Generic_Subprogram
;
413 function Is_Task_Type
(Id
: E
) return B
is
415 return Ekind
(Id
) in Task_Kind
;
418 function Is_Type
(Id
: E
) return B
is
420 return Ekind
(Id
) in Type_Kind
;
423 ------------------------------------------
424 -- Type Representation Attribute Fields --
425 ------------------------------------------
427 function Known_Alignment
(E
: Entity_Id
) return B
is
429 -- For some reason, Empty is passed to this sometimes
431 return No
(E
) or else not Field_Is_Initial_Zero
(E
, F_Alignment
);
434 procedure Reinit_Alignment
(Id
: E
) is
436 Reinit_Field_To_Zero
(Id
, F_Alignment
);
437 end Reinit_Alignment
;
439 procedure Copy_Alignment
(To
, From
: E
) is
441 if Known_Alignment
(From
) then
442 Set_Alignment
(To
, Alignment
(From
));
444 Reinit_Alignment
(To
);
448 function Known_Component_Bit_Offset
(E
: Entity_Id
) return B
is
450 return Present
(Component_Bit_Offset
(E
));
451 end Known_Component_Bit_Offset
;
453 function Known_Static_Component_Bit_Offset
(E
: Entity_Id
) return B
is
455 return Known_Component_Bit_Offset
(E
)
456 and then Component_Bit_Offset
(E
) >= Uint_0
;
457 end Known_Static_Component_Bit_Offset
;
459 function Known_Component_Size
(E
: Entity_Id
) return B
is
461 return Present
(Component_Size
(E
));
462 end Known_Component_Size
;
464 function Known_Static_Component_Size
(E
: Entity_Id
) return B
is
466 return Known_Component_Size
(E
) and then Component_Size
(E
) >= Uint_0
;
467 end Known_Static_Component_Size
;
469 function Known_Esize
(E
: Entity_Id
) return B
is
471 return Present
(Esize
(E
));
474 function Known_Static_Esize
(E
: Entity_Id
) return B
is
476 return Known_Esize
(E
)
477 and then Esize
(E
) >= Uint_0
478 and then not Is_Generic_Type
(E
);
479 end Known_Static_Esize
;
481 procedure Reinit_Esize
(Id
: E
) is
483 Reinit_Field_To_Zero
(Id
, F_Esize
);
486 procedure Copy_Esize
(To
, From
: E
) is
488 if Known_Esize
(From
) then
489 Set_Esize
(To
, Esize
(From
));
495 function Known_Normalized_First_Bit
(E
: Entity_Id
) return B
is
497 return Present
(Normalized_First_Bit
(E
));
498 end Known_Normalized_First_Bit
;
500 function Known_Static_Normalized_First_Bit
(E
: Entity_Id
) return B
is
502 return Known_Normalized_First_Bit
(E
)
503 and then Normalized_First_Bit
(E
) >= Uint_0
;
504 end Known_Static_Normalized_First_Bit
;
506 function Known_Normalized_Position
(E
: Entity_Id
) return B
is
508 return Present
(Normalized_Position
(E
));
509 end Known_Normalized_Position
;
511 function Known_Static_Normalized_Position
(E
: Entity_Id
) return B
is
513 return Known_Normalized_Position
(E
)
514 and then Normalized_Position
(E
) >= Uint_0
;
515 end Known_Static_Normalized_Position
;
517 function Known_RM_Size
(E
: Entity_Id
) return B
is
519 return Present
(RM_Size
(E
));
522 function Known_Static_RM_Size
(E
: Entity_Id
) return B
is
524 return Known_RM_Size
(E
)
525 and then RM_Size
(E
) >= Uint_0
526 and then not Is_Generic_Type
(E
);
527 end Known_Static_RM_Size
;
529 procedure Reinit_RM_Size
(Id
: E
) is
531 Reinit_Field_To_Zero
(Id
, F_RM_Size
);
534 procedure Copy_RM_Size
(To
, From
: E
) is
536 if Known_RM_Size
(From
) then
537 Set_RM_Size
(To
, RM_Size
(From
));
543 -------------------------------
544 -- Reinit_Component_Location --
545 -------------------------------
547 procedure Reinit_Component_Location
(Id
: E
) is
549 Set_Normalized_First_Bit
(Id
, No_Uint
);
550 Set_Component_Bit_Offset
(Id
, No_Uint
);
552 Set_Normalized_Position
(Id
, No_Uint
);
553 end Reinit_Component_Location
;
555 ------------------------------
556 -- Reinit_Object_Size_Align --
557 ------------------------------
559 procedure Reinit_Object_Size_Align
(Id
: E
) is
562 Reinit_Alignment
(Id
);
563 end Reinit_Object_Size_Align
;
569 procedure Init_Size
(Id
: E
; V
: Int
) is
571 pragma Assert
(Is_Type
(Id
));
572 pragma Assert
(not Known_Esize
(Id
) or else Esize
(Id
) = V
);
573 pragma Assert
(not Known_RM_Size
(Id
) or else RM_Size
(Id
) = V
);
575 Set_Esize
(Id
, UI_From_Int
(V
));
576 Set_RM_Size
(Id
, UI_From_Int
(V
));
579 -----------------------
580 -- Reinit_Size_Align --
581 -----------------------
583 procedure Reinit_Size_Align
(Id
: E
) is
585 pragma Assert
(Ekind
(Id
) in Type_Kind | E_Void
);
588 Reinit_Alignment
(Id
);
589 end Reinit_Size_Align
;
595 function Address_Clause
(Id
: E
) return Node_Id
is
597 return Get_Attribute_Definition_Clause
(Id
, Attribute_Address
);
604 function Aft_Value
(Id
: E
) return U
is
606 Delta_Val
: Ureal
:= Delta_Value
(Id
);
608 while Delta_Val
< Ureal_Tenth
loop
609 Delta_Val
:= Delta_Val
* Ureal_10
;
610 Result
:= Result
+ 1;
613 return UI_From_Int
(Result
);
616 ----------------------
617 -- Alignment_Clause --
618 ----------------------
620 function Alignment_Clause
(Id
: E
) return Node_Id
is
622 return Get_Attribute_Definition_Clause
(Id
, Attribute_Alignment
);
623 end Alignment_Clause
;
629 procedure Append_Entity
(Id
: Entity_Id
; Scop
: Entity_Id
) is
630 Last
: constant Entity_Id
:= Last_Entity
(Scop
);
633 Set_Scope
(Id
, Scop
);
634 Set_Prev_Entity
(Id
, Empty
); -- Empty <-- Id
636 -- The entity chain is empty
639 Set_First_Entity
(Scop
, Id
);
641 -- Otherwise the entity chain has at least one element
644 Link_Entities
(Last
, Id
); -- Last <-- Id, Last --> Id
647 -- NOTE: The setting of the Next_Entity attribute of Id must happen
648 -- here as opposed to at the beginning of the routine because doing
649 -- so causes the binder to hang. It is not clear why ???
651 Set_Next_Entity
(Id
, Empty
); -- Id --> Empty
653 Set_Last_Entity
(Scop
, Id
);
660 function Base_Type
(Id
: E
) return E
is
662 if Is_Base_Type
(Id
) then
665 pragma Assert
(Is_Type
(Id
));
670 ----------------------
671 -- Declaration_Node --
672 ----------------------
674 function Declaration_Node
(Id
: E
) return Node_Id
is
678 if Ekind
(Id
) = E_Incomplete_Type
679 and then Present
(Full_View
(Id
))
681 P
:= Parent
(Full_View
(Id
));
686 while Nkind
(P
) in N_Selected_Component | N_Expanded_Name
687 or else (Nkind
(P
) = N_Defining_Program_Unit_Name
688 and then Is_Child_Unit
(Id
))
694 and then Nkind
(P
) not in
695 N_Full_Type_Declaration | N_Subtype_Declaration
700 -- Declarations are sometimes removed by replacing them with other
701 -- irrelevant nodes. For example, a declare expression can be turned
702 -- into a literal by constant folding. In these cases we want to
706 N_Assignment_Statement
708 | N_Procedure_Call_Statement
709 | N_Subtype_Indication
715 -- The following Assert indicates what kinds of nodes can be returned;
716 -- they are not all "declarations".
718 if Serious_Errors_Detected
= 0 then
720 (Nkind
(P
) in N_Is_Decl | N_Empty
,
721 "Declaration_Node incorrect kind: " & Node_Kind
'Image (Nkind
(P
)));
725 end Declaration_Node
;
727 ---------------------
728 -- Designated_Type --
729 ---------------------
731 function Designated_Type
(Id
: E
) return E
is
732 Desig_Type
: Entity_Id
;
735 Desig_Type
:= Directly_Designated_Type
(Id
);
737 if No
(Desig_Type
) then
738 pragma Assert
(Error_Posted
(Id
));
742 if Is_Incomplete_Type
(Desig_Type
)
743 and then Present
(Full_View
(Desig_Type
))
745 return Full_View
(Desig_Type
);
748 if Is_Class_Wide_Type
(Desig_Type
)
749 and then Is_Incomplete_Type
(Etype
(Desig_Type
))
750 and then Present
(Full_View
(Etype
(Desig_Type
)))
751 and then Present
(Class_Wide_Type
(Full_View
(Etype
(Desig_Type
))))
753 return Class_Wide_Type
(Full_View
(Etype
(Desig_Type
)));
759 ----------------------
760 -- Entry_Index_Type --
761 ----------------------
763 function Entry_Index_Type
(Id
: E
) return E
is
765 pragma Assert
(Ekind
(Id
) = E_Entry_Family
);
766 return Etype
(Discrete_Subtype_Definition
(Parent
(Id
)));
767 end Entry_Index_Type
;
769 ---------------------
770 -- First_Component --
771 ---------------------
773 function First_Component
(Id
: E
) return Entity_Id
is
778 (Is_Concurrent_Type
(Id
)
779 or else Is_Incomplete_Or_Private_Type
(Id
)
780 or else Is_Record_Type
(Id
));
782 Comp_Id
:= First_Entity
(Id
);
783 while Present
(Comp_Id
) loop
784 exit when Ekind
(Comp_Id
) = E_Component
;
785 Next_Entity
(Comp_Id
);
791 -------------------------------------
792 -- First_Component_Or_Discriminant --
793 -------------------------------------
795 function First_Component_Or_Discriminant
(Id
: E
) return Entity_Id
is
800 (Is_Concurrent_Type
(Id
)
801 or else Is_Incomplete_Or_Private_Type
(Id
)
802 or else Is_Record_Type
(Id
)
803 or else Has_Discriminants
(Id
));
805 Comp_Id
:= First_Entity
(Id
);
806 while Present
(Comp_Id
) loop
807 exit when Ekind
(Comp_Id
) in E_Component | E_Discriminant
;
808 Next_Entity
(Comp_Id
);
812 end First_Component_Or_Discriminant
;
818 function First_Formal
(Id
: E
) return Entity_Id
is
823 (Is_Generic_Subprogram
(Id
)
824 or else Is_Overloadable
(Id
)
825 or else Ekind
(Id
) in E_Entry_Family
827 | E_Subprogram_Type
);
829 if Ekind
(Id
) = E_Enumeration_Literal
then
833 Formal
:= First_Entity
(Id
);
835 -- Deal with the common, non-generic case first
837 if No
(Formal
) or else Is_Formal
(Formal
) then
841 -- The first/next entity chain of a generic subprogram contains all
842 -- generic formal parameters, followed by the formal parameters.
844 if Is_Generic_Subprogram
(Id
) then
845 while Present
(Formal
) and then not Is_Formal
(Formal
) loop
846 Next_Entity
(Formal
);
855 ------------------------------
856 -- First_Formal_With_Extras --
857 ------------------------------
859 function First_Formal_With_Extras
(Id
: E
) return Entity_Id
is
864 (Is_Generic_Subprogram
(Id
)
865 or else Is_Overloadable
(Id
)
866 or else Ekind
(Id
) in E_Entry_Family
868 | E_Subprogram_Type
);
870 if Ekind
(Id
) = E_Enumeration_Literal
then
874 Formal
:= First_Entity
(Id
);
876 -- The first/next entity chain of a generic subprogram contains all
877 -- generic formal parameters, followed by the formal parameters. Go
878 -- directly to the parameters by skipping the formal part.
880 if Is_Generic_Subprogram
(Id
) then
881 while Present
(Formal
) and then not Is_Formal
(Formal
) loop
882 Next_Entity
(Formal
);
886 if Present
(Formal
) and then Is_Formal
(Formal
) then
889 return Extra_Formals
(Id
); -- Empty if no extra formals
892 end First_Formal_With_Extras
;
898 function Float_Rep
(N
: Entity_Id
) return Float_Rep_Kind
is
899 pragma Unreferenced
(N
);
900 pragma Assert
(Float_Rep_Kind
'First = Float_Rep_Kind
'Last);
902 -- There is only one value, so we don't need to store it, see types.ads.
904 Val
: constant Float_Rep_Kind
:= IEEE_Binary
;
910 -------------------------------------
911 -- Get_Attribute_Definition_Clause --
912 -------------------------------------
914 function Get_Attribute_Definition_Clause
916 Id
: Attribute_Id
) return Node_Id
921 N
:= First_Rep_Item
(E
);
922 while Present
(N
) loop
923 if Nkind
(N
) = N_Attribute_Definition_Clause
924 and then Get_Attribute_Id
(Chars
(N
)) = Id
933 end Get_Attribute_Definition_Clause
;
935 ---------------------------
936 -- Get_Class_Wide_Pragma --
937 ---------------------------
939 function Get_Class_Wide_Pragma
941 Id
: Pragma_Id
) return Node_Id
947 Items
:= Contract
(E
);
953 Item
:= Pre_Post_Conditions
(Items
);
954 while Present
(Item
) loop
955 if Nkind
(Item
) = N_Pragma
956 and then Get_Pragma_Id
(Pragma_Name_Unmapped
(Item
)) = Id
957 and then Class_Present
(Item
)
962 Item
:= Next_Pragma
(Item
);
966 end Get_Class_Wide_Pragma
;
972 function Get_Full_View
(T
: Entity_Id
) return Entity_Id
is
974 if Is_Incomplete_Type
(T
) and then Present
(Full_View
(T
)) then
975 return Full_View
(T
);
977 elsif Is_Class_Wide_Type
(T
)
978 and then Is_Incomplete_Type
(Root_Type
(T
))
979 and then Present
(Full_View
(Root_Type
(T
)))
981 return Class_Wide_Type
(Full_View
(Root_Type
(T
)));
992 function Get_Pragma
(E
: Entity_Id
; Id
: Pragma_Id
) return Node_Id
is
994 -- Classification pragmas
996 Is_CLS
: constant Boolean :=
997 Id
= Pragma_Abstract_State
or else
998 Id
= Pragma_Attach_Handler
or else
999 Id
= Pragma_Async_Readers
or else
1000 Id
= Pragma_Async_Writers
or else
1001 Id
= Pragma_Constant_After_Elaboration
or else
1002 Id
= Pragma_Depends
or else
1003 Id
= Pragma_Effective_Reads
or else
1004 Id
= Pragma_Effective_Writes
or else
1005 Id
= Pragma_Extensions_Visible
or else
1006 Id
= Pragma_Global
or else
1007 Id
= Pragma_Initial_Condition
or else
1008 Id
= Pragma_Initializes
or else
1009 Id
= Pragma_Interrupt_Handler
or else
1010 Id
= Pragma_No_Caching
or else
1011 Id
= Pragma_Part_Of
or else
1012 Id
= Pragma_Refined_Depends
or else
1013 Id
= Pragma_Refined_Global
or else
1014 Id
= Pragma_Refined_State
or else
1015 Id
= Pragma_Volatile_Function
;
1017 -- Contract / subprogram variant / test case pragmas
1019 Is_CTC
: constant Boolean :=
1020 Id
= Pragma_Contract_Cases
or else
1021 Id
= Pragma_Subprogram_Variant
or else
1022 Id
= Pragma_Test_Case
;
1024 -- Pre / postcondition pragmas
1026 Is_PPC
: constant Boolean :=
1027 Id
= Pragma_Precondition
or else
1028 Id
= Pragma_Postcondition
or else
1029 Id
= Pragma_Refined_Post
;
1031 In_Contract
: constant Boolean := Is_CLS
or Is_CTC
or Is_PPC
;
1037 -- Handle pragmas that appear in N_Contract nodes. Those have to be
1038 -- extracted from their specialized list.
1041 Items
:= Contract
(E
);
1047 Item
:= Classifications
(Items
);
1050 Item
:= Contract_Test_Cases
(Items
);
1053 Item
:= Pre_Post_Conditions
(Items
);
1059 Item
:= First_Rep_Item
(E
);
1062 while Present
(Item
) loop
1063 if Nkind
(Item
) = N_Pragma
1064 and then Get_Pragma_Id
(Pragma_Name_Unmapped
(Item
)) = Id
1068 -- All nodes in N_Contract are chained using Next_Pragma
1070 elsif In_Contract
then
1071 Item
:= Next_Pragma
(Item
);
1076 Next_Rep_Item
(Item
);
1083 --------------------------------------
1084 -- Get_Record_Representation_Clause --
1085 --------------------------------------
1087 function Get_Record_Representation_Clause
(E
: Entity_Id
) return Node_Id
is
1091 N
:= First_Rep_Item
(E
);
1092 while Present
(N
) loop
1093 if Nkind
(N
) = N_Record_Representation_Clause
then
1101 end Get_Record_Representation_Clause
;
1103 ------------------------
1104 -- Has_Attach_Handler --
1105 ------------------------
1107 function Has_Attach_Handler
(Id
: E
) return B
is
1111 pragma Assert
(Is_Protected_Type
(Id
));
1113 Ritem
:= First_Rep_Item
(Id
);
1114 while Present
(Ritem
) loop
1115 if Nkind
(Ritem
) = N_Pragma
1116 and then Pragma_Name
(Ritem
) = Name_Attach_Handler
1120 Next_Rep_Item
(Ritem
);
1125 end Has_Attach_Handler
;
1131 function Has_DIC
(Id
: E
) return B
is
1133 return Has_Own_DIC
(Id
) or else Has_Inherited_DIC
(Id
);
1140 function Has_Entries
(Id
: E
) return B
is
1144 pragma Assert
(Is_Concurrent_Type
(Id
));
1146 Ent
:= First_Entity
(Id
);
1147 while Present
(Ent
) loop
1148 if Is_Entry
(Ent
) then
1158 ----------------------------
1159 -- Has_Foreign_Convention --
1160 ----------------------------
1162 function Has_Foreign_Convention
(Id
: E
) return B
is
1164 -- While regular Intrinsics such as the Standard operators fit in the
1165 -- "Ada" convention, those with an Interface_Name materialize GCC
1166 -- builtin imports for which Ada special treatments shouldn't apply.
1168 return Convention
(Id
) in Foreign_Convention
1169 or else (Convention
(Id
) = Convention_Intrinsic
1170 and then Present
(Interface_Name
(Id
)));
1171 end Has_Foreign_Convention
;
1173 ---------------------------
1174 -- Has_Interrupt_Handler --
1175 ---------------------------
1177 function Has_Interrupt_Handler
(Id
: E
) return B
is
1181 pragma Assert
(Is_Protected_Type
(Id
));
1183 Ritem
:= First_Rep_Item
(Id
);
1184 while Present
(Ritem
) loop
1185 if Nkind
(Ritem
) = N_Pragma
1186 and then Pragma_Name
(Ritem
) = Name_Interrupt_Handler
1190 Next_Rep_Item
(Ritem
);
1195 end Has_Interrupt_Handler
;
1197 --------------------
1198 -- Has_Invariants --
1199 --------------------
1201 function Has_Invariants
(Id
: E
) return B
is
1203 return Has_Own_Invariants
(Id
) or else Has_Inherited_Invariants
(Id
);
1206 --------------------------
1207 -- Has_Limited_View --
1208 --------------------------
1210 function Has_Limited_View
(Id
: E
) return B
is
1212 return Ekind
(Id
) = E_Package
1213 and then not Is_Generic_Instance
(Id
)
1214 and then Present
(Limited_View
(Id
));
1215 end Has_Limited_View
;
1217 --------------------------
1218 -- Has_Non_Limited_View --
1219 --------------------------
1221 function Has_Non_Limited_View
(Id
: E
) return B
is
1223 return (Ekind
(Id
) in Incomplete_Kind
1224 or else Ekind
(Id
) in Class_Wide_Kind
1225 or else Ekind
(Id
) = E_Abstract_State
)
1226 and then Present
(Non_Limited_View
(Id
));
1227 end Has_Non_Limited_View
;
1229 ---------------------------------
1230 -- Has_Non_Null_Abstract_State --
1231 ---------------------------------
1233 function Has_Non_Null_Abstract_State
(Id
: E
) return B
is
1235 pragma Assert
(Is_Package_Or_Generic_Package
(Id
));
1238 Present
(Abstract_States
(Id
))
1240 not Is_Null_State
(Node
(First_Elmt
(Abstract_States
(Id
))));
1241 end Has_Non_Null_Abstract_State
;
1243 -------------------------------------
1244 -- Has_Non_Null_Visible_Refinement --
1245 -------------------------------------
1247 function Has_Non_Null_Visible_Refinement
(Id
: E
) return B
is
1248 Constits
: Elist_Id
;
1251 -- "Refinement" is a concept applicable only to abstract states
1253 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
1254 Constits
:= Refinement_Constituents
(Id
);
1256 -- A partial refinement is always non-null. For a full refinement to be
1257 -- non-null, the first constituent must be anything other than null.
1260 Has_Partial_Visible_Refinement
(Id
)
1261 or else (Has_Visible_Refinement
(Id
)
1262 and then Present
(Constits
)
1263 and then Nkind
(Node
(First_Elmt
(Constits
))) /= N_Null
);
1264 end Has_Non_Null_Visible_Refinement
;
1266 -----------------------------
1267 -- Has_Null_Abstract_State --
1268 -----------------------------
1270 function Has_Null_Abstract_State
(Id
: E
) return B
is
1271 pragma Assert
(Is_Package_Or_Generic_Package
(Id
));
1273 States
: constant Elist_Id
:= Abstract_States
(Id
);
1276 -- Check first available state of related package. A null abstract
1277 -- state always appears as the sole element of the state list.
1281 and then Is_Null_State
(Node
(First_Elmt
(States
)));
1282 end Has_Null_Abstract_State
;
1284 ---------------------------------
1285 -- Has_Null_Visible_Refinement --
1286 ---------------------------------
1288 function Has_Null_Visible_Refinement
(Id
: E
) return B
is
1289 Constits
: Elist_Id
;
1292 -- "Refinement" is a concept applicable only to abstract states
1294 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
1295 Constits
:= Refinement_Constituents
(Id
);
1297 -- For a refinement to be null, the state's sole constituent must be a
1301 Has_Visible_Refinement
(Id
)
1302 and then Present
(Constits
)
1303 and then Nkind
(Node
(First_Elmt
(Constits
))) = N_Null
;
1304 end Has_Null_Visible_Refinement
;
1306 --------------------
1307 -- Has_Unmodified --
1308 --------------------
1310 function Has_Unmodified
(E
: Entity_Id
) return Boolean is
1312 if Has_Pragma_Unmodified
(E
) then
1314 elsif Warnings_Off
(E
) then
1315 Set_Warnings_Off_Used_Unmodified
(E
);
1322 ---------------------
1323 -- Has_Unreferenced --
1324 ---------------------
1326 function Has_Unreferenced
(E
: Entity_Id
) return Boolean is
1328 if Has_Pragma_Unreferenced
(E
) then
1330 elsif Warnings_Off
(E
) then
1331 Set_Warnings_Off_Used_Unreferenced
(E
);
1336 end Has_Unreferenced
;
1338 ----------------------
1339 -- Has_Warnings_Off --
1340 ----------------------
1342 function Has_Warnings_Off
(E
: Entity_Id
) return Boolean is
1344 if Warnings_Off
(E
) then
1345 Set_Warnings_Off_Used
(E
);
1350 end Has_Warnings_Off
;
1352 ------------------------------
1353 -- Implementation_Base_Type --
1354 ------------------------------
1356 function Implementation_Base_Type
(Id
: E
) return E
is
1361 Bastyp
:= Base_Type
(Id
);
1363 if Is_Incomplete_Or_Private_Type
(Bastyp
) then
1364 Imptyp
:= Underlying_Type
(Bastyp
);
1366 -- If we have an implementation type, then just return it,
1367 -- otherwise we return the Base_Type anyway. This can only
1368 -- happen in error situations and should avoid some error bombs.
1370 if Present
(Imptyp
) then
1371 return Base_Type
(Imptyp
);
1379 end Implementation_Base_Type
;
1381 -------------------------
1382 -- Invariant_Procedure --
1383 -------------------------
1385 function Invariant_Procedure
(Id
: E
) return Entity_Id
is
1386 Subp_Elmt
: Elmt_Id
;
1387 Subp_Id
: Entity_Id
;
1391 pragma Assert
(Is_Type
(Id
));
1393 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
1395 if Present
(Subps
) then
1396 Subp_Elmt
:= First_Elmt
(Subps
);
1397 while Present
(Subp_Elmt
) loop
1398 Subp_Id
:= Node
(Subp_Elmt
);
1400 if Is_Invariant_Procedure
(Subp_Id
) then
1404 Next_Elmt
(Subp_Elmt
);
1409 end Invariant_Procedure
;
1415 -- Global flag table allowing rapid computation of this function
1417 Entity_Is_Base_Type
: constant array (Entity_Kind
) of Boolean :=
1418 (E_Enumeration_Subtype |
1419 E_Incomplete_Subtype |
1420 E_Signed_Integer_Subtype |
1421 E_Modular_Integer_Subtype |
1422 E_Floating_Point_Subtype |
1423 E_Ordinary_Fixed_Point_Subtype |
1424 E_Decimal_Fixed_Point_Subtype |
1428 E_Record_Subtype_With_Private |
1429 E_Limited_Private_Subtype |
1431 E_Protected_Subtype |
1433 E_String_Literal_Subtype |
1434 E_Class_Wide_Subtype
=> False,
1437 function Is_Base_Type
(Id
: E
) return Boolean is
1439 return Entity_Is_Base_Type
(Ekind
(Id
));
1442 ---------------------
1443 -- Is_Boolean_Type --
1444 ---------------------
1446 function Is_Boolean_Type
(Id
: E
) return B
is
1448 return Root_Type
(Id
) = Standard_Boolean
;
1449 end Is_Boolean_Type
;
1451 ------------------------
1452 -- Is_Constant_Object --
1453 ------------------------
1455 function Is_Constant_Object
(Id
: E
) return B
is
1457 return Ekind
(Id
) in E_Constant | E_In_Parameter | E_Loop_Parameter
;
1458 end Is_Constant_Object
;
1464 function Is_Controlled
(Id
: E
) return B
is
1466 return Is_Controlled_Active
(Id
) and then not Disable_Controlled
(Id
);
1469 --------------------
1470 -- Is_Discriminal --
1471 --------------------
1473 function Is_Discriminal
(Id
: E
) return B
is
1475 return Ekind
(Id
) in E_Constant | E_In_Parameter
1476 and then Present
(Discriminal_Link
(Id
));
1479 ----------------------
1480 -- Is_Dynamic_Scope --
1481 ----------------------
1483 function Is_Dynamic_Scope
(Id
: E
) return B
is
1485 return Ekind
(Id
) in E_Block
1486 -- Including an E_Block that came from an N_Expression_With_Actions
1491 | E_Return_Statement
1495 (Ekind
(Id
) = E_Limited_Private_Type
1496 and then Present
(Full_View
(Id
))
1497 and then Ekind
(Full_View
(Id
)) = E_Task_Type
);
1498 end Is_Dynamic_Scope
;
1500 --------------------
1501 -- Is_Entity_Name --
1502 --------------------
1504 function Is_Entity_Name
(N
: Node_Id
) return Boolean is
1505 Kind
: constant Node_Kind
:= Nkind
(N
);
1508 -- Identifiers, operator symbols, expanded names are entity names
1510 return Kind
= N_Identifier
1511 or else Kind
= N_Operator_Symbol
1512 or else Kind
= N_Expanded_Name
1514 -- Attribute references are entity names if they refer to an entity.
1515 -- Note that we don't do this by testing for the presence of the
1516 -- Entity field in the N_Attribute_Reference node, since it may not
1517 -- have been set yet.
1519 or else (Kind
= N_Attribute_Reference
1520 and then Is_Entity_Attribute_Name
(Attribute_Name
(N
)));
1523 ---------------------------
1524 -- Is_Elaboration_Target --
1525 ---------------------------
1527 function Is_Elaboration_Target
(Id
: E
) return Boolean is
1530 Ekind
(Id
) in E_Constant | E_Package | E_Variable
1531 or else Is_Entry
(Id
)
1532 or else Is_Generic_Unit
(Id
)
1533 or else Is_Subprogram
(Id
)
1534 or else Is_Task_Type
(Id
);
1535 end Is_Elaboration_Target
;
1537 -----------------------
1538 -- Is_External_State --
1539 -----------------------
1541 function Is_External_State
(Id
: E
) return B
is
1543 -- To qualify, the abstract state must appear with option "external" or
1544 -- "synchronous" (SPARK RM 7.1.4(7) and (9)).
1547 Ekind
(Id
) = E_Abstract_State
1548 and then (Has_Option
(Id
, Name_External
)
1550 Has_Option
(Id
, Name_Synchronous
));
1551 end Is_External_State
;
1557 function Is_Finalizer
(Id
: E
) return B
is
1559 return Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uFinalizer
;
1562 ----------------------
1563 -- Is_Full_Access --
1564 ----------------------
1566 function Is_Full_Access
(Id
: E
) return B
is
1568 return Is_Atomic
(Id
) or else Is_Volatile_Full_Access
(Id
);
1575 function Is_Null_State
(Id
: E
) return B
is
1578 Ekind
(Id
) = E_Abstract_State
and then Nkind
(Parent
(Id
)) = N_Null
;
1581 -----------------------------------
1582 -- Is_Package_Or_Generic_Package --
1583 -----------------------------------
1585 function Is_Package_Or_Generic_Package
(Id
: E
) return B
is
1587 return Ekind
(Id
) in E_Generic_Package | E_Package
;
1588 end Is_Package_Or_Generic_Package
;
1590 ---------------------
1591 -- Is_Packed_Array --
1592 ---------------------
1594 function Is_Packed_Array
(Id
: E
) return B
is
1596 return Is_Array_Type
(Id
) and then Is_Packed
(Id
);
1597 end Is_Packed_Array
;
1603 function Is_Prival
(Id
: E
) return B
is
1605 return Ekind
(Id
) in E_Constant | E_Variable
1606 and then Present
(Prival_Link
(Id
));
1609 ----------------------------
1610 -- Is_Protected_Component --
1611 ----------------------------
1613 function Is_Protected_Component
(Id
: E
) return B
is
1615 return Ekind
(Id
) = E_Component
and then Is_Protected_Type
(Scope
(Id
));
1616 end Is_Protected_Component
;
1618 ----------------------------
1619 -- Is_Protected_Interface --
1620 ----------------------------
1622 function Is_Protected_Interface
(Id
: E
) return B
is
1623 Typ
: constant Entity_Id
:= Base_Type
(Id
);
1625 if not Is_Interface
(Typ
) then
1627 elsif Is_Class_Wide_Type
(Typ
) then
1628 return Is_Protected_Interface
(Etype
(Typ
));
1630 return Protected_Present
(Type_Definition
(Parent
(Typ
)));
1632 end Is_Protected_Interface
;
1634 ------------------------------
1635 -- Is_Protected_Record_Type --
1636 ------------------------------
1638 function Is_Protected_Record_Type
(Id
: E
) return B
is
1641 Is_Concurrent_Record_Type
(Id
)
1642 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Id
));
1643 end Is_Protected_Record_Type
;
1645 -------------------------------------
1646 -- Is_Relaxed_Initialization_State --
1647 -------------------------------------
1649 function Is_Relaxed_Initialization_State
(Id
: E
) return B
is
1651 -- To qualify, the abstract state must appear with simple option
1652 -- "Relaxed_Initialization" (SPARK RM 6.10).
1655 Ekind
(Id
) = E_Abstract_State
1656 and then Has_Option
(Id
, Name_Relaxed_Initialization
);
1657 end Is_Relaxed_Initialization_State
;
1659 --------------------------------
1660 -- Is_Standard_Character_Type --
1661 --------------------------------
1663 function Is_Standard_Character_Type
(Id
: E
) return B
is
1666 and then Root_Type
(Id
) in Standard_Character
1667 | Standard_Wide_Character
1668 | Standard_Wide_Wide_Character
;
1669 end Is_Standard_Character_Type
;
1671 -----------------------------
1672 -- Is_Standard_String_Type --
1673 -----------------------------
1675 function Is_Standard_String_Type
(Id
: E
) return B
is
1678 and then Root_Type
(Id
) in Standard_String
1679 | Standard_Wide_String
1680 | Standard_Wide_Wide_String
;
1681 end Is_Standard_String_Type
;
1683 --------------------
1684 -- Is_String_Type --
1685 --------------------
1687 function Is_String_Type
(Id
: E
) return B
is
1689 return Is_Array_Type
(Id
)
1690 and then Id
/= Any_Composite
1691 and then Number_Dimensions
(Id
) = 1
1692 and then Is_Character_Type
(Component_Type
(Id
));
1695 -------------------------------
1696 -- Is_Synchronized_Interface --
1697 -------------------------------
1699 function Is_Synchronized_Interface
(Id
: E
) return B
is
1700 Typ
: constant Entity_Id
:= Base_Type
(Id
);
1703 if not Is_Interface
(Typ
) then
1706 elsif Is_Class_Wide_Type
(Typ
) then
1707 return Is_Synchronized_Interface
(Etype
(Typ
));
1710 return Protected_Present
(Type_Definition
(Parent
(Typ
)))
1711 or else Synchronized_Present
(Type_Definition
(Parent
(Typ
)))
1712 or else Task_Present
(Type_Definition
(Parent
(Typ
)));
1714 end Is_Synchronized_Interface
;
1716 ---------------------------
1717 -- Is_Synchronized_State --
1718 ---------------------------
1720 function Is_Synchronized_State
(Id
: E
) return B
is
1722 -- To qualify, the abstract state must appear with simple option
1723 -- "synchronous" (SPARK RM 7.1.4(9)).
1726 Ekind
(Id
) = E_Abstract_State
1727 and then Has_Option
(Id
, Name_Synchronous
);
1728 end Is_Synchronized_State
;
1730 -----------------------
1731 -- Is_Task_Interface --
1732 -----------------------
1734 function Is_Task_Interface
(Id
: E
) return B
is
1735 Typ
: constant Entity_Id
:= Base_Type
(Id
);
1737 if not Is_Interface
(Typ
) then
1739 elsif Is_Class_Wide_Type
(Typ
) then
1740 return Is_Task_Interface
(Etype
(Typ
));
1742 return Task_Present
(Type_Definition
(Parent
(Typ
)));
1744 end Is_Task_Interface
;
1746 -------------------------
1747 -- Is_Task_Record_Type --
1748 -------------------------
1750 function Is_Task_Record_Type
(Id
: E
) return B
is
1753 Is_Concurrent_Record_Type
(Id
)
1754 and then Is_Task_Type
(Corresponding_Concurrent_Type
(Id
));
1755 end Is_Task_Record_Type
;
1757 ------------------------
1758 -- Is_Wrapper_Package --
1759 ------------------------
1761 function Is_Wrapper_Package
(Id
: E
) return B
is
1763 return Ekind
(Id
) = E_Package
and then Present
(Related_Instance
(Id
));
1764 end Is_Wrapper_Package
;
1770 function Last_Formal
(Id
: E
) return Entity_Id
is
1775 (Is_Overloadable
(Id
)
1776 or else Ekind
(Id
) in E_Entry_Family
1778 | E_Subprogram_Type
);
1780 if Ekind
(Id
) = E_Enumeration_Literal
then
1784 Formal
:= First_Formal
(Id
);
1786 if Present
(Formal
) then
1787 while Present
(Next_Formal
(Formal
)) loop
1788 Next_Formal
(Formal
);
1800 procedure Link_Entities
(First
, Second
: Entity_Id
) is
1802 if Present
(Second
) then
1803 Set_Prev_Entity
(Second
, First
); -- First <-- Second
1806 Set_Next_Entity
(First
, Second
); -- First --> Second
1809 ------------------------
1810 -- Machine_Emax_Value --
1811 ------------------------
1813 function Machine_Emax_Value
(Id
: E
) return Uint
is
1814 Digs
: constant Pos
:= UI_To_Int
(Digits_Value
(Base_Type
(Id
)));
1817 case Float_Rep
(Id
) is
1820 when 1 .. 6 => return Uint_128
;
1821 when 7 .. 15 => return 2**10;
1822 when 16 .. 33 => return 2**14;
1823 when others => return No_Uint
;
1826 end Machine_Emax_Value
;
1828 ------------------------
1829 -- Machine_Emin_Value --
1830 ------------------------
1832 function Machine_Emin_Value
(Id
: E
) return Uint
is
1834 case Float_Rep
(Id
) is
1835 when IEEE_Binary
=> return Uint_3
- Machine_Emax_Value
(Id
);
1837 end Machine_Emin_Value
;
1839 ----------------------------
1840 -- Machine_Mantissa_Value --
1841 ----------------------------
1843 function Machine_Mantissa_Value
(Id
: E
) return Uint
is
1844 Digs
: constant Pos
:= UI_To_Int
(Digits_Value
(Base_Type
(Id
)));
1847 case Float_Rep
(Id
) is
1850 when 1 .. 6 => return Uint_24
;
1851 when 7 .. 15 => return UI_From_Int
(53);
1852 when 16 .. 18 => return Uint_64
;
1853 when 19 .. 33 => return UI_From_Int
(113);
1854 when others => return No_Uint
;
1857 end Machine_Mantissa_Value
;
1859 -------------------------
1860 -- Machine_Radix_Value --
1861 -------------------------
1863 function Machine_Radix_Value
(Id
: E
) return U
is
1865 case Float_Rep
(Id
) is
1869 end Machine_Radix_Value
;
1871 ----------------------
1872 -- Model_Emin_Value --
1873 ----------------------
1875 function Model_Emin_Value
(Id
: E
) return Uint
is
1877 return Machine_Emin_Value
(Id
);
1878 end Model_Emin_Value
;
1880 -------------------------
1881 -- Model_Epsilon_Value --
1882 -------------------------
1884 function Model_Epsilon_Value
(Id
: E
) return Ureal
is
1885 Radix
: constant Ureal
:= UR_From_Uint
(Machine_Radix_Value
(Id
));
1887 return Radix
** (1 - Model_Mantissa_Value
(Id
));
1888 end Model_Epsilon_Value
;
1890 --------------------------
1891 -- Model_Mantissa_Value --
1892 --------------------------
1894 function Model_Mantissa_Value
(Id
: E
) return Uint
is
1896 return Machine_Mantissa_Value
(Id
);
1897 end Model_Mantissa_Value
;
1899 -----------------------
1900 -- Model_Small_Value --
1901 -----------------------
1903 function Model_Small_Value
(Id
: E
) return Ureal
is
1904 Radix
: constant Ureal
:= UR_From_Uint
(Machine_Radix_Value
(Id
));
1906 return Radix
** (Model_Emin_Value
(Id
) - 1);
1907 end Model_Small_Value
;
1909 --------------------
1910 -- Next_Component --
1911 --------------------
1913 function Next_Component
(Id
: E
) return Entity_Id
is
1914 Comp_Id
: Entity_Id
;
1917 Comp_Id
:= Next_Entity
(Id
);
1918 while Present
(Comp_Id
) loop
1919 exit when Ekind
(Comp_Id
) = E_Component
;
1920 Next_Entity
(Comp_Id
);
1926 ------------------------------------
1927 -- Next_Component_Or_Discriminant --
1928 ------------------------------------
1930 function Next_Component_Or_Discriminant
(Id
: E
) return Entity_Id
is
1931 Comp_Id
: Entity_Id
;
1934 Comp_Id
:= Next_Entity
(Id
);
1935 while Present
(Comp_Id
) loop
1936 exit when Ekind
(Comp_Id
) in E_Component | E_Discriminant
;
1937 Next_Entity
(Comp_Id
);
1941 end Next_Component_Or_Discriminant
;
1943 -----------------------
1944 -- Next_Discriminant --
1945 -----------------------
1947 -- This function actually implements both Next_Discriminant and
1948 -- Next_Stored_Discriminant by making sure that the Discriminant
1949 -- returned is of the same variety as Id.
1951 function Next_Discriminant
(Id
: E
) return Entity_Id
is
1953 -- Derived Tagged types with private extensions look like this...
1955 -- E_Discriminant d1
1956 -- E_Discriminant d2
1958 -- E_Discriminant d1
1959 -- E_Discriminant d2
1962 -- so it is critical not to go past the leading discriminants
1964 D
: Entity_Id
:= Id
;
1967 pragma Assert
(Ekind
(Id
) = E_Discriminant
);
1972 or else (Ekind
(D
) /= E_Discriminant
1973 and then not Is_Itype
(D
))
1978 exit when Ekind
(D
) = E_Discriminant
1979 and then (Is_Completely_Hidden
(D
) = Is_Completely_Hidden
(Id
));
1983 end Next_Discriminant
;
1989 function Next_Formal
(Id
: E
) return Entity_Id
is
1993 -- Follow the chain of declared entities as long as the kind of the
1994 -- entity corresponds to a formal parameter. Skip internal entities
1995 -- that may have been created for implicit subtypes, in the process
1996 -- of analyzing default expressions.
2002 if No
(P
) or else Is_Formal
(P
) then
2004 elsif not Is_Internal
(P
) then
2010 -----------------------------
2011 -- Next_Formal_With_Extras --
2012 -----------------------------
2014 function Next_Formal_With_Extras
(Id
: E
) return Entity_Id
is
2016 if Present
(Extra_Formal
(Id
)) then
2017 return Extra_Formal
(Id
);
2019 return Next_Formal
(Id
);
2021 end Next_Formal_With_Extras
;
2027 function Next_Index
(Id
: N
) return Node_Id
is
2029 pragma Assert
(Nkind
(Id
) in N_Is_Index
);
2030 pragma Assert
(No
(Next
(Id
)) or else Nkind
(Next
(Id
)) in N_Is_Index
);
2038 function Next_Literal
(Id
: E
) return Entity_Id
is
2040 pragma Assert
(Nkind
(Id
) in N_Entity
);
2044 ------------------------------
2045 -- Next_Stored_Discriminant --
2046 ------------------------------
2048 function Next_Stored_Discriminant
(Id
: E
) return Entity_Id
is
2050 -- See comment in Next_Discriminant
2052 return Next_Discriminant
(Id
);
2053 end Next_Stored_Discriminant
;
2055 -----------------------
2056 -- Number_Dimensions --
2057 -----------------------
2059 function Number_Dimensions
(Id
: E
) return Pos
is
2064 if Ekind
(Id
) = E_String_Literal_Subtype
then
2069 T
:= First_Index
(Id
);
2070 while Present
(T
) loop
2077 end Number_Dimensions
;
2079 --------------------
2080 -- Number_Entries --
2081 --------------------
2083 function Number_Entries
(Id
: E
) return Nat
is
2088 pragma Assert
(Is_Concurrent_Type
(Id
));
2091 Ent
:= First_Entity
(Id
);
2092 while Present
(Ent
) loop
2093 if Is_Entry
(Ent
) then
2103 --------------------
2104 -- Number_Formals --
2105 --------------------
2107 function Number_Formals
(Id
: E
) return Pos
is
2113 Formal
:= First_Formal
(Id
);
2114 while Present
(Formal
) loop
2116 Next_Formal
(Formal
);
2122 ------------------------
2123 -- Object_Size_Clause --
2124 ------------------------
2126 function Object_Size_Clause
(Id
: E
) return Node_Id
is
2128 return Get_Attribute_Definition_Clause
(Id
, Attribute_Object_Size
);
2129 end Object_Size_Clause
;
2131 --------------------
2132 -- Parameter_Mode --
2133 --------------------
2135 function Parameter_Mode
(Id
: E
) return Formal_Kind
is
2144 function DIC_Procedure
(Id
: E
) return Entity_Id
is
2145 Subp_Elmt
: Elmt_Id
;
2146 Subp_Id
: Entity_Id
;
2150 pragma Assert
(Is_Type
(Id
));
2152 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
2154 if Present
(Subps
) then
2155 Subp_Elmt
:= First_Elmt
(Subps
);
2156 while Present
(Subp_Elmt
) loop
2157 Subp_Id
:= Node
(Subp_Elmt
);
2159 -- Currently the flag Is_DIC_Procedure is set for both normal DIC
2160 -- check procedures as well as for partial DIC check procedures,
2161 -- and we don't have a flag for the partial procedures.
2163 if Is_DIC_Procedure
(Subp_Id
)
2164 and then not Is_Partial_DIC_Procedure
(Subp_Id
)
2169 Next_Elmt
(Subp_Elmt
);
2176 function Partial_DIC_Procedure
(Id
: E
) return Entity_Id
is
2177 Subp_Elmt
: Elmt_Id
;
2178 Subp_Id
: Entity_Id
;
2182 pragma Assert
(Is_Type
(Id
));
2184 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
2186 if Present
(Subps
) then
2187 Subp_Elmt
:= First_Elmt
(Subps
);
2188 while Present
(Subp_Elmt
) loop
2189 Subp_Id
:= Node
(Subp_Elmt
);
2191 if Is_Partial_DIC_Procedure
(Subp_Id
) then
2195 Next_Elmt
(Subp_Elmt
);
2200 end Partial_DIC_Procedure
;
2202 function Is_Partial_DIC_Procedure
(Id
: E
) return B
is
2203 Partial_DIC_Suffix
: constant String := "Partial_DIC";
2204 DIC_Nam
: constant String := Get_Name_String
(Chars
(Id
));
2207 pragma Assert
(Ekind
(Id
) in E_Function | E_Procedure
);
2209 -- Instead of adding a new Entity_Id flag (which are in short supply),
2210 -- we test the form of the subprogram name. When the node field and flag
2211 -- situation is eased, this should be replaced with a flag. ???
2213 if DIC_Nam
'Length > Partial_DIC_Suffix
'Length
2216 (DIC_Nam
'Last - Partial_DIC_Suffix
'Length + 1 .. DIC_Nam
'Last) =
2223 end Is_Partial_DIC_Procedure
;
2225 ---------------------------------
2226 -- Partial_Invariant_Procedure --
2227 ---------------------------------
2229 function Partial_Invariant_Procedure
(Id
: E
) return Entity_Id
is
2230 Subp_Elmt
: Elmt_Id
;
2231 Subp_Id
: Entity_Id
;
2235 pragma Assert
(Is_Type
(Id
));
2237 Subps
:= Subprograms_For_Type
(Base_Type
(Id
));
2239 if Present
(Subps
) then
2240 Subp_Elmt
:= First_Elmt
(Subps
);
2241 while Present
(Subp_Elmt
) loop
2242 Subp_Id
:= Node
(Subp_Elmt
);
2244 if Is_Partial_Invariant_Procedure
(Subp_Id
) then
2248 Next_Elmt
(Subp_Elmt
);
2253 end Partial_Invariant_Procedure
;
2255 -------------------------------------
2256 -- Partial_Refinement_Constituents --
2257 -------------------------------------
2259 function Partial_Refinement_Constituents
(Id
: E
) return L
is
2260 Constits
: Elist_Id
:= No_Elist
;
2262 procedure Add_Usable_Constituents
(Item
: E
);
2263 -- Add global item Item and/or its constituents to list Constits when
2264 -- they can be used in a global refinement within the current scope. The
2266 -- 1) If Item is an abstract state with full refinement visible, add
2267 -- its constituents.
2268 -- 2) If Item is an abstract state with only partial refinement
2269 -- visible, add both Item and its constituents.
2270 -- 3) If Item is an abstract state without a visible refinement, add
2272 -- 4) If Id is not an abstract state, add it.
2274 procedure Add_Usable_Constituents
(List
: Elist_Id
);
2275 -- Apply Add_Usable_Constituents to every constituent in List
2277 -----------------------------
2278 -- Add_Usable_Constituents --
2279 -----------------------------
2281 procedure Add_Usable_Constituents
(Item
: E
) is
2283 if Ekind
(Item
) = E_Abstract_State
then
2284 if Has_Visible_Refinement
(Item
) then
2285 Add_Usable_Constituents
(Refinement_Constituents
(Item
));
2287 elsif Has_Partial_Visible_Refinement
(Item
) then
2288 Append_New_Elmt
(Item
, Constits
);
2289 Add_Usable_Constituents
(Part_Of_Constituents
(Item
));
2292 Append_New_Elmt
(Item
, Constits
);
2296 Append_New_Elmt
(Item
, Constits
);
2298 end Add_Usable_Constituents
;
2300 procedure Add_Usable_Constituents
(List
: Elist_Id
) is
2301 Constit_Elmt
: Elmt_Id
;
2303 if Present
(List
) then
2304 Constit_Elmt
:= First_Elmt
(List
);
2305 while Present
(Constit_Elmt
) loop
2306 Add_Usable_Constituents
(Node
(Constit_Elmt
));
2307 Next_Elmt
(Constit_Elmt
);
2310 end Add_Usable_Constituents
;
2312 -- Start of processing for Partial_Refinement_Constituents
2315 -- "Refinement" is a concept applicable only to abstract states
2317 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
2319 if Has_Visible_Refinement
(Id
) then
2320 Constits
:= Refinement_Constituents
(Id
);
2322 -- A refinement may be partially visible when objects declared in the
2323 -- private part of a package are subject to a Part_Of indicator.
2325 elsif Has_Partial_Visible_Refinement
(Id
) then
2326 Add_Usable_Constituents
(Part_Of_Constituents
(Id
));
2328 -- Function should only be called when full or partial refinement is
2332 raise Program_Error
;
2336 end Partial_Refinement_Constituents
;
2338 ------------------------
2339 -- Predicate_Function --
2340 ------------------------
2342 function Predicate_Function
(Id
: E
) return Entity_Id
is
2343 Subp_Elmt
: Elmt_Id
;
2344 Subp_Id
: Entity_Id
;
2349 pragma Assert
(Is_Type
(Id
));
2351 -- If type is private and has a completion, predicate may be defined on
2354 if Is_Private_Type
(Id
)
2356 (not Has_Predicates
(Id
) or else No
(Subprograms_For_Type
(Id
)))
2357 and then Present
(Full_View
(Id
))
2359 Typ
:= Full_View
(Id
);
2361 elsif Ekind
(Id
) in E_Array_Subtype
2363 | E_Record_Subtype_With_Private
2364 and then Present
(Predicated_Parent
(Id
))
2366 Typ
:= Predicated_Parent
(Id
);
2372 Subps
:= Subprograms_For_Type
(Typ
);
2374 if Present
(Subps
) then
2375 Subp_Elmt
:= First_Elmt
(Subps
);
2376 while Present
(Subp_Elmt
) loop
2377 Subp_Id
:= Node
(Subp_Elmt
);
2379 if Ekind
(Subp_Id
) = E_Function
2380 and then Is_Predicate_Function
(Subp_Id
)
2385 Next_Elmt
(Subp_Elmt
);
2390 end Predicate_Function
;
2392 -------------------------
2393 -- Present_In_Rep_Item --
2394 -------------------------
2396 function Present_In_Rep_Item
(E
: Entity_Id
; N
: Node_Id
) return Boolean is
2400 Ritem
:= First_Rep_Item
(E
);
2402 while Present
(Ritem
) loop
2407 Next_Rep_Item
(Ritem
);
2411 end Present_In_Rep_Item
;
2413 --------------------------
2414 -- Primitive_Operations --
2415 --------------------------
2417 function Primitive_Operations
(Id
: E
) return L
is
2419 if Is_Concurrent_Type
(Id
) then
2420 if Present
(Corresponding_Record_Type
(Id
)) then
2421 return Direct_Primitive_Operations
2422 (Corresponding_Record_Type
(Id
));
2424 -- When expansion is disabled, the corresponding record type is
2425 -- absent, but if this is a tagged type with ancestors, or if the
2426 -- extension of prefixed calls for untagged types is enabled, then
2427 -- it may have associated primitive operations.
2430 return Direct_Primitive_Operations
(Id
);
2434 return Direct_Primitive_Operations
(Id
);
2436 end Primitive_Operations
;
2438 ---------------------
2439 -- Record_Rep_Item --
2440 ---------------------
2442 procedure Record_Rep_Item
(E
: Entity_Id
; N
: Node_Id
) is
2444 Set_Next_Rep_Item
(N
, First_Rep_Item
(E
));
2445 Set_First_Rep_Item
(E
, N
);
2446 end Record_Rep_Item
;
2452 procedure Remove_Entity
(Id
: Entity_Id
) is
2453 Next
: constant Entity_Id
:= Next_Entity
(Id
);
2454 Prev
: constant Entity_Id
:= Prev_Entity
(Id
);
2455 Scop
: constant Entity_Id
:= Scope
(Id
);
2456 First
: constant Entity_Id
:= First_Entity
(Scop
);
2457 Last
: constant Entity_Id
:= Last_Entity
(Scop
);
2460 -- Eliminate any existing linkages from the entity
2462 Set_Prev_Entity
(Id
, Empty
); -- Empty <-- Id
2463 Set_Next_Entity
(Id
, Empty
); -- Id --> Empty
2465 -- The eliminated entity was the only element in the entity chain
2467 if Id
= First
and then Id
= Last
then
2468 Set_First_Entity
(Scop
, Empty
);
2469 Set_Last_Entity
(Scop
, Empty
);
2471 -- The eliminated entity was the head of the entity chain
2473 elsif Id
= First
then
2474 Set_First_Entity
(Scop
, Next
);
2475 Set_Prev_Entity
(Next
, Empty
); -- Empty <-- First_Entity
2477 -- The eliminated entity was the tail of the entity chain
2479 elsif Id
= Last
then
2480 Set_Last_Entity
(Scop
, Prev
);
2481 Set_Next_Entity
(Prev
, Empty
); -- Last_Entity --> Empty
2483 -- Otherwise the eliminated entity comes from the middle of the entity
2487 Link_Entities
(Prev
, Next
); -- Prev <-- Next, Prev --> Next
2495 function Root_Type
(Id
: E
) return E
is
2496 T
, Etyp
: Entity_Id
;
2499 pragma Assert
(Nkind
(Id
) in N_Entity
);
2501 T
:= Base_Type
(Id
);
2503 if Ekind
(T
) = E_Class_Wide_Type
then
2515 -- Following test catches some error cases resulting from
2518 elsif No
(Etyp
) then
2519 Check_Error_Detected
;
2522 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
2525 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
2531 -- Return if there is a circularity in the inheritance chain. This
2532 -- happens in some error situations and we do not want to get
2533 -- stuck in this loop.
2535 if T
= Base_Type
(Id
) then
2542 ---------------------
2543 -- Safe_Emax_Value --
2544 ---------------------
2546 function Safe_Emax_Value
(Id
: E
) return Uint
is
2548 return Machine_Emax_Value
(Id
);
2549 end Safe_Emax_Value
;
2551 ----------------------
2552 -- Safe_First_Value --
2553 ----------------------
2555 function Safe_First_Value
(Id
: E
) return Ureal
is
2557 return -Safe_Last_Value
(Id
);
2558 end Safe_First_Value
;
2560 ---------------------
2561 -- Safe_Last_Value --
2562 ---------------------
2564 function Safe_Last_Value
(Id
: E
) return Ureal
is
2565 Radix
: constant Uint
:= Machine_Radix_Value
(Id
);
2566 Mantissa
: constant Uint
:= Machine_Mantissa_Value
(Id
);
2567 Emax
: constant Uint
:= Safe_Emax_Value
(Id
);
2568 Significand
: constant Uint
:= Radix
** Mantissa
- 1;
2569 Exponent
: constant Uint
:= Emax
- Mantissa
;
2575 (Num
=> Significand
* 2 ** (Exponent
mod 4),
2576 Den
=> -Exponent
/ 4,
2581 (Num
=> Significand
,
2585 end Safe_Last_Value
;
2591 function Scope_Depth
(Id
: E
) return Uint
is
2596 while Is_Record_Type
(Scop
) loop
2597 Scop
:= Scope
(Scop
);
2600 return Scope_Depth_Value
(Scop
);
2603 function Scope_Depth_Default_0
(Id
: E
) return U
is
2605 if Scope_Depth_Set
(Id
) then
2606 return Scope_Depth
(Id
);
2611 end Scope_Depth_Default_0
;
2613 ---------------------
2614 -- Scope_Depth_Set --
2615 ---------------------
2617 function Scope_Depth_Set
(Id
: E
) return B
is
2619 return not Is_Record_Type
(Id
)
2620 and then not Field_Is_Initial_Zero
(Id
, F_Scope_Depth_Value
);
2621 -- We can't call Scope_Depth_Value here, because Empty is not a valid
2622 -- value of type Uint.
2623 end Scope_Depth_Set
;
2625 --------------------
2626 -- Set_Convention --
2627 --------------------
2629 procedure Set_Convention
(E
: Entity_Id
; Val
: Snames
.Convention_Id
) is
2631 Set_Basic_Convention
(E
, Val
);
2633 if Ekind
(E
) in Access_Subprogram_Kind
2634 and then Has_Foreign_Convention
(E
)
2636 Set_Can_Use_Internal_Rep
(E
, False);
2639 -- If E is an object, including a component, and the type of E is an
2640 -- anonymous access type with no convention set, then also set the
2641 -- convention of the anonymous access type. We do not do this for
2642 -- anonymous protected types, since protected types always have the
2643 -- default convention.
2645 if Present
(Etype
(E
))
2646 and then (Is_Object
(E
)
2648 -- Allow E_Void (happens for pragma Convention appearing
2649 -- in the middle of a record applying to a component)
2651 or else Ekind
(E
) = E_Void
)
2654 Typ
: constant Entity_Id
:= Etype
(E
);
2657 if Ekind
(Typ
) in E_Anonymous_Access_Type
2658 | E_Anonymous_Access_Subprogram_Type
2659 and then not Has_Convention_Pragma
(Typ
)
2661 Set_Convention
(Typ
, Val
);
2662 Set_Has_Convention_Pragma
(Typ
);
2664 -- And for the access subprogram type, deal similarly with the
2665 -- designated E_Subprogram_Type, which is always internal.
2667 if Ekind
(Typ
) = E_Anonymous_Access_Subprogram_Type
then
2669 Dtype
: constant Entity_Id
:= Designated_Type
(Typ
);
2671 if Ekind
(Dtype
) = E_Subprogram_Type
then
2672 pragma Assert
(not Has_Convention_Pragma
(Dtype
));
2673 Set_Convention
(Dtype
, Val
);
2674 Set_Has_Convention_Pragma
(Dtype
);
2683 -----------------------
2684 -- Set_DIC_Procedure --
2685 -----------------------
2687 procedure Set_DIC_Procedure
(Id
: E
; V
: E
) is
2688 Base_Typ
: Entity_Id
;
2692 pragma Assert
(Is_Type
(Id
));
2694 Base_Typ
:= Base_Type
(Id
);
2695 Subps
:= Subprograms_For_Type
(Base_Typ
);
2698 Subps
:= New_Elmt_List
;
2699 Set_Subprograms_For_Type
(Base_Typ
, Subps
);
2702 Prepend_Elmt
(V
, Subps
);
2703 end Set_DIC_Procedure
;
2705 procedure Set_Partial_DIC_Procedure
(Id
: E
; V
: E
) is
2707 Set_DIC_Procedure
(Id
, V
);
2708 end Set_Partial_DIC_Procedure
;
2714 procedure Set_Float_Rep
2715 (Ignore_N
: Entity_Id
; Ignore_Val
: Float_Rep_Kind
) is
2717 pragma Assert
(Float_Rep_Kind
'First = Float_Rep_Kind
'Last);
2718 -- There is only one value, so we don't need to store it (see
2722 -----------------------------
2723 -- Set_Invariant_Procedure --
2724 -----------------------------
2726 procedure Set_Invariant_Procedure
(Id
: E
; V
: E
) is
2727 Base_Typ
: Entity_Id
;
2728 Subp_Elmt
: Elmt_Id
;
2729 Subp_Id
: Entity_Id
;
2733 pragma Assert
(Is_Type
(Id
));
2735 Base_Typ
:= Base_Type
(Id
);
2736 Subps
:= Subprograms_For_Type
(Base_Typ
);
2739 Subps
:= New_Elmt_List
;
2740 Set_Subprograms_For_Type
(Base_Typ
, Subps
);
2743 Subp_Elmt
:= First_Elmt
(Subps
);
2744 Prepend_Elmt
(V
, Subps
);
2746 -- Check for a duplicate invariant procedure
2748 while Present
(Subp_Elmt
) loop
2749 Subp_Id
:= Node
(Subp_Elmt
);
2751 if Is_Invariant_Procedure
(Subp_Id
) then
2752 raise Program_Error
;
2755 Next_Elmt
(Subp_Elmt
);
2757 end Set_Invariant_Procedure
;
2759 -------------------------------------
2760 -- Set_Partial_Invariant_Procedure --
2761 -------------------------------------
2763 procedure Set_Partial_Invariant_Procedure
(Id
: E
; V
: E
) is
2764 Base_Typ
: Entity_Id
;
2765 Subp_Elmt
: Elmt_Id
;
2766 Subp_Id
: Entity_Id
;
2770 pragma Assert
(Is_Type
(Id
));
2772 Base_Typ
:= Base_Type
(Id
);
2773 Subps
:= Subprograms_For_Type
(Base_Typ
);
2776 Subps
:= New_Elmt_List
;
2777 Set_Subprograms_For_Type
(Base_Typ
, Subps
);
2780 Subp_Elmt
:= First_Elmt
(Subps
);
2781 Prepend_Elmt
(V
, Subps
);
2783 -- Check for a duplicate partial invariant procedure
2785 while Present
(Subp_Elmt
) loop
2786 Subp_Id
:= Node
(Subp_Elmt
);
2788 if Is_Partial_Invariant_Procedure
(Subp_Id
) then
2789 raise Program_Error
;
2792 Next_Elmt
(Subp_Elmt
);
2794 end Set_Partial_Invariant_Procedure
;
2796 ----------------------------
2797 -- Set_Predicate_Function --
2798 ----------------------------
2800 procedure Set_Predicate_Function
(Id
: E
; V
: E
) is
2801 Subp_Elmt
: Elmt_Id
;
2802 Subp_Id
: Entity_Id
;
2806 pragma Assert
(Is_Type
(Id
) and then Has_Predicates
(Id
));
2808 Subps
:= Subprograms_For_Type
(Id
);
2811 Subps
:= New_Elmt_List
;
2812 Set_Subprograms_For_Type
(Id
, Subps
);
2815 Subp_Elmt
:= First_Elmt
(Subps
);
2816 Prepend_Elmt
(V
, Subps
);
2818 -- Check for a duplicate predication function
2820 while Present
(Subp_Elmt
) loop
2821 Subp_Id
:= Node
(Subp_Elmt
);
2823 if Ekind
(Subp_Id
) = E_Function
2824 and then Is_Predicate_Function
(Subp_Id
)
2826 raise Program_Error
;
2829 Next_Elmt
(Subp_Elmt
);
2831 end Set_Predicate_Function
;
2837 function Size_Clause
(Id
: E
) return Node_Id
is
2838 Result
: Node_Id
:= Get_Attribute_Definition_Clause
(Id
, Attribute_Size
);
2841 Result
:= Get_Attribute_Definition_Clause
(Id
, Attribute_Value_Size
);
2847 ------------------------
2848 -- Stream_Size_Clause --
2849 ------------------------
2851 function Stream_Size_Clause
(Id
: E
) return N
is
2853 return Get_Attribute_Definition_Clause
(Id
, Attribute_Stream_Size
);
2854 end Stream_Size_Clause
;
2860 function Subtype_Kind
(K
: Entity_Kind
) return Entity_Kind
is
2866 Kind
:= E_Access_Subtype
;
2868 when E_Array_Subtype
2871 Kind
:= E_Array_Subtype
;
2873 when E_Class_Wide_Subtype
2876 Kind
:= E_Class_Wide_Subtype
;
2878 when E_Decimal_Fixed_Point_Subtype
2879 | E_Decimal_Fixed_Point_Type
2881 Kind
:= E_Decimal_Fixed_Point_Subtype
;
2883 when E_Ordinary_Fixed_Point_Subtype
2884 | E_Ordinary_Fixed_Point_Type
2886 Kind
:= E_Ordinary_Fixed_Point_Subtype
;
2888 when E_Private_Subtype
2891 Kind
:= E_Private_Subtype
;
2893 when E_Limited_Private_Subtype
2894 | E_Limited_Private_Type
2896 Kind
:= E_Limited_Private_Subtype
;
2898 when E_Record_Subtype_With_Private
2899 | E_Record_Type_With_Private
2901 Kind
:= E_Record_Subtype_With_Private
;
2903 when E_Record_Subtype
2906 Kind
:= E_Record_Subtype
;
2908 when Enumeration_Kind
=>
2909 Kind
:= E_Enumeration_Subtype
;
2911 when E_Incomplete_Type
=>
2912 Kind
:= E_Incomplete_Subtype
;
2915 Kind
:= E_Floating_Point_Subtype
;
2917 when Signed_Integer_Kind
=>
2918 Kind
:= E_Signed_Integer_Subtype
;
2920 when Modular_Integer_Kind
=>
2921 Kind
:= E_Modular_Integer_Subtype
;
2923 when Protected_Kind
=>
2924 Kind
:= E_Protected_Subtype
;
2927 Kind
:= E_Task_Subtype
;
2930 raise Program_Error
;
2936 ---------------------
2937 -- Type_High_Bound --
2938 ---------------------
2940 function Type_High_Bound
(Id
: E
) return N
is
2941 Rng
: constant Node_Id
:= Scalar_Range
(Id
);
2943 if Nkind
(Rng
) = N_Subtype_Indication
then
2944 return High_Bound
(Range_Expression
(Constraint
(Rng
)));
2946 return High_Bound
(Rng
);
2948 end Type_High_Bound
;
2950 --------------------
2951 -- Type_Low_Bound --
2952 --------------------
2954 function Type_Low_Bound
(Id
: E
) return N
is
2955 Rng
: constant Node_Id
:= Scalar_Range
(Id
);
2957 if Nkind
(Rng
) = N_Subtype_Indication
then
2958 return Low_Bound
(Range_Expression
(Constraint
(Rng
)));
2960 return Low_Bound
(Rng
);
2964 ---------------------
2965 -- Underlying_Type --
2966 ---------------------
2968 function Underlying_Type
(Id
: E
) return Entity_Id
is
2970 -- For record_with_private the underlying type is always the direct full
2971 -- view. Never try to take the full view of the parent it does not make
2974 if Ekind
(Id
) = E_Record_Type_With_Private
then
2975 return Full_View
(Id
);
2977 -- If we have a class-wide type that comes from the limited view then we
2978 -- return the Underlying_Type of its nonlimited view.
2980 elsif Ekind
(Id
) = E_Class_Wide_Type
2981 and then From_Limited_With
(Id
)
2982 and then Present
(Non_Limited_View
(Id
))
2984 return Underlying_Type
(Non_Limited_View
(Id
));
2986 elsif Ekind
(Id
) in Incomplete_Or_Private_Kind
then
2988 -- If we have an incomplete or private type with a full view, then we
2989 -- return the Underlying_Type of this full view.
2991 if Present
(Full_View
(Id
)) then
2992 if Id
= Full_View
(Id
) then
2994 -- Previous error in declaration
2999 return Underlying_Type
(Full_View
(Id
));
3002 -- If we have a private type with an underlying full view, then we
3003 -- return the Underlying_Type of this underlying full view.
3005 elsif Ekind
(Id
) in Private_Kind
3006 and then Present
(Underlying_Full_View
(Id
))
3008 return Underlying_Type
(Underlying_Full_View
(Id
));
3010 -- If we have an incomplete entity that comes from the limited view
3011 -- then we return the Underlying_Type of its nonlimited view.
3013 elsif From_Limited_With
(Id
)
3014 and then Present
(Non_Limited_View
(Id
))
3016 return Underlying_Type
(Non_Limited_View
(Id
));
3018 -- Otherwise check for the case where we have a derived type or
3019 -- subtype, and if so get the Underlying_Type of the parent type.
3021 elsif Etype
(Id
) /= Id
then
3022 return Underlying_Type
(Etype
(Id
));
3024 -- Otherwise we have an incomplete or private type that has no full
3025 -- view, which means that we have not encountered the completion, so
3026 -- return Empty to indicate the underlying type is not yet known.
3032 -- For non-incomplete, non-private types, return the type itself. Also
3033 -- for entities that are not types at all return the entity itself.
3038 end Underlying_Type
;
3040 ------------------------
3041 -- Unlink_Next_Entity --
3042 ------------------------
3044 procedure Unlink_Next_Entity
(Id
: Entity_Id
) is
3045 Next
: constant Entity_Id
:= Next_Entity
(Id
);
3048 if Present
(Next
) then
3049 Set_Prev_Entity
(Next
, Empty
); -- Empty <-- Next
3052 Set_Next_Entity
(Id
, Empty
); -- Id --> Empty
3053 end Unlink_Next_Entity
;
3055 ----------------------------------
3056 -- Is_Volatile, Set_Is_Volatile --
3057 ----------------------------------
3059 function Is_Volatile
(Id
: E
) return B
is
3061 pragma Assert
(Nkind
(Id
) in N_Entity
);
3063 if Is_Type
(Id
) then
3064 return Is_Volatile_Type
(Base_Type
(Id
));
3066 return Is_Volatile_Object
(Id
);
3070 procedure Set_Is_Volatile
(Id
: E
; V
: B
:= True) is
3072 pragma Assert
(Nkind
(Id
) in N_Entity
);
3074 if Is_Type
(Id
) then
3075 Set_Is_Volatile_Type
(Id
, V
);
3077 Set_Is_Volatile_Object
(Id
, V
);
3079 end Set_Is_Volatile
;
3081 -----------------------
3082 -- Write_Entity_Info --
3083 -----------------------
3085 procedure Write_Entity_Info
(Id
: Entity_Id
; Prefix
: String) is
3087 procedure Write_Attribute
(Which
: String; Nam
: E
);
3088 -- Write attribute value with given string name
3090 procedure Write_Kind
(Id
: Entity_Id
);
3091 -- Write Ekind field of entity
3093 ---------------------
3094 -- Write_Attribute --
3095 ---------------------
3097 procedure Write_Attribute
(Which
: String; Nam
: E
) is
3101 Write_Int
(Int
(Nam
));
3103 Write_Name
(Chars
(Nam
));
3105 end Write_Attribute
;
3111 procedure Write_Kind
(Id
: Entity_Id
) is
3112 K
: constant String := Entity_Kind
'Image (Ekind
(Id
));
3116 Write_Str
(" Kind ");
3118 if Is_Type
(Id
) and then Is_Tagged_Type
(Id
) then
3119 Write_Str
("TAGGED ");
3122 Write_Str
(K
(3 .. K
'Length));
3125 if Is_Type
(Id
) and then Depends_On_Private
(Id
) then
3126 Write_Str
("Depends_On_Private ");
3130 -- Start of processing for Write_Entity_Info
3134 Write_Attribute
("Name ", Id
);
3135 Write_Int
(Int
(Id
));
3139 Write_Attribute
(" Type ", Etype
(Id
));
3141 if Id
/= Standard_Standard
then
3142 Write_Attribute
(" Scope ", Scope
(Id
));
3147 when Discrete_Kind
=>
3148 Write_Str
("Bounds: Id = ");
3150 if Present
(Scalar_Range
(Id
)) then
3151 Write_Int
(Int
(Type_Low_Bound
(Id
)));
3152 Write_Str
(" .. Id = ");
3153 Write_Int
(Int
(Type_High_Bound
(Id
)));
3155 Write_Str
("Empty");
3166 (" Component Type ", Component_Type
(Id
));
3169 Write_Str
(" Indexes ");
3171 Index
:= First_Index
(Id
);
3172 while Present
(Index
) loop
3173 Write_Attribute
(" ", Etype
(Index
));
3174 Index
:= Next_Index
(Index
);
3182 (" Directly Designated Type ",
3183 Directly_Designated_Type
(Id
));
3186 when Overloadable_Kind
=>
3187 if Present
(Homonym
(Id
)) then
3188 Write_Str
(" Homonym ");
3189 Write_Name
(Chars
(Homonym
(Id
)));
3191 Write_Int
(Int
(Homonym
(Id
)));
3198 if Ekind
(Scope
(Id
)) in Record_Kind
then
3200 " Original_Record_Component ",
3201 Original_Record_Component
(Id
));
3202 Write_Int
(Int
(Original_Record_Component
(Id
)));
3209 end Write_Entity_Info
;
3211 -------------------------
3212 -- Iterator Procedures --
3213 -------------------------
3215 procedure Proc_Next_Component
(N
: in out Node_Id
) is
3217 N
:= Next_Component
(N
);
3218 end Proc_Next_Component
;
3220 procedure Proc_Next_Component_Or_Discriminant
(N
: in out Node_Id
) is
3222 N
:= Next_Entity
(N
);
3223 while Present
(N
) loop
3224 exit when Ekind
(N
) in E_Component | E_Discriminant
;
3225 N
:= Next_Entity
(N
);
3227 end Proc_Next_Component_Or_Discriminant
;
3229 procedure Proc_Next_Discriminant
(N
: in out Node_Id
) is
3231 N
:= Next_Discriminant
(N
);
3232 end Proc_Next_Discriminant
;
3234 procedure Proc_Next_Formal
(N
: in out Node_Id
) is
3236 N
:= Next_Formal
(N
);
3237 end Proc_Next_Formal
;
3239 procedure Proc_Next_Formal_With_Extras
(N
: in out Node_Id
) is
3241 N
:= Next_Formal_With_Extras
(N
);
3242 end Proc_Next_Formal_With_Extras
;
3244 procedure Proc_Next_Index
(N
: in out Node_Id
) is
3246 N
:= Next_Index
(N
);
3247 end Proc_Next_Index
;
3249 procedure Proc_Next_Inlined_Subprogram
(N
: in out Node_Id
) is
3251 N
:= Next_Inlined_Subprogram
(N
);
3252 end Proc_Next_Inlined_Subprogram
;
3254 procedure Proc_Next_Literal
(N
: in out Node_Id
) is
3256 N
:= Next_Literal
(N
);
3257 end Proc_Next_Literal
;
3259 procedure Proc_Next_Stored_Discriminant
(N
: in out Node_Id
) is
3261 N
:= Next_Stored_Discriminant
(N
);
3262 end Proc_Next_Stored_Discriminant
;