1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 Casing
; use Casing
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Errout
; use Errout
;
31 with Elists
; use Elists
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Disp
; use Exp_Disp
;
34 with Exp_Tss
; use Exp_Tss
;
35 with Exp_Util
; use Exp_Util
;
36 with Fname
; use Fname
;
37 with Freeze
; use Freeze
;
39 with Lib
.Xref
; use Lib
.Xref
;
40 with Nlists
; use Nlists
;
41 with Output
; use Output
;
43 with Rtsfind
; use Rtsfind
;
44 with Scans
; use Scans
;
47 with Sem_Aux
; use Sem_Aux
;
48 with Sem_Attr
; use Sem_Attr
;
49 with Sem_Ch8
; use Sem_Ch8
;
50 with Sem_Eval
; use Sem_Eval
;
51 with Sem_Res
; use Sem_Res
;
52 with Sem_Type
; use Sem_Type
;
53 with Sinfo
; use Sinfo
;
54 with Sinput
; use Sinput
;
55 with Stand
; use Stand
;
57 with Stringt
; use Stringt
;
58 with Targparm
; use Targparm
;
59 with Tbuild
; use Tbuild
;
60 with Ttypes
; use Ttypes
;
61 with Uname
; use Uname
;
63 with GNAT
.HTable
; use GNAT
.HTable
;
64 package body Sem_Util
is
66 ----------------------------------------
67 -- Global_Variables for New_Copy_Tree --
68 ----------------------------------------
70 -- These global variables are used by New_Copy_Tree. See description
71 -- of the body of this subprogram for details. Global variables can be
72 -- safely used by New_Copy_Tree, since there is no case of a recursive
73 -- call from the processing inside New_Copy_Tree.
75 NCT_Hash_Threshhold
: constant := 20;
76 -- If there are more than this number of pairs of entries in the
77 -- map, then Hash_Tables_Used will be set, and the hash tables will
78 -- be initialized and used for the searches.
80 NCT_Hash_Tables_Used
: Boolean := False;
81 -- Set to True if hash tables are in use
83 NCT_Table_Entries
: Nat
;
84 -- Count entries in table to see if threshhold is reached
86 NCT_Hash_Table_Setup
: Boolean := False;
87 -- Set to True if hash table contains data. We set this True if we
88 -- setup the hash table with data, and leave it set permanently
89 -- from then on, this is a signal that second and subsequent users
90 -- of the hash table must clear the old entries before reuse.
92 subtype NCT_Header_Num
is Int
range 0 .. 511;
93 -- Defines range of headers in hash tables (512 headers)
95 -----------------------
96 -- Local Subprograms --
97 -----------------------
99 function Build_Component_Subtype
102 T
: Entity_Id
) return Node_Id
;
103 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
104 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
105 -- Loc is the source location, T is the original subtype.
107 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
108 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
109 -- with discriminants whose default values are static, examine only the
110 -- components in the selected variant to determine whether all of them
113 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
114 -- T is a derived tagged type. Check whether the type extension is null.
115 -- If the parent type is fully initialized, T can be treated as such.
117 ------------------------------
118 -- Abstract_Interface_List --
119 ------------------------------
121 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
125 if Is_Concurrent_Type
(Typ
) then
127 -- If we are dealing with a synchronized subtype, go to the base
128 -- type, whose declaration has the interface list.
130 -- Shouldn't this be Declaration_Node???
132 Nod
:= Parent
(Base_Type
(Typ
));
134 if Nkind
(Nod
) = N_Full_Type_Declaration
then
138 elsif Ekind
(Typ
) = E_Record_Type_With_Private
then
139 if Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
then
140 Nod
:= Type_Definition
(Parent
(Typ
));
142 elsif Nkind
(Parent
(Typ
)) = N_Private_Type_Declaration
then
143 if Present
(Full_View
(Typ
)) then
144 Nod
:= Type_Definition
(Parent
(Full_View
(Typ
)));
146 -- If the full-view is not available we cannot do anything else
147 -- here (the source has errors).
153 -- Support for generic formals with interfaces is still missing ???
155 elsif Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
160 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
);
164 elsif Ekind
(Typ
) = E_Record_Subtype
then
165 Nod
:= Type_Definition
(Parent
(Etype
(Typ
)));
167 elsif Ekind
(Typ
) = E_Record_Subtype_With_Private
then
169 -- Recurse, because parent may still be a private extension. Also
170 -- note that the full view of the subtype or the full view of its
171 -- base type may (both) be unavailable.
173 return Abstract_Interface_List
(Etype
(Typ
));
175 else pragma Assert
((Ekind
(Typ
)) = E_Record_Type
);
176 if Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
177 Nod
:= Formal_Type_Definition
(Parent
(Typ
));
179 Nod
:= Type_Definition
(Parent
(Typ
));
183 return Interface_List
(Nod
);
184 end Abstract_Interface_List
;
186 --------------------------------
187 -- Add_Access_Type_To_Process --
188 --------------------------------
190 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
194 Ensure_Freeze_Node
(E
);
195 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
199 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
203 end Add_Access_Type_To_Process
;
205 ----------------------------
206 -- Add_Global_Declaration --
207 ----------------------------
209 procedure Add_Global_Declaration
(N
: Node_Id
) is
210 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
213 if No
(Declarations
(Aux_Node
)) then
214 Set_Declarations
(Aux_Node
, New_List
);
217 Append_To
(Declarations
(Aux_Node
), N
);
219 end Add_Global_Declaration
;
221 -----------------------
222 -- Alignment_In_Bits --
223 -----------------------
225 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
227 return Alignment
(E
) * System_Storage_Unit
;
228 end Alignment_In_Bits
;
230 -----------------------------------------
231 -- Apply_Compile_Time_Constraint_Error --
232 -----------------------------------------
234 procedure Apply_Compile_Time_Constraint_Error
237 Reason
: RT_Exception_Code
;
238 Ent
: Entity_Id
:= Empty
;
239 Typ
: Entity_Id
:= Empty
;
240 Loc
: Source_Ptr
:= No_Location
;
241 Rep
: Boolean := True;
242 Warn
: Boolean := False)
244 Stat
: constant Boolean := Is_Static_Expression
(N
);
245 R_Stat
: constant Node_Id
:=
246 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
257 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
263 -- Now we replace the node by an N_Raise_Constraint_Error node
264 -- This does not need reanalyzing, so set it as analyzed now.
267 Set_Analyzed
(N
, True);
270 Set_Raises_Constraint_Error
(N
);
272 -- Now deal with possible local raise handling
274 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
276 -- If the original expression was marked as static, the result is
277 -- still marked as static, but the Raises_Constraint_Error flag is
278 -- always set so that further static evaluation is not attempted.
281 Set_Is_Static_Expression
(N
);
283 end Apply_Compile_Time_Constraint_Error
;
285 --------------------------
286 -- Build_Actual_Subtype --
287 --------------------------
289 function Build_Actual_Subtype
291 N
: Node_Or_Entity_Id
) return Node_Id
294 -- Normally Sloc (N), but may point to corresponding body in some cases
296 Constraints
: List_Id
;
302 Disc_Type
: Entity_Id
;
308 if Nkind
(N
) = N_Defining_Identifier
then
309 Obj
:= New_Reference_To
(N
, Loc
);
311 -- If this is a formal parameter of a subprogram declaration, and
312 -- we are compiling the body, we want the declaration for the
313 -- actual subtype to carry the source position of the body, to
314 -- prevent anomalies in gdb when stepping through the code.
316 if Is_Formal
(N
) then
318 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
320 if Nkind
(Decl
) = N_Subprogram_Declaration
321 and then Present
(Corresponding_Body
(Decl
))
323 Loc
:= Sloc
(Corresponding_Body
(Decl
));
332 if Is_Array_Type
(T
) then
333 Constraints
:= New_List
;
334 for J
in 1 .. Number_Dimensions
(T
) loop
336 -- Build an array subtype declaration with the nominal subtype and
337 -- the bounds of the actual. Add the declaration in front of the
338 -- local declarations for the subprogram, for analysis before any
339 -- reference to the formal in the body.
342 Make_Attribute_Reference
(Loc
,
344 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
345 Attribute_Name
=> Name_First
,
346 Expressions
=> New_List
(
347 Make_Integer_Literal
(Loc
, J
)));
350 Make_Attribute_Reference
(Loc
,
352 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
353 Attribute_Name
=> Name_Last
,
354 Expressions
=> New_List
(
355 Make_Integer_Literal
(Loc
, J
)));
357 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
360 -- If the type has unknown discriminants there is no constrained
361 -- subtype to build. This is never called for a formal or for a
362 -- lhs, so returning the type is ok ???
364 elsif Has_Unknown_Discriminants
(T
) then
368 Constraints
:= New_List
;
370 -- Type T is a generic derived type, inherit the discriminants from
373 if Is_Private_Type
(T
)
374 and then No
(Full_View
(T
))
376 -- T was flagged as an error if it was declared as a formal
377 -- derived type with known discriminants. In this case there
378 -- is no need to look at the parent type since T already carries
379 -- its own discriminants.
381 and then not Error_Posted
(T
)
383 Disc_Type
:= Etype
(Base_Type
(T
));
388 Discr
:= First_Discriminant
(Disc_Type
);
389 while Present
(Discr
) loop
390 Append_To
(Constraints
,
391 Make_Selected_Component
(Loc
,
393 Duplicate_Subexpr_No_Checks
(Obj
),
394 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
395 Next_Discriminant
(Discr
);
400 Make_Defining_Identifier
(Loc
,
401 Chars
=> New_Internal_Name
('S'));
402 Set_Is_Internal
(Subt
);
405 Make_Subtype_Declaration
(Loc
,
406 Defining_Identifier
=> Subt
,
407 Subtype_Indication
=>
408 Make_Subtype_Indication
(Loc
,
409 Subtype_Mark
=> New_Reference_To
(T
, Loc
),
411 Make_Index_Or_Discriminant_Constraint
(Loc
,
412 Constraints
=> Constraints
)));
414 Mark_Rewrite_Insertion
(Decl
);
416 end Build_Actual_Subtype
;
418 ---------------------------------------
419 -- Build_Actual_Subtype_Of_Component --
420 ---------------------------------------
422 function Build_Actual_Subtype_Of_Component
424 N
: Node_Id
) return Node_Id
426 Loc
: constant Source_Ptr
:= Sloc
(N
);
427 P
: constant Node_Id
:= Prefix
(N
);
430 Indx_Type
: Entity_Id
;
432 Deaccessed_T
: Entity_Id
;
433 -- This is either a copy of T, or if T is an access type, then it is
434 -- the directly designated type of this access type.
436 function Build_Actual_Array_Constraint
return List_Id
;
437 -- If one or more of the bounds of the component depends on
438 -- discriminants, build actual constraint using the discriminants
441 function Build_Actual_Record_Constraint
return List_Id
;
442 -- Similar to previous one, for discriminated components constrained
443 -- by the discriminant of the enclosing object.
445 -----------------------------------
446 -- Build_Actual_Array_Constraint --
447 -----------------------------------
449 function Build_Actual_Array_Constraint
return List_Id
is
450 Constraints
: constant List_Id
:= New_List
;
458 Indx
:= First_Index
(Deaccessed_T
);
459 while Present
(Indx
) loop
460 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
461 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
463 if Denotes_Discriminant
(Old_Lo
) then
465 Make_Selected_Component
(Loc
,
466 Prefix
=> New_Copy_Tree
(P
),
467 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
470 Lo
:= New_Copy_Tree
(Old_Lo
);
472 -- The new bound will be reanalyzed in the enclosing
473 -- declaration. For literal bounds that come from a type
474 -- declaration, the type of the context must be imposed, so
475 -- insure that analysis will take place. For non-universal
476 -- types this is not strictly necessary.
478 Set_Analyzed
(Lo
, False);
481 if Denotes_Discriminant
(Old_Hi
) then
483 Make_Selected_Component
(Loc
,
484 Prefix
=> New_Copy_Tree
(P
),
485 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
488 Hi
:= New_Copy_Tree
(Old_Hi
);
489 Set_Analyzed
(Hi
, False);
492 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
497 end Build_Actual_Array_Constraint
;
499 ------------------------------------
500 -- Build_Actual_Record_Constraint --
501 ------------------------------------
503 function Build_Actual_Record_Constraint
return List_Id
is
504 Constraints
: constant List_Id
:= New_List
;
509 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
510 while Present
(D
) loop
511 if Denotes_Discriminant
(Node
(D
)) then
512 D_Val
:= Make_Selected_Component
(Loc
,
513 Prefix
=> New_Copy_Tree
(P
),
514 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
517 D_Val
:= New_Copy_Tree
(Node
(D
));
520 Append
(D_Val
, Constraints
);
525 end Build_Actual_Record_Constraint
;
527 -- Start of processing for Build_Actual_Subtype_Of_Component
530 -- Why the test for Spec_Expression mode here???
532 if In_Spec_Expression
then
535 -- More comments for the rest of this body would be good ???
537 elsif Nkind
(N
) = N_Explicit_Dereference
then
538 if Is_Composite_Type
(T
)
539 and then not Is_Constrained
(T
)
540 and then not (Is_Class_Wide_Type
(T
)
541 and then Is_Constrained
(Root_Type
(T
)))
542 and then not Has_Unknown_Discriminants
(T
)
544 -- If the type of the dereference is already constrained, it
545 -- is an actual subtype.
547 if Is_Array_Type
(Etype
(N
))
548 and then Is_Constrained
(Etype
(N
))
552 Remove_Side_Effects
(P
);
553 return Build_Actual_Subtype
(T
, N
);
560 if Ekind
(T
) = E_Access_Subtype
then
561 Deaccessed_T
:= Designated_Type
(T
);
566 if Ekind
(Deaccessed_T
) = E_Array_Subtype
then
567 Id
:= First_Index
(Deaccessed_T
);
568 while Present
(Id
) loop
569 Indx_Type
:= Underlying_Type
(Etype
(Id
));
571 if Denotes_Discriminant
(Type_Low_Bound
(Indx_Type
))
573 Denotes_Discriminant
(Type_High_Bound
(Indx_Type
))
575 Remove_Side_Effects
(P
);
577 Build_Component_Subtype
578 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
584 elsif Is_Composite_Type
(Deaccessed_T
)
585 and then Has_Discriminants
(Deaccessed_T
)
586 and then not Has_Unknown_Discriminants
(Deaccessed_T
)
588 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
589 while Present
(D
) loop
590 if Denotes_Discriminant
(Node
(D
)) then
591 Remove_Side_Effects
(P
);
593 Build_Component_Subtype
(
594 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
601 -- If none of the above, the actual and nominal subtypes are the same
604 end Build_Actual_Subtype_Of_Component
;
606 -----------------------------
607 -- Build_Component_Subtype --
608 -----------------------------
610 function Build_Component_Subtype
613 T
: Entity_Id
) return Node_Id
619 -- Unchecked_Union components do not require component subtypes
621 if Is_Unchecked_Union
(T
) then
626 Make_Defining_Identifier
(Loc
,
627 Chars
=> New_Internal_Name
('S'));
628 Set_Is_Internal
(Subt
);
631 Make_Subtype_Declaration
(Loc
,
632 Defining_Identifier
=> Subt
,
633 Subtype_Indication
=>
634 Make_Subtype_Indication
(Loc
,
635 Subtype_Mark
=> New_Reference_To
(Base_Type
(T
), Loc
),
637 Make_Index_Or_Discriminant_Constraint
(Loc
,
640 Mark_Rewrite_Insertion
(Decl
);
642 end Build_Component_Subtype
;
644 ---------------------------
645 -- Build_Default_Subtype --
646 ---------------------------
648 function Build_Default_Subtype
650 N
: Node_Id
) return Entity_Id
652 Loc
: constant Source_Ptr
:= Sloc
(N
);
656 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
660 Disc
:= First_Discriminant
(T
);
662 if No
(Discriminant_Default_Value
(Disc
)) then
667 Act
: constant Entity_Id
:=
668 Make_Defining_Identifier
(Loc
,
669 Chars
=> New_Internal_Name
('S'));
671 Constraints
: constant List_Id
:= New_List
;
675 while Present
(Disc
) loop
676 Append_To
(Constraints
,
677 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
678 Next_Discriminant
(Disc
);
682 Make_Subtype_Declaration
(Loc
,
683 Defining_Identifier
=> Act
,
684 Subtype_Indication
=>
685 Make_Subtype_Indication
(Loc
,
686 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
688 Make_Index_Or_Discriminant_Constraint
(Loc
,
689 Constraints
=> Constraints
)));
691 Insert_Action
(N
, Decl
);
695 end Build_Default_Subtype
;
697 --------------------------------------------
698 -- Build_Discriminal_Subtype_Of_Component --
699 --------------------------------------------
701 function Build_Discriminal_Subtype_Of_Component
702 (T
: Entity_Id
) return Node_Id
704 Loc
: constant Source_Ptr
:= Sloc
(T
);
708 function Build_Discriminal_Array_Constraint
return List_Id
;
709 -- If one or more of the bounds of the component depends on
710 -- discriminants, build actual constraint using the discriminants
713 function Build_Discriminal_Record_Constraint
return List_Id
;
714 -- Similar to previous one, for discriminated components constrained
715 -- by the discriminant of the enclosing object.
717 ----------------------------------------
718 -- Build_Discriminal_Array_Constraint --
719 ----------------------------------------
721 function Build_Discriminal_Array_Constraint
return List_Id
is
722 Constraints
: constant List_Id
:= New_List
;
730 Indx
:= First_Index
(T
);
731 while Present
(Indx
) loop
732 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
733 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
735 if Denotes_Discriminant
(Old_Lo
) then
736 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
739 Lo
:= New_Copy_Tree
(Old_Lo
);
742 if Denotes_Discriminant
(Old_Hi
) then
743 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
746 Hi
:= New_Copy_Tree
(Old_Hi
);
749 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
754 end Build_Discriminal_Array_Constraint
;
756 -----------------------------------------
757 -- Build_Discriminal_Record_Constraint --
758 -----------------------------------------
760 function Build_Discriminal_Record_Constraint
return List_Id
is
761 Constraints
: constant List_Id
:= New_List
;
766 D
:= First_Elmt
(Discriminant_Constraint
(T
));
767 while Present
(D
) loop
768 if Denotes_Discriminant
(Node
(D
)) then
770 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
773 D_Val
:= New_Copy_Tree
(Node
(D
));
776 Append
(D_Val
, Constraints
);
781 end Build_Discriminal_Record_Constraint
;
783 -- Start of processing for Build_Discriminal_Subtype_Of_Component
786 if Ekind
(T
) = E_Array_Subtype
then
787 Id
:= First_Index
(T
);
788 while Present
(Id
) loop
789 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
))) or else
790 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
792 return Build_Component_Subtype
793 (Build_Discriminal_Array_Constraint
, Loc
, T
);
799 elsif Ekind
(T
) = E_Record_Subtype
800 and then Has_Discriminants
(T
)
801 and then not Has_Unknown_Discriminants
(T
)
803 D
:= First_Elmt
(Discriminant_Constraint
(T
));
804 while Present
(D
) loop
805 if Denotes_Discriminant
(Node
(D
)) then
806 return Build_Component_Subtype
807 (Build_Discriminal_Record_Constraint
, Loc
, T
);
814 -- If none of the above, the actual and nominal subtypes are the same
817 end Build_Discriminal_Subtype_Of_Component
;
819 ------------------------------
820 -- Build_Elaboration_Entity --
821 ------------------------------
823 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
824 Loc
: constant Source_Ptr
:= Sloc
(N
);
826 Elab_Ent
: Entity_Id
;
828 procedure Set_Package_Name
(Ent
: Entity_Id
);
829 -- Given an entity, sets the fully qualified name of the entity in
830 -- Name_Buffer, with components separated by double underscores. This
831 -- is a recursive routine that climbs the scope chain to Standard.
833 ----------------------
834 -- Set_Package_Name --
835 ----------------------
837 procedure Set_Package_Name
(Ent
: Entity_Id
) is
839 if Scope
(Ent
) /= Standard_Standard
then
840 Set_Package_Name
(Scope
(Ent
));
843 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
845 Name_Buffer
(Name_Len
+ 1) := '_';
846 Name_Buffer
(Name_Len
+ 2) := '_';
847 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
848 Name_Len
:= Name_Len
+ Nam
'Length + 2;
852 Get_Name_String
(Chars
(Ent
));
854 end Set_Package_Name
;
856 -- Start of processing for Build_Elaboration_Entity
859 -- Ignore if already constructed
861 if Present
(Elaboration_Entity
(Spec_Id
)) then
865 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
866 -- name with dots replaced by double underscore. We have to manually
867 -- construct this name, since it will be elaborated in the outer scope,
868 -- and thus will not have the unit name automatically prepended.
870 Set_Package_Name
(Spec_Id
);
874 Name_Buffer
(Name_Len
+ 1) := '_';
875 Name_Buffer
(Name_Len
+ 2) := 'E';
876 Name_Len
:= Name_Len
+ 2;
878 -- Create elaboration flag
881 Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
882 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
885 Make_Object_Declaration
(Loc
,
886 Defining_Identifier
=> Elab_Ent
,
888 New_Occurrence_Of
(Standard_Boolean
, Loc
),
890 New_Occurrence_Of
(Standard_False
, Loc
));
892 Push_Scope
(Standard_Standard
);
893 Add_Global_Declaration
(Decl
);
896 -- Reset True_Constant indication, since we will indeed assign a value
897 -- to the variable in the binder main. We also kill the Current_Value
898 -- and Last_Assignment fields for the same reason.
900 Set_Is_True_Constant
(Elab_Ent
, False);
901 Set_Current_Value
(Elab_Ent
, Empty
);
902 Set_Last_Assignment
(Elab_Ent
, Empty
);
904 -- We do not want any further qualification of the name (if we did
905 -- not do this, we would pick up the name of the generic package
906 -- in the case of a library level generic instantiation).
908 Set_Has_Qualified_Name
(Elab_Ent
);
909 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
910 end Build_Elaboration_Entity
;
912 -----------------------------------
913 -- Cannot_Raise_Constraint_Error --
914 -----------------------------------
916 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
918 if Compile_Time_Known_Value
(Expr
) then
921 elsif Do_Range_Check
(Expr
) then
924 elsif Raises_Constraint_Error
(Expr
) then
932 when N_Expanded_Name
=>
935 when N_Selected_Component
=>
936 return not Do_Discriminant_Check
(Expr
);
938 when N_Attribute_Reference
=>
939 if Do_Overflow_Check
(Expr
) then
942 elsif No
(Expressions
(Expr
)) then
950 N
:= First
(Expressions
(Expr
));
951 while Present
(N
) loop
952 if Cannot_Raise_Constraint_Error
(N
) then
963 when N_Type_Conversion
=>
964 if Do_Overflow_Check
(Expr
)
965 or else Do_Length_Check
(Expr
)
966 or else Do_Tag_Check
(Expr
)
971 Cannot_Raise_Constraint_Error
(Expression
(Expr
));
974 when N_Unchecked_Type_Conversion
=>
975 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
978 if Do_Overflow_Check
(Expr
) then
982 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
989 if Do_Division_Check
(Expr
)
990 or else Do_Overflow_Check
(Expr
)
995 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
997 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1016 N_Op_Shift_Right_Arithmetic |
1020 if Do_Overflow_Check
(Expr
) then
1024 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
1026 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1033 end Cannot_Raise_Constraint_Error
;
1035 --------------------------
1036 -- Check_Fully_Declared --
1037 --------------------------
1039 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
1041 if Ekind
(T
) = E_Incomplete_Type
then
1043 -- Ada 2005 (AI-50217): If the type is available through a limited
1044 -- with_clause, verify that its full view has been analyzed.
1046 if From_With_Type
(T
)
1047 and then Present
(Non_Limited_View
(T
))
1048 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
1050 -- The non-limited view is fully declared
1055 ("premature usage of incomplete}", N
, First_Subtype
(T
));
1058 -- Need comments for these tests ???
1060 elsif Has_Private_Component
(T
)
1061 and then not Is_Generic_Type
(Root_Type
(T
))
1062 and then not In_Spec_Expression
1064 -- Special case: if T is the anonymous type created for a single
1065 -- task or protected object, use the name of the source object.
1067 if Is_Concurrent_Type
(T
)
1068 and then not Comes_From_Source
(T
)
1069 and then Nkind
(N
) = N_Object_Declaration
1071 Error_Msg_NE
("type of& has incomplete component", N
,
1072 Defining_Identifier
(N
));
1076 ("premature usage of incomplete}", N
, First_Subtype
(T
));
1079 end Check_Fully_Declared
;
1081 -------------------------
1082 -- Check_Nested_Access --
1083 -------------------------
1085 procedure Check_Nested_Access
(Ent
: Entity_Id
) is
1086 Scop
: constant Entity_Id
:= Current_Scope
;
1087 Current_Subp
: Entity_Id
;
1088 Enclosing
: Entity_Id
;
1091 -- Currently only enabled for VM back-ends for efficiency, should we
1092 -- enable it more systematically ???
1094 -- Check for Is_Imported needs commenting below ???
1096 if VM_Target
/= No_VM
1097 and then (Ekind
(Ent
) = E_Variable
1099 Ekind
(Ent
) = E_Constant
1101 Ekind
(Ent
) = E_Loop_Parameter
)
1102 and then Scope
(Ent
) /= Empty
1103 and then not Is_Library_Level_Entity
(Ent
)
1104 and then not Is_Imported
(Ent
)
1106 if Is_Subprogram
(Scop
)
1107 or else Is_Generic_Subprogram
(Scop
)
1108 or else Is_Entry
(Scop
)
1110 Current_Subp
:= Scop
;
1112 Current_Subp
:= Current_Subprogram
;
1115 Enclosing
:= Enclosing_Subprogram
(Ent
);
1117 if Enclosing
/= Empty
1118 and then Enclosing
/= Current_Subp
1120 Set_Has_Up_Level_Access
(Ent
, True);
1123 end Check_Nested_Access
;
1125 ------------------------------------------
1126 -- Check_Potentially_Blocking_Operation --
1127 ------------------------------------------
1129 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
1132 -- N is one of the potentially blocking operations listed in 9.5.1(8).
1133 -- When pragma Detect_Blocking is active, the run time will raise
1134 -- Program_Error. Here we only issue a warning, since we generally
1135 -- support the use of potentially blocking operations in the absence
1138 -- Indirect blocking through a subprogram call cannot be diagnosed
1139 -- statically without interprocedural analysis, so we do not attempt
1142 S
:= Scope
(Current_Scope
);
1143 while Present
(S
) and then S
/= Standard_Standard
loop
1144 if Is_Protected_Type
(S
) then
1146 ("potentially blocking operation in protected operation?", N
);
1153 end Check_Potentially_Blocking_Operation
;
1155 ------------------------------
1156 -- Check_Unprotected_Access --
1157 ------------------------------
1159 procedure Check_Unprotected_Access
1163 Cont_Encl_Typ
: Entity_Id
;
1164 Pref_Encl_Typ
: Entity_Id
;
1166 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
1167 -- Check whether Obj is a private component of a protected object.
1168 -- Return the protected type where the component resides, Empty
1171 function Is_Public_Operation
return Boolean;
1172 -- Verify that the enclosing operation is callable from outside the
1173 -- protected object, to minimize false positives.
1175 ------------------------------
1176 -- Enclosing_Protected_Type --
1177 ------------------------------
1179 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
1181 if Is_Entity_Name
(Obj
) then
1183 Ent
: Entity_Id
:= Entity
(Obj
);
1186 -- The object can be a renaming of a private component, use
1187 -- the original record component.
1189 if Is_Prival
(Ent
) then
1190 Ent
:= Prival_Link
(Ent
);
1193 if Is_Protected_Type
(Scope
(Ent
)) then
1199 -- For indexed and selected components, recursively check the prefix
1201 if Nkind_In
(Obj
, N_Indexed_Component
, N_Selected_Component
) then
1202 return Enclosing_Protected_Type
(Prefix
(Obj
));
1204 -- The object does not denote a protected component
1209 end Enclosing_Protected_Type
;
1211 -------------------------
1212 -- Is_Public_Operation --
1213 -------------------------
1215 function Is_Public_Operation
return Boolean is
1222 and then S
/= Pref_Encl_Typ
1224 if Scope
(S
) = Pref_Encl_Typ
then
1225 E
:= First_Entity
(Pref_Encl_Typ
);
1227 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
1240 end Is_Public_Operation
;
1242 -- Start of processing for Check_Unprotected_Access
1245 if Nkind
(Expr
) = N_Attribute_Reference
1246 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
1248 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
1249 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
1251 -- Check whether we are trying to export a protected component to a
1252 -- context with an equal or lower access level.
1254 if Present
(Pref_Encl_Typ
)
1255 and then No
(Cont_Encl_Typ
)
1256 and then Is_Public_Operation
1257 and then Scope_Depth
(Pref_Encl_Typ
) >=
1258 Object_Access_Level
(Context
)
1261 ("?possible unprotected access to protected data", Expr
);
1264 end Check_Unprotected_Access
;
1270 procedure Check_VMS
(Construct
: Node_Id
) is
1272 if not OpenVMS_On_Target
then
1274 ("this construct is allowed only in Open'V'M'S", Construct
);
1278 ------------------------
1279 -- Collect_Interfaces --
1280 ------------------------
1282 procedure Collect_Interfaces
1284 Ifaces_List
: out Elist_Id
;
1285 Exclude_Parents
: Boolean := False;
1286 Use_Full_View
: Boolean := True)
1288 procedure Collect
(Typ
: Entity_Id
);
1289 -- Subsidiary subprogram used to traverse the whole list
1290 -- of directly and indirectly implemented interfaces
1296 procedure Collect
(Typ
: Entity_Id
) is
1297 Ancestor
: Entity_Id
;
1305 -- Handle private types
1308 and then Is_Private_Type
(Typ
)
1309 and then Present
(Full_View
(Typ
))
1311 Full_T
:= Full_View
(Typ
);
1314 -- Include the ancestor if we are generating the whole list of
1315 -- abstract interfaces.
1317 if Etype
(Full_T
) /= Typ
1319 -- Protect the frontend against wrong sources. For example:
1322 -- type A is tagged null record;
1323 -- type B is new A with private;
1324 -- type C is new A with private;
1326 -- type B is new C with null record;
1327 -- type C is new B with null record;
1330 and then Etype
(Full_T
) /= T
1332 Ancestor
:= Etype
(Full_T
);
1335 if Is_Interface
(Ancestor
)
1336 and then not Exclude_Parents
1338 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
1342 -- Traverse the graph of ancestor interfaces
1344 if Is_Non_Empty_List
(Abstract_Interface_List
(Full_T
)) then
1345 Id
:= First
(Abstract_Interface_List
(Full_T
));
1346 while Present
(Id
) loop
1347 Iface
:= Etype
(Id
);
1349 -- Protect against wrong uses. For example:
1350 -- type I is interface;
1351 -- type O is tagged null record;
1352 -- type Wrong is new I and O with null record; -- ERROR
1354 if Is_Interface
(Iface
) then
1356 and then Etype
(T
) /= T
1357 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
1362 Append_Unique_Elmt
(Iface
, Ifaces_List
);
1371 -- Start of processing for Collect_Interfaces
1374 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
1375 Ifaces_List
:= New_Elmt_List
;
1377 end Collect_Interfaces
;
1379 ----------------------------------
1380 -- Collect_Interface_Components --
1381 ----------------------------------
1383 procedure Collect_Interface_Components
1384 (Tagged_Type
: Entity_Id
;
1385 Components_List
: out Elist_Id
)
1387 procedure Collect
(Typ
: Entity_Id
);
1388 -- Subsidiary subprogram used to climb to the parents
1394 procedure Collect
(Typ
: Entity_Id
) is
1395 Tag_Comp
: Entity_Id
;
1396 Parent_Typ
: Entity_Id
;
1399 -- Handle private types
1401 if Present
(Full_View
(Etype
(Typ
))) then
1402 Parent_Typ
:= Full_View
(Etype
(Typ
));
1404 Parent_Typ
:= Etype
(Typ
);
1407 if Parent_Typ
/= Typ
1409 -- Protect the frontend against wrong sources. For example:
1412 -- type A is tagged null record;
1413 -- type B is new A with private;
1414 -- type C is new A with private;
1416 -- type B is new C with null record;
1417 -- type C is new B with null record;
1420 and then Parent_Typ
/= Tagged_Type
1422 Collect
(Parent_Typ
);
1425 -- Collect the components containing tags of secondary dispatch
1428 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1429 while Present
(Tag_Comp
) loop
1430 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
1431 Append_Elmt
(Tag_Comp
, Components_List
);
1433 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
1437 -- Start of processing for Collect_Interface_Components
1440 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
1441 and then Is_Tagged_Type
(Tagged_Type
));
1443 Components_List
:= New_Elmt_List
;
1444 Collect
(Tagged_Type
);
1445 end Collect_Interface_Components
;
1447 -----------------------------
1448 -- Collect_Interfaces_Info --
1449 -----------------------------
1451 procedure Collect_Interfaces_Info
1453 Ifaces_List
: out Elist_Id
;
1454 Components_List
: out Elist_Id
;
1455 Tags_List
: out Elist_Id
)
1457 Comps_List
: Elist_Id
;
1458 Comp_Elmt
: Elmt_Id
;
1459 Comp_Iface
: Entity_Id
;
1460 Iface_Elmt
: Elmt_Id
;
1463 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
1464 -- Search for the secondary tag associated with the interface type
1465 -- Iface that is implemented by T.
1471 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
1475 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
1477 and then Ekind
(Node
(ADT
)) = E_Constant
1478 and then Related_Type
(Node
(ADT
)) /= Iface
1480 -- Skip the secondary dispatch tables of Iface
1488 pragma Assert
(Ekind
(Node
(ADT
)) = E_Constant
);
1492 -- Start of processing for Collect_Interfaces_Info
1495 Collect_Interfaces
(T
, Ifaces_List
);
1496 Collect_Interface_Components
(T
, Comps_List
);
1498 -- Search for the record component and tag associated with each
1499 -- interface type of T.
1501 Components_List
:= New_Elmt_List
;
1502 Tags_List
:= New_Elmt_List
;
1504 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
1505 while Present
(Iface_Elmt
) loop
1506 Iface
:= Node
(Iface_Elmt
);
1508 -- Associate the primary tag component and the primary dispatch table
1509 -- with all the interfaces that are parents of T
1511 if Is_Ancestor
(Iface
, T
) then
1512 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
1513 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
1515 -- Otherwise search for the tag component and secondary dispatch
1519 Comp_Elmt
:= First_Elmt
(Comps_List
);
1520 while Present
(Comp_Elmt
) loop
1521 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
1523 if Comp_Iface
= Iface
1524 or else Is_Ancestor
(Iface
, Comp_Iface
)
1526 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
1527 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
1531 Next_Elmt
(Comp_Elmt
);
1533 pragma Assert
(Present
(Comp_Elmt
));
1536 Next_Elmt
(Iface_Elmt
);
1538 end Collect_Interfaces_Info
;
1540 ----------------------------------
1541 -- Collect_Primitive_Operations --
1542 ----------------------------------
1544 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
1545 B_Type
: constant Entity_Id
:= Base_Type
(T
);
1546 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
1547 B_Scope
: Entity_Id
:= Scope
(B_Type
);
1551 Formal_Derived
: Boolean := False;
1555 -- For tagged types, the primitive operations are collected as they
1556 -- are declared, and held in an explicit list which is simply returned.
1558 if Is_Tagged_Type
(B_Type
) then
1559 return Primitive_Operations
(B_Type
);
1561 -- An untagged generic type that is a derived type inherits the
1562 -- primitive operations of its parent type. Other formal types only
1563 -- have predefined operators, which are not explicitly represented.
1565 elsif Is_Generic_Type
(B_Type
) then
1566 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
1567 and then Nkind
(Formal_Type_Definition
(B_Decl
))
1568 = N_Formal_Derived_Type_Definition
1570 Formal_Derived
:= True;
1572 return New_Elmt_List
;
1576 Op_List
:= New_Elmt_List
;
1578 if B_Scope
= Standard_Standard
then
1579 if B_Type
= Standard_String
then
1580 Append_Elmt
(Standard_Op_Concat
, Op_List
);
1582 elsif B_Type
= Standard_Wide_String
then
1583 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
1589 elsif (Is_Package_Or_Generic_Package
(B_Scope
)
1591 Nkind
(Parent
(Declaration_Node
(First_Subtype
(T
)))) /=
1593 or else Is_Derived_Type
(B_Type
)
1595 -- The primitive operations appear after the base type, except
1596 -- if the derivation happens within the private part of B_Scope
1597 -- and the type is a private type, in which case both the type
1598 -- and some primitive operations may appear before the base
1599 -- type, and the list of candidates starts after the type.
1601 if In_Open_Scopes
(B_Scope
)
1602 and then Scope
(T
) = B_Scope
1603 and then In_Private_Part
(B_Scope
)
1605 Id
:= Next_Entity
(T
);
1607 Id
:= Next_Entity
(B_Type
);
1610 while Present
(Id
) loop
1612 -- Note that generic formal subprograms are not
1613 -- considered to be primitive operations and thus
1614 -- are never inherited.
1616 if Is_Overloadable
(Id
)
1617 and then Nkind
(Parent
(Parent
(Id
)))
1618 not in N_Formal_Subprogram_Declaration
1622 if Base_Type
(Etype
(Id
)) = B_Type
then
1625 Formal
:= First_Formal
(Id
);
1626 while Present
(Formal
) loop
1627 if Base_Type
(Etype
(Formal
)) = B_Type
then
1631 elsif Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
1633 (Designated_Type
(Etype
(Formal
))) = B_Type
1639 Next_Formal
(Formal
);
1643 -- For a formal derived type, the only primitives are the
1644 -- ones inherited from the parent type. Operations appearing
1645 -- in the package declaration are not primitive for it.
1648 and then (not Formal_Derived
1649 or else Present
(Alias
(Id
)))
1651 Append_Elmt
(Id
, Op_List
);
1657 -- For a type declared in System, some of its operations
1658 -- may appear in the target-specific extension to System.
1661 and then Chars
(B_Scope
) = Name_System
1662 and then Scope
(B_Scope
) = Standard_Standard
1663 and then Present_System_Aux
1665 B_Scope
:= System_Aux_Id
;
1666 Id
:= First_Entity
(System_Aux_Id
);
1672 end Collect_Primitive_Operations
;
1674 -----------------------------------
1675 -- Compile_Time_Constraint_Error --
1676 -----------------------------------
1678 function Compile_Time_Constraint_Error
1681 Ent
: Entity_Id
:= Empty
;
1682 Loc
: Source_Ptr
:= No_Location
;
1683 Warn
: Boolean := False) return Node_Id
1685 Msgc
: String (1 .. Msg
'Length + 2);
1686 -- Copy of message, with room for possible ? and ! at end
1696 -- A static constraint error in an instance body is not a fatal error.
1697 -- we choose to inhibit the message altogether, because there is no
1698 -- obvious node (for now) on which to post it. On the other hand the
1699 -- offending node must be replaced with a constraint_error in any case.
1701 -- No messages are generated if we already posted an error on this node
1703 if not Error_Posted
(N
) then
1704 if Loc
/= No_Location
then
1710 Msgc
(1 .. Msg
'Length) := Msg
;
1713 -- Message is a warning, even in Ada 95 case
1715 if Msg
(Msg
'Last) = '?' then
1718 -- In Ada 83, all messages are warnings. In the private part and
1719 -- the body of an instance, constraint_checks are only warnings.
1720 -- We also make this a warning if the Warn parameter is set.
1723 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
1729 elsif In_Instance_Not_Visible
then
1734 -- Otherwise we have a real error message (Ada 95 static case)
1735 -- and we make this an unconditional message. Note that in the
1736 -- warning case we do not make the message unconditional, it seems
1737 -- quite reasonable to delete messages like this (about exceptions
1738 -- that will be raised) in dead code.
1746 -- Should we generate a warning? The answer is not quite yes. The
1747 -- very annoying exception occurs in the case of a short circuit
1748 -- operator where the left operand is static and decisive. Climb
1749 -- parents to see if that is the case we have here. Conditional
1750 -- expressions with decisive conditions are a similar situation.
1758 -- And then with False as left operand
1760 if Nkind
(P
) = N_And_Then
1761 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1762 and then Is_False
(Expr_Value
(Left_Opnd
(P
)))
1767 -- OR ELSE with True as left operand
1769 elsif Nkind
(P
) = N_Or_Else
1770 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1771 and then Is_True
(Expr_Value
(Left_Opnd
(P
)))
1776 -- Conditional expression
1778 elsif Nkind
(P
) = N_Conditional_Expression
then
1780 Cond
: constant Node_Id
:= First
(Expressions
(P
));
1781 Texp
: constant Node_Id
:= Next
(Cond
);
1782 Fexp
: constant Node_Id
:= Next
(Texp
);
1785 if Compile_Time_Known_Value
(Cond
) then
1787 -- Condition is True and we are in the right operand
1789 if Is_True
(Expr_Value
(Cond
))
1790 and then OldP
= Fexp
1795 -- Condition is False and we are in the left operand
1797 elsif Is_False
(Expr_Value
(Cond
))
1798 and then OldP
= Texp
1806 -- Special case for component association in aggregates, where
1807 -- we want to keep climbing up to the parent aggregate.
1809 elsif Nkind
(P
) = N_Component_Association
1810 and then Nkind
(Parent
(P
)) = N_Aggregate
1814 -- Keep going if within subexpression
1817 exit when Nkind
(P
) not in N_Subexpr
;
1822 if Present
(Ent
) then
1823 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
1825 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
1829 if Inside_Init_Proc
then
1831 ("\?& will be raised for objects of this type",
1832 N
, Standard_Constraint_Error
, Eloc
);
1835 ("\?& will be raised at run time",
1836 N
, Standard_Constraint_Error
, Eloc
);
1841 ("\static expression fails Constraint_Check", Eloc
);
1842 Set_Error_Posted
(N
);
1848 end Compile_Time_Constraint_Error
;
1850 -----------------------
1851 -- Conditional_Delay --
1852 -----------------------
1854 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
1856 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
1857 Set_Has_Delayed_Freeze
(New_Ent
);
1859 end Conditional_Delay
;
1861 -------------------------
1862 -- Copy_Parameter_List --
1863 -------------------------
1865 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
1866 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
1871 if No
(First_Formal
(Subp_Id
)) then
1875 Formal
:= First_Formal
(Subp_Id
);
1876 while Present
(Formal
) loop
1878 (Make_Parameter_Specification
(Loc
,
1879 Defining_Identifier
=>
1880 Make_Defining_Identifier
(Sloc
(Formal
),
1881 Chars
=> Chars
(Formal
)),
1882 In_Present
=> In_Present
(Parent
(Formal
)),
1883 Out_Present
=> Out_Present
(Parent
(Formal
)),
1885 New_Reference_To
(Etype
(Formal
), Loc
),
1887 New_Copy_Tree
(Expression
(Parent
(Formal
)))),
1890 Next_Formal
(Formal
);
1895 end Copy_Parameter_List
;
1897 --------------------
1898 -- Current_Entity --
1899 --------------------
1901 -- The currently visible definition for a given identifier is the
1902 -- one most chained at the start of the visibility chain, i.e. the
1903 -- one that is referenced by the Node_Id value of the name of the
1904 -- given identifier.
1906 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
1908 return Get_Name_Entity_Id
(Chars
(N
));
1911 -----------------------------
1912 -- Current_Entity_In_Scope --
1913 -----------------------------
1915 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
1917 CS
: constant Entity_Id
:= Current_Scope
;
1919 Transient_Case
: constant Boolean := Scope_Is_Transient
;
1922 E
:= Get_Name_Entity_Id
(Chars
(N
));
1924 and then Scope
(E
) /= CS
1925 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
1931 end Current_Entity_In_Scope
;
1937 function Current_Scope
return Entity_Id
is
1939 if Scope_Stack
.Last
= -1 then
1940 return Standard_Standard
;
1943 C
: constant Entity_Id
:=
1944 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
1949 return Standard_Standard
;
1955 ------------------------
1956 -- Current_Subprogram --
1957 ------------------------
1959 function Current_Subprogram
return Entity_Id
is
1960 Scop
: constant Entity_Id
:= Current_Scope
;
1962 if Is_Subprogram
(Scop
) or else Is_Generic_Subprogram
(Scop
) then
1965 return Enclosing_Subprogram
(Scop
);
1967 end Current_Subprogram
;
1969 ---------------------
1970 -- Defining_Entity --
1971 ---------------------
1973 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
1974 K
: constant Node_Kind
:= Nkind
(N
);
1975 Err
: Entity_Id
:= Empty
;
1980 N_Subprogram_Declaration |
1981 N_Abstract_Subprogram_Declaration |
1983 N_Package_Declaration |
1984 N_Subprogram_Renaming_Declaration |
1985 N_Subprogram_Body_Stub |
1986 N_Generic_Subprogram_Declaration |
1987 N_Generic_Package_Declaration |
1988 N_Formal_Subprogram_Declaration
1990 return Defining_Entity
(Specification
(N
));
1993 N_Component_Declaration |
1994 N_Defining_Program_Unit_Name |
1995 N_Discriminant_Specification |
1997 N_Entry_Declaration |
1998 N_Entry_Index_Specification |
1999 N_Exception_Declaration |
2000 N_Exception_Renaming_Declaration |
2001 N_Formal_Object_Declaration |
2002 N_Formal_Package_Declaration |
2003 N_Formal_Type_Declaration |
2004 N_Full_Type_Declaration |
2005 N_Implicit_Label_Declaration |
2006 N_Incomplete_Type_Declaration |
2007 N_Loop_Parameter_Specification |
2008 N_Number_Declaration |
2009 N_Object_Declaration |
2010 N_Object_Renaming_Declaration |
2011 N_Package_Body_Stub |
2012 N_Parameter_Specification |
2013 N_Private_Extension_Declaration |
2014 N_Private_Type_Declaration |
2016 N_Protected_Body_Stub |
2017 N_Protected_Type_Declaration |
2018 N_Single_Protected_Declaration |
2019 N_Single_Task_Declaration |
2020 N_Subtype_Declaration |
2023 N_Task_Type_Declaration
2025 return Defining_Identifier
(N
);
2028 return Defining_Entity
(Proper_Body
(N
));
2031 N_Function_Instantiation |
2032 N_Function_Specification |
2033 N_Generic_Function_Renaming_Declaration |
2034 N_Generic_Package_Renaming_Declaration |
2035 N_Generic_Procedure_Renaming_Declaration |
2037 N_Package_Instantiation |
2038 N_Package_Renaming_Declaration |
2039 N_Package_Specification |
2040 N_Procedure_Instantiation |
2041 N_Procedure_Specification
2044 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
2047 if Nkind
(Nam
) in N_Entity
then
2050 -- For Error, make up a name and attach to declaration
2051 -- so we can continue semantic analysis
2053 elsif Nam
= Error
then
2055 Make_Defining_Identifier
(Sloc
(N
),
2056 Chars
=> New_Internal_Name
('T'));
2057 Set_Defining_Unit_Name
(N
, Err
);
2060 -- If not an entity, get defining identifier
2063 return Defining_Identifier
(Nam
);
2067 when N_Block_Statement
=>
2068 return Entity
(Identifier
(N
));
2071 raise Program_Error
;
2074 end Defining_Entity
;
2076 --------------------------
2077 -- Denotes_Discriminant --
2078 --------------------------
2080 function Denotes_Discriminant
2082 Check_Concurrent
: Boolean := False) return Boolean
2086 if not Is_Entity_Name
(N
)
2087 or else No
(Entity
(N
))
2094 -- If we are checking for a protected type, the discriminant may have
2095 -- been rewritten as the corresponding discriminal of the original type
2096 -- or of the corresponding concurrent record, depending on whether we
2097 -- are in the spec or body of the protected type.
2099 return Ekind
(E
) = E_Discriminant
2102 and then Ekind
(E
) = E_In_Parameter
2103 and then Present
(Discriminal_Link
(E
))
2105 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
2107 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
2109 end Denotes_Discriminant
;
2111 ----------------------
2112 -- Denotes_Variable --
2113 ----------------------
2115 function Denotes_Variable
(N
: Node_Id
) return Boolean is
2117 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
2118 end Denotes_Variable
;
2120 -----------------------------
2121 -- Depends_On_Discriminant --
2122 -----------------------------
2124 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
2129 Get_Index_Bounds
(N
, L
, H
);
2130 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
2131 end Depends_On_Discriminant
;
2133 -------------------------
2134 -- Designate_Same_Unit --
2135 -------------------------
2137 function Designate_Same_Unit
2139 Name2
: Node_Id
) return Boolean
2141 K1
: constant Node_Kind
:= Nkind
(Name1
);
2142 K2
: constant Node_Kind
:= Nkind
(Name2
);
2144 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
2145 -- Returns the parent unit name node of a defining program unit name
2146 -- or the prefix if N is a selected component or an expanded name.
2148 function Select_Node
(N
: Node_Id
) return Node_Id
;
2149 -- Returns the defining identifier node of a defining program unit
2150 -- name or the selector node if N is a selected component or an
2157 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
2159 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
2171 function Select_Node
(N
: Node_Id
) return Node_Id
is
2173 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
2174 return Defining_Identifier
(N
);
2177 return Selector_Name
(N
);
2181 -- Start of processing for Designate_Next_Unit
2184 if (K1
= N_Identifier
or else
2185 K1
= N_Defining_Identifier
)
2187 (K2
= N_Identifier
or else
2188 K2
= N_Defining_Identifier
)
2190 return Chars
(Name1
) = Chars
(Name2
);
2193 (K1
= N_Expanded_Name
or else
2194 K1
= N_Selected_Component
or else
2195 K1
= N_Defining_Program_Unit_Name
)
2197 (K2
= N_Expanded_Name
or else
2198 K2
= N_Selected_Component
or else
2199 K2
= N_Defining_Program_Unit_Name
)
2202 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
2204 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
2209 end Designate_Same_Unit
;
2211 ----------------------------
2212 -- Enclosing_Generic_Body --
2213 ----------------------------
2215 function Enclosing_Generic_Body
2216 (N
: Node_Id
) return Node_Id
2224 while Present
(P
) loop
2225 if Nkind
(P
) = N_Package_Body
2226 or else Nkind
(P
) = N_Subprogram_Body
2228 Spec
:= Corresponding_Spec
(P
);
2230 if Present
(Spec
) then
2231 Decl
:= Unit_Declaration_Node
(Spec
);
2233 if Nkind
(Decl
) = N_Generic_Package_Declaration
2234 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
2245 end Enclosing_Generic_Body
;
2247 ----------------------------
2248 -- Enclosing_Generic_Unit --
2249 ----------------------------
2251 function Enclosing_Generic_Unit
2252 (N
: Node_Id
) return Node_Id
2260 while Present
(P
) loop
2261 if Nkind
(P
) = N_Generic_Package_Declaration
2262 or else Nkind
(P
) = N_Generic_Subprogram_Declaration
2266 elsif Nkind
(P
) = N_Package_Body
2267 or else Nkind
(P
) = N_Subprogram_Body
2269 Spec
:= Corresponding_Spec
(P
);
2271 if Present
(Spec
) then
2272 Decl
:= Unit_Declaration_Node
(Spec
);
2274 if Nkind
(Decl
) = N_Generic_Package_Declaration
2275 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
2286 end Enclosing_Generic_Unit
;
2288 -------------------------------
2289 -- Enclosing_Lib_Unit_Entity --
2290 -------------------------------
2292 function Enclosing_Lib_Unit_Entity
return Entity_Id
is
2293 Unit_Entity
: Entity_Id
;
2296 -- Look for enclosing library unit entity by following scope links.
2297 -- Equivalent to, but faster than indexing through the scope stack.
2299 Unit_Entity
:= Current_Scope
;
2300 while (Present
(Scope
(Unit_Entity
))
2301 and then Scope
(Unit_Entity
) /= Standard_Standard
)
2302 and not Is_Child_Unit
(Unit_Entity
)
2304 Unit_Entity
:= Scope
(Unit_Entity
);
2308 end Enclosing_Lib_Unit_Entity
;
2310 -----------------------------
2311 -- Enclosing_Lib_Unit_Node --
2312 -----------------------------
2314 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
2315 Current_Node
: Node_Id
;
2319 while Present
(Current_Node
)
2320 and then Nkind
(Current_Node
) /= N_Compilation_Unit
2322 Current_Node
:= Parent
(Current_Node
);
2325 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
2329 return Current_Node
;
2330 end Enclosing_Lib_Unit_Node
;
2332 --------------------------
2333 -- Enclosing_Subprogram --
2334 --------------------------
2336 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
2337 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
2340 if Dynamic_Scope
= Standard_Standard
then
2343 elsif Dynamic_Scope
= Empty
then
2346 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
2347 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
2349 elsif Ekind
(Dynamic_Scope
) = E_Block
2350 or else Ekind
(Dynamic_Scope
) = E_Return_Statement
2352 return Enclosing_Subprogram
(Dynamic_Scope
);
2354 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
2355 return Get_Task_Body_Procedure
(Dynamic_Scope
);
2357 elsif Convention
(Dynamic_Scope
) = Convention_Protected
then
2358 return Protected_Body_Subprogram
(Dynamic_Scope
);
2361 return Dynamic_Scope
;
2363 end Enclosing_Subprogram
;
2365 ------------------------
2366 -- Ensure_Freeze_Node --
2367 ------------------------
2369 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
2373 if No
(Freeze_Node
(E
)) then
2374 FN
:= Make_Freeze_Entity
(Sloc
(E
));
2375 Set_Has_Delayed_Freeze
(E
);
2376 Set_Freeze_Node
(E
, FN
);
2377 Set_Access_Types_To_Process
(FN
, No_Elist
);
2378 Set_TSS_Elist
(FN
, No_Elist
);
2381 end Ensure_Freeze_Node
;
2387 procedure Enter_Name
(Def_Id
: Entity_Id
) is
2388 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
2389 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
2390 S
: constant Entity_Id
:= Current_Scope
;
2393 Generate_Definition
(Def_Id
);
2395 -- Add new name to current scope declarations. Check for duplicate
2396 -- declaration, which may or may not be a genuine error.
2400 -- Case of previous entity entered because of a missing declaration
2401 -- or else a bad subtype indication. Best is to use the new entity,
2402 -- and make the previous one invisible.
2404 if Etype
(E
) = Any_Type
then
2405 Set_Is_Immediately_Visible
(E
, False);
2407 -- Case of renaming declaration constructed for package instances.
2408 -- if there is an explicit declaration with the same identifier,
2409 -- the renaming is not immediately visible any longer, but remains
2410 -- visible through selected component notation.
2412 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
2413 and then not Comes_From_Source
(E
)
2415 Set_Is_Immediately_Visible
(E
, False);
2417 -- The new entity may be the package renaming, which has the same
2418 -- same name as a generic formal which has been seen already.
2420 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
2421 and then not Comes_From_Source
(Def_Id
)
2423 Set_Is_Immediately_Visible
(E
, False);
2425 -- For a fat pointer corresponding to a remote access to subprogram,
2426 -- we use the same identifier as the RAS type, so that the proper
2427 -- name appears in the stub. This type is only retrieved through
2428 -- the RAS type and never by visibility, and is not added to the
2429 -- visibility list (see below).
2431 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
2432 and then Present
(Corresponding_Remote_Type
(Def_Id
))
2436 -- A controller component for a type extension overrides the
2437 -- inherited component.
2439 elsif Chars
(E
) = Name_uController
then
2442 -- Case of an implicit operation or derived literal. The new entity
2443 -- hides the implicit one, which is removed from all visibility,
2444 -- i.e. the entity list of its scope, and homonym chain of its name.
2446 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
2447 or else Is_Internal
(E
)
2451 Prev_Vis
: Entity_Id
;
2452 Decl
: constant Node_Id
:= Parent
(E
);
2455 -- If E is an implicit declaration, it cannot be the first
2456 -- entity in the scope.
2458 Prev
:= First_Entity
(Current_Scope
);
2459 while Present
(Prev
)
2460 and then Next_Entity
(Prev
) /= E
2467 -- If E is not on the entity chain of the current scope,
2468 -- it is an implicit declaration in the generic formal
2469 -- part of a generic subprogram. When analyzing the body,
2470 -- the generic formals are visible but not on the entity
2471 -- chain of the subprogram. The new entity will become
2472 -- the visible one in the body.
2475 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
2479 Set_Next_Entity
(Prev
, Next_Entity
(E
));
2481 if No
(Next_Entity
(Prev
)) then
2482 Set_Last_Entity
(Current_Scope
, Prev
);
2485 if E
= Current_Entity
(E
) then
2489 Prev_Vis
:= Current_Entity
(E
);
2490 while Homonym
(Prev_Vis
) /= E
loop
2491 Prev_Vis
:= Homonym
(Prev_Vis
);
2495 if Present
(Prev_Vis
) then
2497 -- Skip E in the visibility chain
2499 Set_Homonym
(Prev_Vis
, Homonym
(E
));
2502 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
2507 -- This section of code could use a comment ???
2509 elsif Present
(Etype
(E
))
2510 and then Is_Concurrent_Type
(Etype
(E
))
2515 -- If the homograph is a protected component renaming, it should not
2516 -- be hiding the current entity. Such renamings are treated as weak
2519 elsif Is_Prival
(E
) then
2520 Set_Is_Immediately_Visible
(E
, False);
2522 -- In this case the current entity is a protected component renaming.
2523 -- Perform minimal decoration by setting the scope and return since
2524 -- the prival should not be hiding other visible entities.
2526 elsif Is_Prival
(Def_Id
) then
2527 Set_Scope
(Def_Id
, Current_Scope
);
2530 -- Analogous to privals, the discriminal generated for an entry
2531 -- index parameter acts as a weak declaration. Perform minimal
2532 -- decoration to avoid bogus errors.
2534 elsif Is_Discriminal
(Def_Id
)
2535 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
2537 Set_Scope
(Def_Id
, Current_Scope
);
2540 -- In the body or private part of an instance, a type extension
2541 -- may introduce a component with the same name as that of an
2542 -- actual. The legality rule is not enforced, but the semantics
2543 -- of the full type with two components of the same name are not
2544 -- clear at this point ???
2546 elsif In_Instance_Not_Visible
then
2549 -- When compiling a package body, some child units may have become
2550 -- visible. They cannot conflict with local entities that hide them.
2552 elsif Is_Child_Unit
(E
)
2553 and then In_Open_Scopes
(Scope
(E
))
2554 and then not Is_Immediately_Visible
(E
)
2558 -- Conversely, with front-end inlining we may compile the parent
2559 -- body first, and a child unit subsequently. The context is now
2560 -- the parent spec, and body entities are not visible.
2562 elsif Is_Child_Unit
(Def_Id
)
2563 and then Is_Package_Body_Entity
(E
)
2564 and then not In_Package_Body
(Current_Scope
)
2568 -- Case of genuine duplicate declaration
2571 Error_Msg_Sloc
:= Sloc
(E
);
2573 -- If the previous declaration is an incomplete type declaration
2574 -- this may be an attempt to complete it with a private type.
2575 -- The following avoids confusing cascaded errors.
2577 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
2578 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
2581 ("incomplete type cannot be completed with a private " &
2582 "declaration", Parent
(Def_Id
));
2583 Set_Is_Immediately_Visible
(E
, False);
2584 Set_Full_View
(E
, Def_Id
);
2586 -- An inherited component of a record conflicts with a new
2587 -- discriminant. The discriminant is inserted first in the scope,
2588 -- but the error should be posted on it, not on the component.
2590 elsif Ekind
(E
) = E_Discriminant
2591 and then Present
(Scope
(Def_Id
))
2592 and then Scope
(Def_Id
) /= Current_Scope
2594 Error_Msg_Sloc
:= Sloc
(Def_Id
);
2595 Error_Msg_N
("& conflicts with declaration#", E
);
2598 -- If the name of the unit appears in its own context clause,
2599 -- a dummy package with the name has already been created, and
2600 -- the error emitted. Try to continue quietly.
2602 elsif Error_Posted
(E
)
2603 and then Sloc
(E
) = No_Location
2604 and then Nkind
(Parent
(E
)) = N_Package_Specification
2605 and then Current_Scope
= Standard_Standard
2607 Set_Scope
(Def_Id
, Current_Scope
);
2611 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
2613 -- Avoid cascaded messages with duplicate components in
2616 if Ekind
(E
) = E_Component
2617 or else Ekind
(E
) = E_Discriminant
2623 if Nkind
(Parent
(Parent
(Def_Id
))) =
2624 N_Generic_Subprogram_Declaration
2626 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
2628 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
2631 -- If entity is in standard, then we are in trouble, because
2632 -- it means that we have a library package with a duplicated
2633 -- name. That's hard to recover from, so abort!
2635 if S
= Standard_Standard
then
2636 raise Unrecoverable_Error
;
2638 -- Otherwise we continue with the declaration. Having two
2639 -- identical declarations should not cause us too much trouble!
2647 -- If we fall through, declaration is OK , or OK enough to continue
2649 -- If Def_Id is a discriminant or a record component we are in the
2650 -- midst of inheriting components in a derived record definition.
2651 -- Preserve their Ekind and Etype.
2653 if Ekind
(Def_Id
) = E_Discriminant
2654 or else Ekind
(Def_Id
) = E_Component
2658 -- If a type is already set, leave it alone (happens whey a type
2659 -- declaration is reanalyzed following a call to the optimizer)
2661 elsif Present
(Etype
(Def_Id
)) then
2664 -- Otherwise, the kind E_Void insures that premature uses of the entity
2665 -- will be detected. Any_Type insures that no cascaded errors will occur
2668 Set_Ekind
(Def_Id
, E_Void
);
2669 Set_Etype
(Def_Id
, Any_Type
);
2672 -- Inherited discriminants and components in derived record types are
2673 -- immediately visible. Itypes are not.
2675 if Ekind
(Def_Id
) = E_Discriminant
2676 or else Ekind
(Def_Id
) = E_Component
2677 or else (No
(Corresponding_Remote_Type
(Def_Id
))
2678 and then not Is_Itype
(Def_Id
))
2680 Set_Is_Immediately_Visible
(Def_Id
);
2681 Set_Current_Entity
(Def_Id
);
2684 Set_Homonym
(Def_Id
, C
);
2685 Append_Entity
(Def_Id
, S
);
2686 Set_Public_Status
(Def_Id
);
2688 -- Warn if new entity hides an old one
2690 if Warn_On_Hiding
and then Present
(C
)
2692 -- Don't warn for record components since they always have a well
2693 -- defined scope which does not confuse other uses. Note that in
2694 -- some cases, Ekind has not been set yet.
2696 and then Ekind
(C
) /= E_Component
2697 and then Ekind
(C
) /= E_Discriminant
2698 and then Nkind
(Parent
(C
)) /= N_Component_Declaration
2699 and then Ekind
(Def_Id
) /= E_Component
2700 and then Ekind
(Def_Id
) /= E_Discriminant
2701 and then Nkind
(Parent
(Def_Id
)) /= N_Component_Declaration
2703 -- Don't warn for one character variables. It is too common to use
2704 -- such variables as locals and will just cause too many false hits.
2706 and then Length_Of_Name
(Chars
(C
)) /= 1
2708 -- Don't warn for non-source entities
2710 and then Comes_From_Source
(C
)
2711 and then Comes_From_Source
(Def_Id
)
2713 -- Don't warn unless entity in question is in extended main source
2715 and then In_Extended_Main_Source_Unit
(Def_Id
)
2717 -- Finally, the hidden entity must be either immediately visible
2718 -- or use visible (from a used package)
2721 (Is_Immediately_Visible
(C
)
2723 Is_Potentially_Use_Visible
(C
))
2725 Error_Msg_Sloc
:= Sloc
(C
);
2726 Error_Msg_N
("declaration hides &#?", Def_Id
);
2730 --------------------------
2731 -- Explain_Limited_Type --
2732 --------------------------
2734 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
2738 -- For array, component type must be limited
2740 if Is_Array_Type
(T
) then
2741 Error_Msg_Node_2
:= T
;
2743 ("\component type& of type& is limited", N
, Component_Type
(T
));
2744 Explain_Limited_Type
(Component_Type
(T
), N
);
2746 elsif Is_Record_Type
(T
) then
2748 -- No need for extra messages if explicit limited record
2750 if Is_Limited_Record
(Base_Type
(T
)) then
2754 -- Otherwise find a limited component. Check only components that
2755 -- come from source, or inherited components that appear in the
2756 -- source of the ancestor.
2758 C
:= First_Component
(T
);
2759 while Present
(C
) loop
2760 if Is_Limited_Type
(Etype
(C
))
2762 (Comes_From_Source
(C
)
2764 (Present
(Original_Record_Component
(C
))
2766 Comes_From_Source
(Original_Record_Component
(C
))))
2768 Error_Msg_Node_2
:= T
;
2769 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
2770 Explain_Limited_Type
(Etype
(C
), N
);
2777 -- The type may be declared explicitly limited, even if no component
2778 -- of it is limited, in which case we fall out of the loop.
2781 end Explain_Limited_Type
;
2787 procedure Find_Actual
2789 Formal
: out Entity_Id
;
2792 Parnt
: constant Node_Id
:= Parent
(N
);
2796 if (Nkind
(Parnt
) = N_Indexed_Component
2798 Nkind
(Parnt
) = N_Selected_Component
)
2799 and then N
= Prefix
(Parnt
)
2801 Find_Actual
(Parnt
, Formal
, Call
);
2804 elsif Nkind
(Parnt
) = N_Parameter_Association
2805 and then N
= Explicit_Actual_Parameter
(Parnt
)
2807 Call
:= Parent
(Parnt
);
2809 elsif Nkind
(Parnt
) = N_Procedure_Call_Statement
then
2818 -- If we have a call to a subprogram look for the parameter. Note that
2819 -- we exclude overloaded calls, since we don't know enough to be sure
2820 -- of giving the right answer in this case.
2822 if Is_Entity_Name
(Name
(Call
))
2823 and then Present
(Entity
(Name
(Call
)))
2824 and then Is_Overloadable
(Entity
(Name
(Call
)))
2825 and then not Is_Overloaded
(Name
(Call
))
2827 -- Fall here if we are definitely a parameter
2829 Actual
:= First_Actual
(Call
);
2830 Formal
:= First_Formal
(Entity
(Name
(Call
)));
2831 while Present
(Formal
) and then Present
(Actual
) loop
2835 Actual
:= Next_Actual
(Actual
);
2836 Formal
:= Next_Formal
(Formal
);
2841 -- Fall through here if we did not find matching actual
2847 -------------------------------------
2848 -- Find_Corresponding_Discriminant --
2849 -------------------------------------
2851 function Find_Corresponding_Discriminant
2853 Typ
: Entity_Id
) return Entity_Id
2855 Par_Disc
: Entity_Id
;
2856 Old_Disc
: Entity_Id
;
2857 New_Disc
: Entity_Id
;
2860 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
2862 -- The original type may currently be private, and the discriminant
2863 -- only appear on its full view.
2865 if Is_Private_Type
(Scope
(Par_Disc
))
2866 and then not Has_Discriminants
(Scope
(Par_Disc
))
2867 and then Present
(Full_View
(Scope
(Par_Disc
)))
2869 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
2871 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
2874 if Is_Class_Wide_Type
(Typ
) then
2875 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
2877 New_Disc
:= First_Discriminant
(Typ
);
2880 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
2881 if Old_Disc
= Par_Disc
then
2884 Next_Discriminant
(Old_Disc
);
2885 Next_Discriminant
(New_Disc
);
2889 -- Should always find it
2891 raise Program_Error
;
2892 end Find_Corresponding_Discriminant
;
2894 --------------------------
2895 -- Find_Overlaid_Entity --
2896 --------------------------
2898 procedure Find_Overlaid_Entity
2900 Ent
: out Entity_Id
;
2906 -- We are looking for one of the two following forms:
2908 -- for X'Address use Y'Address
2912 -- Const : constant Address := expr;
2914 -- for X'Address use Const;
2916 -- In the second case, the expr is either Y'Address, or recursively a
2917 -- constant that eventually references Y'Address.
2922 if Nkind
(N
) = N_Attribute_Definition_Clause
2923 and then Chars
(N
) = Name_Address
2925 Expr
:= Expression
(N
);
2927 -- This loop checks the form of the expression for Y'Address,
2928 -- using recursion to deal with intermediate constants.
2931 -- Check for Y'Address
2933 if Nkind
(Expr
) = N_Attribute_Reference
2934 and then Attribute_Name
(Expr
) = Name_Address
2936 Expr
:= Prefix
(Expr
);
2939 -- Check for Const where Const is a constant entity
2941 elsif Is_Entity_Name
(Expr
)
2942 and then Ekind
(Entity
(Expr
)) = E_Constant
2944 Expr
:= Constant_Value
(Entity
(Expr
));
2946 -- Anything else does not need checking
2953 -- This loop checks the form of the prefix for an entity,
2954 -- using recursion to deal with intermediate components.
2957 -- Check for Y where Y is an entity
2959 if Is_Entity_Name
(Expr
) then
2960 Ent
:= Entity
(Expr
);
2963 -- Check for components
2966 Nkind_In
(Expr
, N_Selected_Component
, N_Indexed_Component
) then
2968 Expr
:= Prefix
(Expr
);
2971 -- Anything else does not need checking
2978 end Find_Overlaid_Entity
;
2980 -------------------------
2981 -- Find_Parameter_Type --
2982 -------------------------
2984 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
2986 if Nkind
(Param
) /= N_Parameter_Specification
then
2989 -- For an access parameter, obtain the type from the formal entity
2990 -- itself, because access to subprogram nodes do not carry a type.
2991 -- Shouldn't we always use the formal entity ???
2993 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
2994 return Etype
(Defining_Identifier
(Param
));
2997 return Etype
(Parameter_Type
(Param
));
2999 end Find_Parameter_Type
;
3001 -----------------------------
3002 -- Find_Static_Alternative --
3003 -----------------------------
3005 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
3006 Expr
: constant Node_Id
:= Expression
(N
);
3007 Val
: constant Uint
:= Expr_Value
(Expr
);
3012 Alt
:= First
(Alternatives
(N
));
3015 if Nkind
(Alt
) /= N_Pragma
then
3016 Choice
:= First
(Discrete_Choices
(Alt
));
3017 while Present
(Choice
) loop
3019 -- Others choice, always matches
3021 if Nkind
(Choice
) = N_Others_Choice
then
3024 -- Range, check if value is in the range
3026 elsif Nkind
(Choice
) = N_Range
then
3028 Val
>= Expr_Value
(Low_Bound
(Choice
))
3030 Val
<= Expr_Value
(High_Bound
(Choice
));
3032 -- Choice is a subtype name. Note that we know it must
3033 -- be a static subtype, since otherwise it would have
3034 -- been diagnosed as illegal.
3036 elsif Is_Entity_Name
(Choice
)
3037 and then Is_Type
(Entity
(Choice
))
3039 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
3040 Assume_Valid
=> False);
3042 -- Choice is a subtype indication
3044 elsif Nkind
(Choice
) = N_Subtype_Indication
then
3046 C
: constant Node_Id
:= Constraint
(Choice
);
3047 R
: constant Node_Id
:= Range_Expression
(C
);
3051 Val
>= Expr_Value
(Low_Bound
(R
))
3053 Val
<= Expr_Value
(High_Bound
(R
));
3056 -- Choice is a simple expression
3059 exit Search
when Val
= Expr_Value
(Choice
);
3067 pragma Assert
(Present
(Alt
));
3070 -- The above loop *must* terminate by finding a match, since
3071 -- we know the case statement is valid, and the value of the
3072 -- expression is known at compile time. When we fall out of
3073 -- the loop, Alt points to the alternative that we know will
3074 -- be selected at run time.
3077 end Find_Static_Alternative
;
3083 function First_Actual
(Node
: Node_Id
) return Node_Id
is
3087 if No
(Parameter_Associations
(Node
)) then
3091 N
:= First
(Parameter_Associations
(Node
));
3093 if Nkind
(N
) = N_Parameter_Association
then
3094 return First_Named_Actual
(Node
);
3100 -------------------------
3101 -- Full_Qualified_Name --
3102 -------------------------
3104 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
3106 pragma Warnings
(Off
, Res
);
3108 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
3109 -- Compute recursively the qualified name without NUL at the end
3111 ----------------------------------
3112 -- Internal_Full_Qualified_Name --
3113 ----------------------------------
3115 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
3116 Ent
: Entity_Id
:= E
;
3117 Parent_Name
: String_Id
:= No_String
;
3120 -- Deals properly with child units
3122 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
3123 Ent
:= Defining_Identifier
(Ent
);
3126 -- Compute qualification recursively (only "Standard" has no scope)
3128 if Present
(Scope
(Scope
(Ent
))) then
3129 Parent_Name
:= Internal_Full_Qualified_Name
(Scope
(Ent
));
3132 -- Every entity should have a name except some expanded blocks
3133 -- don't bother about those.
3135 if Chars
(Ent
) = No_Name
then
3139 -- Add a period between Name and qualification
3141 if Parent_Name
/= No_String
then
3142 Start_String
(Parent_Name
);
3143 Store_String_Char
(Get_Char_Code
('.'));
3149 -- Generates the entity name in upper case
3151 Get_Decoded_Name_String
(Chars
(Ent
));
3153 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
3155 end Internal_Full_Qualified_Name
;
3157 -- Start of processing for Full_Qualified_Name
3160 Res
:= Internal_Full_Qualified_Name
(E
);
3161 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
3163 end Full_Qualified_Name
;
3165 -----------------------
3166 -- Gather_Components --
3167 -----------------------
3169 procedure Gather_Components
3171 Comp_List
: Node_Id
;
3172 Governed_By
: List_Id
;
3174 Report_Errors
: out Boolean)
3178 Discrete_Choice
: Node_Id
;
3179 Comp_Item
: Node_Id
;
3181 Discrim
: Entity_Id
;
3182 Discrim_Name
: Node_Id
;
3183 Discrim_Value
: Node_Id
;
3186 Report_Errors
:= False;
3188 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
3191 elsif Present
(Component_Items
(Comp_List
)) then
3192 Comp_Item
:= First
(Component_Items
(Comp_List
));
3198 while Present
(Comp_Item
) loop
3200 -- Skip the tag of a tagged record, the interface tags, as well
3201 -- as all items that are not user components (anonymous types,
3202 -- rep clauses, Parent field, controller field).
3204 if Nkind
(Comp_Item
) = N_Component_Declaration
then
3206 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
3208 if not Is_Tag
(Comp
)
3209 and then Chars
(Comp
) /= Name_uParent
3210 and then Chars
(Comp
) /= Name_uController
3212 Append_Elmt
(Comp
, Into
);
3220 if No
(Variant_Part
(Comp_List
)) then
3223 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
3224 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
3227 -- Look for the discriminant that governs this variant part.
3228 -- The discriminant *must* be in the Governed_By List
3230 Assoc
:= First
(Governed_By
);
3231 Find_Constraint
: loop
3232 Discrim
:= First
(Choices
(Assoc
));
3233 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
3234 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
3236 Chars
(Corresponding_Discriminant
(Entity
(Discrim
)))
3237 = Chars
(Discrim_Name
))
3238 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
3239 = Chars
(Discrim_Name
);
3241 if No
(Next
(Assoc
)) then
3242 if not Is_Constrained
(Typ
)
3243 and then Is_Derived_Type
(Typ
)
3244 and then Present
(Stored_Constraint
(Typ
))
3246 -- If the type is a tagged type with inherited discriminants,
3247 -- use the stored constraint on the parent in order to find
3248 -- the values of discriminants that are otherwise hidden by an
3249 -- explicit constraint. Renamed discriminants are handled in
3252 -- If several parent discriminants are renamed by a single
3253 -- discriminant of the derived type, the call to obtain the
3254 -- Corresponding_Discriminant field only retrieves the last
3255 -- of them. We recover the constraint on the others from the
3256 -- Stored_Constraint as well.
3263 D
:= First_Discriminant
(Etype
(Typ
));
3264 C
:= First_Elmt
(Stored_Constraint
(Typ
));
3265 while Present
(D
) and then Present
(C
) loop
3266 if Chars
(Discrim_Name
) = Chars
(D
) then
3267 if Is_Entity_Name
(Node
(C
))
3268 and then Entity
(Node
(C
)) = Entity
(Discrim
)
3270 -- D is renamed by Discrim, whose value is given in
3277 Make_Component_Association
(Sloc
(Typ
),
3279 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
3280 Duplicate_Subexpr_No_Checks
(Node
(C
)));
3282 exit Find_Constraint
;
3285 Next_Discriminant
(D
);
3292 if No
(Next
(Assoc
)) then
3293 Error_Msg_NE
(" missing value for discriminant&",
3294 First
(Governed_By
), Discrim_Name
);
3295 Report_Errors
:= True;
3300 end loop Find_Constraint
;
3302 Discrim_Value
:= Expression
(Assoc
);
3304 if not Is_OK_Static_Expression
(Discrim_Value
) then
3306 ("value for discriminant & must be static!",
3307 Discrim_Value
, Discrim
);
3308 Why_Not_Static
(Discrim_Value
);
3309 Report_Errors
:= True;
3313 Search_For_Discriminant_Value
: declare
3319 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
3322 Find_Discrete_Value
: while Present
(Variant
) loop
3323 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
3324 while Present
(Discrete_Choice
) loop
3326 exit Find_Discrete_Value
when
3327 Nkind
(Discrete_Choice
) = N_Others_Choice
;
3329 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
3331 UI_Low
:= Expr_Value
(Low
);
3332 UI_High
:= Expr_Value
(High
);
3334 exit Find_Discrete_Value
when
3335 UI_Low
<= UI_Discrim_Value
3337 UI_High
>= UI_Discrim_Value
;
3339 Next
(Discrete_Choice
);
3342 Next_Non_Pragma
(Variant
);
3343 end loop Find_Discrete_Value
;
3344 end Search_For_Discriminant_Value
;
3346 if No
(Variant
) then
3348 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
3349 Report_Errors
:= True;
3353 -- If we have found the corresponding choice, recursively add its
3354 -- components to the Into list.
3356 Gather_Components
(Empty
,
3357 Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
3358 end Gather_Components
;
3360 ------------------------
3361 -- Get_Actual_Subtype --
3362 ------------------------
3364 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
3365 Typ
: constant Entity_Id
:= Etype
(N
);
3366 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
3375 -- If what we have is an identifier that references a subprogram
3376 -- formal, or a variable or constant object, then we get the actual
3377 -- subtype from the referenced entity if one has been built.
3379 if Nkind
(N
) = N_Identifier
3381 (Is_Formal
(Entity
(N
))
3382 or else Ekind
(Entity
(N
)) = E_Constant
3383 or else Ekind
(Entity
(N
)) = E_Variable
)
3384 and then Present
(Actual_Subtype
(Entity
(N
)))
3386 return Actual_Subtype
(Entity
(N
));
3388 -- Actual subtype of unchecked union is always itself. We never need
3389 -- the "real" actual subtype. If we did, we couldn't get it anyway
3390 -- because the discriminant is not available. The restrictions on
3391 -- Unchecked_Union are designed to make sure that this is OK.
3393 elsif Is_Unchecked_Union
(Base_Type
(Utyp
)) then
3396 -- Here for the unconstrained case, we must find actual subtype
3397 -- No actual subtype is available, so we must build it on the fly.
3399 -- Checking the type, not the underlying type, for constrainedness
3400 -- seems to be necessary. Maybe all the tests should be on the type???
3402 elsif (not Is_Constrained
(Typ
))
3403 and then (Is_Array_Type
(Utyp
)
3404 or else (Is_Record_Type
(Utyp
)
3405 and then Has_Discriminants
(Utyp
)))
3406 and then not Has_Unknown_Discriminants
(Utyp
)
3407 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
3409 -- Nothing to do if in spec expression (why not???)
3411 if In_Spec_Expression
then
3414 elsif Is_Private_Type
(Typ
)
3415 and then not Has_Discriminants
(Typ
)
3417 -- If the type has no discriminants, there is no subtype to
3418 -- build, even if the underlying type is discriminated.
3422 -- Else build the actual subtype
3425 Decl
:= Build_Actual_Subtype
(Typ
, N
);
3426 Atyp
:= Defining_Identifier
(Decl
);
3428 -- If Build_Actual_Subtype generated a new declaration then use it
3432 -- The actual subtype is an Itype, so analyze the declaration,
3433 -- but do not attach it to the tree, to get the type defined.
3435 Set_Parent
(Decl
, N
);
3436 Set_Is_Itype
(Atyp
);
3437 Analyze
(Decl
, Suppress
=> All_Checks
);
3438 Set_Associated_Node_For_Itype
(Atyp
, N
);
3439 Set_Has_Delayed_Freeze
(Atyp
, False);
3441 -- We need to freeze the actual subtype immediately. This is
3442 -- needed, because otherwise this Itype will not get frozen
3443 -- at all, and it is always safe to freeze on creation because
3444 -- any associated types must be frozen at this point.
3446 Freeze_Itype
(Atyp
, N
);
3449 -- Otherwise we did not build a declaration, so return original
3456 -- For all remaining cases, the actual subtype is the same as
3457 -- the nominal type.
3462 end Get_Actual_Subtype
;
3464 -------------------------------------
3465 -- Get_Actual_Subtype_If_Available --
3466 -------------------------------------
3468 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
3469 Typ
: constant Entity_Id
:= Etype
(N
);
3472 -- If what we have is an identifier that references a subprogram
3473 -- formal, or a variable or constant object, then we get the actual
3474 -- subtype from the referenced entity if one has been built.
3476 if Nkind
(N
) = N_Identifier
3478 (Is_Formal
(Entity
(N
))
3479 or else Ekind
(Entity
(N
)) = E_Constant
3480 or else Ekind
(Entity
(N
)) = E_Variable
)
3481 and then Present
(Actual_Subtype
(Entity
(N
)))
3483 return Actual_Subtype
(Entity
(N
));
3485 -- Otherwise the Etype of N is returned unchanged
3490 end Get_Actual_Subtype_If_Available
;
3492 -------------------------------
3493 -- Get_Default_External_Name --
3494 -------------------------------
3496 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
3498 Get_Decoded_Name_String
(Chars
(E
));
3500 if Opt
.External_Name_Imp_Casing
= Uppercase
then
3501 Set_Casing
(All_Upper_Case
);
3503 Set_Casing
(All_Lower_Case
);
3507 Make_String_Literal
(Sloc
(E
),
3508 Strval
=> String_From_Name_Buffer
);
3509 end Get_Default_External_Name
;
3511 ---------------------------
3512 -- Get_Enum_Lit_From_Pos --
3513 ---------------------------
3515 function Get_Enum_Lit_From_Pos
3518 Loc
: Source_Ptr
) return Node_Id
3523 -- In the case where the literal is of type Character, Wide_Character
3524 -- or Wide_Wide_Character or of a type derived from them, there needs
3525 -- to be some special handling since there is no explicit chain of
3526 -- literals to search. Instead, an N_Character_Literal node is created
3527 -- with the appropriate Char_Code and Chars fields.
3529 if Is_Standard_Character_Type
(T
) then
3530 Set_Character_Literal_Name
(UI_To_CC
(Pos
));
3532 Make_Character_Literal
(Loc
,
3534 Char_Literal_Value
=> Pos
);
3536 -- For all other cases, we have a complete table of literals, and
3537 -- we simply iterate through the chain of literal until the one
3538 -- with the desired position value is found.
3542 Lit
:= First_Literal
(Base_Type
(T
));
3543 for J
in 1 .. UI_To_Int
(Pos
) loop
3547 return New_Occurrence_Of
(Lit
, Loc
);
3549 end Get_Enum_Lit_From_Pos
;
3551 ------------------------
3552 -- Get_Generic_Entity --
3553 ------------------------
3555 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
3556 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
3558 if Present
(Renamed_Object
(Ent
)) then
3559 return Renamed_Object
(Ent
);
3563 end Get_Generic_Entity
;
3565 ----------------------
3566 -- Get_Index_Bounds --
3567 ----------------------
3569 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
3570 Kind
: constant Node_Kind
:= Nkind
(N
);
3574 if Kind
= N_Range
then
3576 H
:= High_Bound
(N
);
3578 elsif Kind
= N_Subtype_Indication
then
3579 R
:= Range_Expression
(Constraint
(N
));
3587 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
3588 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
3591 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
3592 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
3596 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
3597 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
3600 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
3601 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
3605 -- N is an expression, indicating a range with one value
3610 end Get_Index_Bounds
;
3612 ----------------------------------
3613 -- Get_Library_Unit_Name_string --
3614 ----------------------------------
3616 procedure Get_Library_Unit_Name_String
(Decl_Node
: Node_Id
) is
3617 Unit_Name_Id
: constant Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
3620 Get_Unit_Name_String
(Unit_Name_Id
);
3622 -- Remove seven last character (" (spec)" or " (body)")
3624 Name_Len
:= Name_Len
- 7;
3625 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
3626 end Get_Library_Unit_Name_String
;
3628 ------------------------
3629 -- Get_Name_Entity_Id --
3630 ------------------------
3632 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
3634 return Entity_Id
(Get_Name_Table_Info
(Id
));
3635 end Get_Name_Entity_Id
;
3641 function Get_Pragma_Id
(N
: Node_Id
) return Pragma_Id
is
3643 return Get_Pragma_Id
(Pragma_Name
(N
));
3646 ---------------------------
3647 -- Get_Referenced_Object --
3648 ---------------------------
3650 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
3655 while Is_Entity_Name
(R
)
3656 and then Present
(Renamed_Object
(Entity
(R
)))
3658 R
:= Renamed_Object
(Entity
(R
));
3662 end Get_Referenced_Object
;
3664 ------------------------
3665 -- Get_Renamed_Entity --
3666 ------------------------
3668 function Get_Renamed_Entity
(E
: Entity_Id
) return Entity_Id
is
3673 while Present
(Renamed_Entity
(R
)) loop
3674 R
:= Renamed_Entity
(R
);
3678 end Get_Renamed_Entity
;
3680 -------------------------
3681 -- Get_Subprogram_Body --
3682 -------------------------
3684 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
3688 Decl
:= Unit_Declaration_Node
(E
);
3690 if Nkind
(Decl
) = N_Subprogram_Body
then
3693 -- The below comment is bad, because it is possible for
3694 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
3696 else -- Nkind (Decl) = N_Subprogram_Declaration
3698 if Present
(Corresponding_Body
(Decl
)) then
3699 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
3701 -- Imported subprogram case
3707 end Get_Subprogram_Body
;
3709 ---------------------------
3710 -- Get_Subprogram_Entity --
3711 ---------------------------
3713 function Get_Subprogram_Entity
(Nod
: Node_Id
) return Entity_Id
is
3718 if Nkind
(Nod
) = N_Accept_Statement
then
3719 Nam
:= Entry_Direct_Name
(Nod
);
3721 -- For an entry call, the prefix of the call is a selected component.
3722 -- Need additional code for internal calls ???
3724 elsif Nkind
(Nod
) = N_Entry_Call_Statement
then
3725 if Nkind
(Name
(Nod
)) = N_Selected_Component
then
3726 Nam
:= Entity
(Selector_Name
(Name
(Nod
)));
3735 if Nkind
(Nam
) = N_Explicit_Dereference
then
3736 Proc
:= Etype
(Prefix
(Nam
));
3737 elsif Is_Entity_Name
(Nam
) then
3738 Proc
:= Entity
(Nam
);
3743 if Is_Object
(Proc
) then
3744 Proc
:= Etype
(Proc
);
3747 if Ekind
(Proc
) = E_Access_Subprogram_Type
then
3748 Proc
:= Directly_Designated_Type
(Proc
);
3751 if not Is_Subprogram
(Proc
)
3752 and then Ekind
(Proc
) /= E_Subprogram_Type
3758 end Get_Subprogram_Entity
;
3760 -----------------------------
3761 -- Get_Task_Body_Procedure --
3762 -----------------------------
3764 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
3766 -- Note: A task type may be the completion of a private type with
3767 -- discriminants. When performing elaboration checks on a task
3768 -- declaration, the current view of the type may be the private one,
3769 -- and the procedure that holds the body of the task is held in its
3772 -- This is an odd function, why not have Task_Body_Procedure do
3773 -- the following digging???
3775 return Task_Body_Procedure
(Underlying_Type
(Root_Type
(E
)));
3776 end Get_Task_Body_Procedure
;
3778 -----------------------
3779 -- Has_Access_Values --
3780 -----------------------
3782 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
3783 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
3786 -- Case of a private type which is not completed yet. This can only
3787 -- happen in the case of a generic format type appearing directly, or
3788 -- as a component of the type to which this function is being applied
3789 -- at the top level. Return False in this case, since we certainly do
3790 -- not know that the type contains access types.
3795 elsif Is_Access_Type
(Typ
) then
3798 elsif Is_Array_Type
(Typ
) then
3799 return Has_Access_Values
(Component_Type
(Typ
));
3801 elsif Is_Record_Type
(Typ
) then
3806 -- Loop to Check components
3808 Comp
:= First_Component_Or_Discriminant
(Typ
);
3809 while Present
(Comp
) loop
3811 -- Check for access component, tag field does not count, even
3812 -- though it is implemented internally using an access type.
3814 if Has_Access_Values
(Etype
(Comp
))
3815 and then Chars
(Comp
) /= Name_uTag
3820 Next_Component_Or_Discriminant
(Comp
);
3829 end Has_Access_Values
;
3831 ------------------------------
3832 -- Has_Compatible_Alignment --
3833 ------------------------------
3835 function Has_Compatible_Alignment
3837 Expr
: Node_Id
) return Alignment_Result
3839 function Has_Compatible_Alignment_Internal
3842 Default
: Alignment_Result
) return Alignment_Result
;
3843 -- This is the internal recursive function that actually does the work.
3844 -- There is one additional parameter, which says what the result should
3845 -- be if no alignment information is found, and there is no definite
3846 -- indication of compatible alignments. At the outer level, this is set
3847 -- to Unknown, but for internal recursive calls in the case where types
3848 -- are known to be correct, it is set to Known_Compatible.
3850 ---------------------------------------
3851 -- Has_Compatible_Alignment_Internal --
3852 ---------------------------------------
3854 function Has_Compatible_Alignment_Internal
3857 Default
: Alignment_Result
) return Alignment_Result
3859 Result
: Alignment_Result
:= Known_Compatible
;
3860 -- Holds the current status of the result. Note that once a value of
3861 -- Known_Incompatible is set, it is sticky and does not get changed
3862 -- to Unknown (the value in Result only gets worse as we go along,
3865 Offs
: Uint
:= No_Uint
;
3866 -- Set to a factor of the offset from the base object when Expr is a
3867 -- selected or indexed component, based on Component_Bit_Offset and
3868 -- Component_Size respectively. A negative value is used to represent
3869 -- a value which is not known at compile time.
3871 procedure Check_Prefix
;
3872 -- Checks the prefix recursively in the case where the expression
3873 -- is an indexed or selected component.
3875 procedure Set_Result
(R
: Alignment_Result
);
3876 -- If R represents a worse outcome (unknown instead of known
3877 -- compatible, or known incompatible), then set Result to R.
3883 procedure Check_Prefix
is
3885 -- The subtlety here is that in doing a recursive call to check
3886 -- the prefix, we have to decide what to do in the case where we
3887 -- don't find any specific indication of an alignment problem.
3889 -- At the outer level, we normally set Unknown as the result in
3890 -- this case, since we can only set Known_Compatible if we really
3891 -- know that the alignment value is OK, but for the recursive
3892 -- call, in the case where the types match, and we have not
3893 -- specified a peculiar alignment for the object, we are only
3894 -- concerned about suspicious rep clauses, the default case does
3895 -- not affect us, since the compiler will, in the absence of such
3896 -- rep clauses, ensure that the alignment is correct.
3898 if Default
= Known_Compatible
3900 (Etype
(Obj
) = Etype
(Expr
)
3901 and then (Unknown_Alignment
(Obj
)
3903 Alignment
(Obj
) = Alignment
(Etype
(Obj
))))
3906 (Has_Compatible_Alignment_Internal
3907 (Obj
, Prefix
(Expr
), Known_Compatible
));
3909 -- In all other cases, we need a full check on the prefix
3913 (Has_Compatible_Alignment_Internal
3914 (Obj
, Prefix
(Expr
), Unknown
));
3922 procedure Set_Result
(R
: Alignment_Result
) is
3929 -- Start of processing for Has_Compatible_Alignment_Internal
3932 -- If Expr is a selected component, we must make sure there is no
3933 -- potentially troublesome component clause, and that the record is
3936 if Nkind
(Expr
) = N_Selected_Component
then
3938 -- Packed record always generate unknown alignment
3940 if Is_Packed
(Etype
(Prefix
(Expr
))) then
3941 Set_Result
(Unknown
);
3944 -- Check prefix and component offset
3947 Offs
:= Component_Bit_Offset
(Entity
(Selector_Name
(Expr
)));
3949 -- If Expr is an indexed component, we must make sure there is no
3950 -- potentially troublesome Component_Size clause and that the array
3951 -- is not bit-packed.
3953 elsif Nkind
(Expr
) = N_Indexed_Component
then
3955 Typ
: constant Entity_Id
:= Etype
(Prefix
(Expr
));
3956 Ind
: constant Node_Id
:= First_Index
(Typ
);
3959 -- Bit packed array always generates unknown alignment
3961 if Is_Bit_Packed_Array
(Typ
) then
3962 Set_Result
(Unknown
);
3965 -- Check prefix and component offset
3968 Offs
:= Component_Size
(Typ
);
3970 -- Small optimization: compute the full offset when possible
3973 and then Offs
> Uint_0
3974 and then Present
(Ind
)
3975 and then Nkind
(Ind
) = N_Range
3976 and then Compile_Time_Known_Value
(Low_Bound
(Ind
))
3977 and then Compile_Time_Known_Value
(First
(Expressions
(Expr
)))
3979 Offs
:= Offs
* (Expr_Value
(First
(Expressions
(Expr
)))
3980 - Expr_Value
(Low_Bound
((Ind
))));
3985 -- If we have a null offset, the result is entirely determined by
3986 -- the base object and has already been computed recursively.
3988 if Offs
= Uint_0
then
3991 -- Case where we know the alignment of the object
3993 elsif Known_Alignment
(Obj
) then
3995 ObjA
: constant Uint
:= Alignment
(Obj
);
3996 ExpA
: Uint
:= No_Uint
;
3997 SizA
: Uint
:= No_Uint
;
4000 -- If alignment of Obj is 1, then we are always OK
4003 Set_Result
(Known_Compatible
);
4005 -- Alignment of Obj is greater than 1, so we need to check
4008 -- If we have an offset, see if it is compatible
4010 if Offs
/= No_Uint
and Offs
> Uint_0
then
4011 if Offs
mod (System_Storage_Unit
* ObjA
) /= 0 then
4012 Set_Result
(Known_Incompatible
);
4015 -- See if Expr is an object with known alignment
4017 elsif Is_Entity_Name
(Expr
)
4018 and then Known_Alignment
(Entity
(Expr
))
4020 ExpA
:= Alignment
(Entity
(Expr
));
4022 -- Otherwise, we can use the alignment of the type of
4023 -- Expr given that we already checked for
4024 -- discombobulating rep clauses for the cases of indexed
4025 -- and selected components above.
4027 elsif Known_Alignment
(Etype
(Expr
)) then
4028 ExpA
:= Alignment
(Etype
(Expr
));
4030 -- Otherwise the alignment is unknown
4033 Set_Result
(Default
);
4036 -- If we got an alignment, see if it is acceptable
4038 if ExpA
/= No_Uint
and then ExpA
< ObjA
then
4039 Set_Result
(Known_Incompatible
);
4042 -- If Expr is not a piece of a larger object, see if size
4043 -- is given. If so, check that it is not too small for the
4044 -- required alignment.
4046 if Offs
/= No_Uint
then
4049 -- See if Expr is an object with known size
4051 elsif Is_Entity_Name
(Expr
)
4052 and then Known_Static_Esize
(Entity
(Expr
))
4054 SizA
:= Esize
(Entity
(Expr
));
4056 -- Otherwise, we check the object size of the Expr type
4058 elsif Known_Static_Esize
(Etype
(Expr
)) then
4059 SizA
:= Esize
(Etype
(Expr
));
4062 -- If we got a size, see if it is a multiple of the Obj
4063 -- alignment, if not, then the alignment cannot be
4064 -- acceptable, since the size is always a multiple of the
4067 if SizA
/= No_Uint
then
4068 if SizA
mod (ObjA
* Ttypes
.System_Storage_Unit
) /= 0 then
4069 Set_Result
(Known_Incompatible
);
4075 -- If we do not know required alignment, any non-zero offset is a
4076 -- potential problem (but certainly may be OK, so result is unknown).
4078 elsif Offs
/= No_Uint
then
4079 Set_Result
(Unknown
);
4081 -- If we can't find the result by direct comparison of alignment
4082 -- values, then there is still one case that we can determine known
4083 -- result, and that is when we can determine that the types are the
4084 -- same, and no alignments are specified. Then we known that the
4085 -- alignments are compatible, even if we don't know the alignment
4086 -- value in the front end.
4088 elsif Etype
(Obj
) = Etype
(Expr
) then
4090 -- Types are the same, but we have to check for possible size
4091 -- and alignments on the Expr object that may make the alignment
4092 -- different, even though the types are the same.
4094 if Is_Entity_Name
(Expr
) then
4096 -- First check alignment of the Expr object. Any alignment less
4097 -- than Maximum_Alignment is worrisome since this is the case
4098 -- where we do not know the alignment of Obj.
4100 if Known_Alignment
(Entity
(Expr
))
4102 UI_To_Int
(Alignment
(Entity
(Expr
))) <
4103 Ttypes
.Maximum_Alignment
4105 Set_Result
(Unknown
);
4107 -- Now check size of Expr object. Any size that is not an
4108 -- even multiple of Maximum_Alignment is also worrisome
4109 -- since it may cause the alignment of the object to be less
4110 -- than the alignment of the type.
4112 elsif Known_Static_Esize
(Entity
(Expr
))
4114 (UI_To_Int
(Esize
(Entity
(Expr
))) mod
4115 (Ttypes
.Maximum_Alignment
* Ttypes
.System_Storage_Unit
))
4118 Set_Result
(Unknown
);
4120 -- Otherwise same type is decisive
4123 Set_Result
(Known_Compatible
);
4127 -- Another case to deal with is when there is an explicit size or
4128 -- alignment clause when the types are not the same. If so, then the
4129 -- result is Unknown. We don't need to do this test if the Default is
4130 -- Unknown, since that result will be set in any case.
4132 elsif Default
/= Unknown
4133 and then (Has_Size_Clause
(Etype
(Expr
))
4135 Has_Alignment_Clause
(Etype
(Expr
)))
4137 Set_Result
(Unknown
);
4139 -- If no indication found, set default
4142 Set_Result
(Default
);
4145 -- Return worst result found
4148 end Has_Compatible_Alignment_Internal
;
4150 -- Start of processing for Has_Compatible_Alignment
4153 -- If Obj has no specified alignment, then set alignment from the type
4154 -- alignment. Perhaps we should always do this, but for sure we should
4155 -- do it when there is an address clause since we can do more if the
4156 -- alignment is known.
4158 if Unknown_Alignment
(Obj
) then
4159 Set_Alignment
(Obj
, Alignment
(Etype
(Obj
)));
4162 -- Now do the internal call that does all the work
4164 return Has_Compatible_Alignment_Internal
(Obj
, Expr
, Unknown
);
4165 end Has_Compatible_Alignment
;
4167 ----------------------
4168 -- Has_Declarations --
4169 ----------------------
4171 function Has_Declarations
(N
: Node_Id
) return Boolean is
4173 return Nkind_In
(Nkind
(N
), N_Accept_Statement
,
4175 N_Compilation_Unit_Aux
,
4181 N_Package_Specification
);
4182 end Has_Declarations
;
4184 -------------------------------------------
4185 -- Has_Discriminant_Dependent_Constraint --
4186 -------------------------------------------
4188 function Has_Discriminant_Dependent_Constraint
4189 (Comp
: Entity_Id
) return Boolean
4191 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
4192 Subt_Indic
: constant Node_Id
:=
4193 Subtype_Indication
(Component_Definition
(Comp_Decl
));
4198 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
4199 Constr
:= Constraint
(Subt_Indic
);
4201 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
4202 Assn
:= First
(Constraints
(Constr
));
4203 while Present
(Assn
) loop
4204 case Nkind
(Assn
) is
4205 when N_Subtype_Indication |
4209 if Depends_On_Discriminant
(Assn
) then
4213 when N_Discriminant_Association
=>
4214 if Depends_On_Discriminant
(Expression
(Assn
)) then
4229 end Has_Discriminant_Dependent_Constraint
;
4231 --------------------
4232 -- Has_Infinities --
4233 --------------------
4235 function Has_Infinities
(E
: Entity_Id
) return Boolean is
4238 Is_Floating_Point_Type
(E
)
4239 and then Nkind
(Scalar_Range
(E
)) = N_Range
4240 and then Includes_Infinities
(Scalar_Range
(E
));
4243 --------------------
4244 -- Has_Interfaces --
4245 --------------------
4247 function Has_Interfaces
4249 Use_Full_View
: Boolean := True) return Boolean
4254 -- Handle concurrent types
4256 if Is_Concurrent_Type
(T
) then
4257 Typ
:= Corresponding_Record_Type
(T
);
4262 if not Present
(Typ
)
4263 or else not Is_Record_Type
(Typ
)
4264 or else not Is_Tagged_Type
(Typ
)
4269 -- Handle private types
4272 and then Present
(Full_View
(Typ
))
4274 Typ
:= Full_View
(Typ
);
4277 -- Handle concurrent record types
4279 if Is_Concurrent_Record_Type
(Typ
)
4280 and then Is_Non_Empty_List
(Abstract_Interface_List
(Typ
))
4286 if Is_Interface
(Typ
)
4288 (Is_Record_Type
(Typ
)
4289 and then Present
(Interfaces
(Typ
))
4290 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
)))
4295 exit when Etype
(Typ
) = Typ
4297 -- Handle private types
4299 or else (Present
(Full_View
(Etype
(Typ
)))
4300 and then Full_View
(Etype
(Typ
)) = Typ
)
4302 -- Protect the frontend against wrong source with cyclic
4305 or else Etype
(Typ
) = T
;
4307 -- Climb to the ancestor type handling private types
4309 if Present
(Full_View
(Etype
(Typ
))) then
4310 Typ
:= Full_View
(Etype
(Typ
));
4319 ------------------------
4320 -- Has_Null_Exclusion --
4321 ------------------------
4323 function Has_Null_Exclusion
(N
: Node_Id
) return Boolean is
4326 when N_Access_Definition |
4327 N_Access_Function_Definition |
4328 N_Access_Procedure_Definition |
4329 N_Access_To_Object_Definition |
4331 N_Derived_Type_Definition |
4332 N_Function_Specification |
4333 N_Subtype_Declaration
=>
4334 return Null_Exclusion_Present
(N
);
4336 when N_Component_Definition |
4337 N_Formal_Object_Declaration |
4338 N_Object_Renaming_Declaration
=>
4339 if Present
(Subtype_Mark
(N
)) then
4340 return Null_Exclusion_Present
(N
);
4341 else pragma Assert
(Present
(Access_Definition
(N
)));
4342 return Null_Exclusion_Present
(Access_Definition
(N
));
4345 when N_Discriminant_Specification
=>
4346 if Nkind
(Discriminant_Type
(N
)) = N_Access_Definition
then
4347 return Null_Exclusion_Present
(Discriminant_Type
(N
));
4349 return Null_Exclusion_Present
(N
);
4352 when N_Object_Declaration
=>
4353 if Nkind
(Object_Definition
(N
)) = N_Access_Definition
then
4354 return Null_Exclusion_Present
(Object_Definition
(N
));
4356 return Null_Exclusion_Present
(N
);
4359 when N_Parameter_Specification
=>
4360 if Nkind
(Parameter_Type
(N
)) = N_Access_Definition
then
4361 return Null_Exclusion_Present
(Parameter_Type
(N
));
4363 return Null_Exclusion_Present
(N
);
4370 end Has_Null_Exclusion
;
4372 ------------------------
4373 -- Has_Null_Extension --
4374 ------------------------
4376 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
4377 B
: constant Entity_Id
:= Base_Type
(T
);
4382 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
4383 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
4385 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
4387 if Present
(Ext
) then
4388 if Null_Present
(Ext
) then
4391 Comps
:= Component_List
(Ext
);
4393 -- The null component list is rewritten during analysis to
4394 -- include the parent component. Any other component indicates
4395 -- that the extension was not originally null.
4397 return Null_Present
(Comps
)
4398 or else No
(Next
(First
(Component_Items
(Comps
))));
4407 end Has_Null_Extension
;
4409 -------------------------------
4410 -- Has_Overriding_Initialize --
4411 -------------------------------
4413 function Has_Overriding_Initialize
(T
: Entity_Id
) return Boolean is
4414 BT
: constant Entity_Id
:= Base_Type
(T
);
4419 if Is_Controlled
(BT
) then
4421 -- For derived types, check immediate ancestor, excluding
4422 -- Controlled itself.
4424 if Is_Derived_Type
(BT
)
4425 and then not In_Predefined_Unit
(Etype
(BT
))
4426 and then Has_Overriding_Initialize
(Etype
(BT
))
4430 elsif Present
(Primitive_Operations
(BT
)) then
4431 P
:= First_Elmt
(Primitive_Operations
(BT
));
4432 while Present
(P
) loop
4433 if Chars
(Node
(P
)) = Name_Initialize
4434 and then Comes_From_Source
(Node
(P
))
4445 elsif Has_Controlled_Component
(BT
) then
4446 Comp
:= First_Component
(BT
);
4447 while Present
(Comp
) loop
4448 if Has_Overriding_Initialize
(Etype
(Comp
)) then
4452 Next_Component
(Comp
);
4460 end Has_Overriding_Initialize
;
4462 --------------------------------------
4463 -- Has_Preelaborable_Initialization --
4464 --------------------------------------
4466 function Has_Preelaborable_Initialization
(E
: Entity_Id
) return Boolean is
4469 procedure Check_Components
(E
: Entity_Id
);
4470 -- Check component/discriminant chain, sets Has_PE False if a component
4471 -- or discriminant does not meet the preelaborable initialization rules.
4473 ----------------------
4474 -- Check_Components --
4475 ----------------------
4477 procedure Check_Components
(E
: Entity_Id
) is
4481 function Is_Preelaborable_Expression
(N
: Node_Id
) return Boolean;
4482 -- Returns True if and only if the expression denoted by N does not
4483 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
4485 ---------------------------------
4486 -- Is_Preelaborable_Expression --
4487 ---------------------------------
4489 function Is_Preelaborable_Expression
(N
: Node_Id
) return Boolean is
4493 Comp_Type
: Entity_Id
;
4494 Is_Array_Aggr
: Boolean;
4497 if Is_Static_Expression
(N
) then
4500 elsif Nkind
(N
) = N_Null
then
4503 -- Attributes are allowed in general, even if their prefix is a
4504 -- formal type. (It seems that certain attributes known not to be
4505 -- static might not be allowed, but there are no rules to prevent
4508 elsif Nkind
(N
) = N_Attribute_Reference
then
4511 -- The name of a discriminant evaluated within its parent type is
4512 -- defined to be preelaborable (10.2.1(8)). Note that we test for
4513 -- names that denote discriminals as well as discriminants to
4514 -- catch references occurring within init procs.
4516 elsif Is_Entity_Name
(N
)
4518 (Ekind
(Entity
(N
)) = E_Discriminant
4520 ((Ekind
(Entity
(N
)) = E_Constant
4521 or else Ekind
(Entity
(N
)) = E_In_Parameter
)
4522 and then Present
(Discriminal_Link
(Entity
(N
)))))
4526 elsif Nkind
(N
) = N_Qualified_Expression
then
4527 return Is_Preelaborable_Expression
(Expression
(N
));
4529 -- For aggregates we have to check that each of the associations
4530 -- is preelaborable.
4532 elsif Nkind
(N
) = N_Aggregate
4533 or else Nkind
(N
) = N_Extension_Aggregate
4535 Is_Array_Aggr
:= Is_Array_Type
(Etype
(N
));
4537 if Is_Array_Aggr
then
4538 Comp_Type
:= Component_Type
(Etype
(N
));
4541 -- Check the ancestor part of extension aggregates, which must
4542 -- be either the name of a type that has preelaborable init or
4543 -- an expression that is preelaborable.
4545 if Nkind
(N
) = N_Extension_Aggregate
then
4547 Anc_Part
: constant Node_Id
:= Ancestor_Part
(N
);
4550 if Is_Entity_Name
(Anc_Part
)
4551 and then Is_Type
(Entity
(Anc_Part
))
4553 if not Has_Preelaborable_Initialization
4559 elsif not Is_Preelaborable_Expression
(Anc_Part
) then
4565 -- Check positional associations
4567 Exp
:= First
(Expressions
(N
));
4568 while Present
(Exp
) loop
4569 if not Is_Preelaborable_Expression
(Exp
) then
4576 -- Check named associations
4578 Assn
:= First
(Component_Associations
(N
));
4579 while Present
(Assn
) loop
4580 Choice
:= First
(Choices
(Assn
));
4581 while Present
(Choice
) loop
4582 if Is_Array_Aggr
then
4583 if Nkind
(Choice
) = N_Others_Choice
then
4586 elsif Nkind
(Choice
) = N_Range
then
4587 if not Is_Static_Range
(Choice
) then
4591 elsif not Is_Static_Expression
(Choice
) then
4596 Comp_Type
:= Etype
(Choice
);
4602 -- If the association has a <> at this point, then we have
4603 -- to check whether the component's type has preelaborable
4604 -- initialization. Note that this only occurs when the
4605 -- association's corresponding component does not have a
4606 -- default expression, the latter case having already been
4607 -- expanded as an expression for the association.
4609 if Box_Present
(Assn
) then
4610 if not Has_Preelaborable_Initialization
(Comp_Type
) then
4614 -- In the expression case we check whether the expression
4615 -- is preelaborable.
4618 not Is_Preelaborable_Expression
(Expression
(Assn
))
4626 -- If we get here then aggregate as a whole is preelaborable
4630 -- All other cases are not preelaborable
4635 end Is_Preelaborable_Expression
;
4637 -- Start of processing for Check_Components
4640 -- Loop through entities of record or protected type
4643 while Present
(Ent
) loop
4645 -- We are interested only in components and discriminants
4647 if Ekind
(Ent
) = E_Component
4649 Ekind
(Ent
) = E_Discriminant
4651 -- Get default expression if any. If there is no declaration
4652 -- node, it means we have an internal entity. The parent and
4653 -- tag fields are examples of such entities. For these cases,
4654 -- we just test the type of the entity.
4656 if Present
(Declaration_Node
(Ent
)) then
4657 Exp
:= Expression
(Declaration_Node
(Ent
));
4662 -- A component has PI if it has no default expression and the
4663 -- component type has PI.
4666 if not Has_Preelaborable_Initialization
(Etype
(Ent
)) then
4671 -- Require the default expression to be preelaborable
4673 elsif not Is_Preelaborable_Expression
(Exp
) then
4681 end Check_Components
;
4683 -- Start of processing for Has_Preelaborable_Initialization
4686 -- Immediate return if already marked as known preelaborable init. This
4687 -- covers types for which this function has already been called once
4688 -- and returned True (in which case the result is cached), and also
4689 -- types to which a pragma Preelaborable_Initialization applies.
4691 if Known_To_Have_Preelab_Init
(E
) then
4695 -- If the type is a subtype representing a generic actual type, then
4696 -- test whether its base type has preelaborable initialization since
4697 -- the subtype representing the actual does not inherit this attribute
4698 -- from the actual or formal. (but maybe it should???)
4700 if Is_Generic_Actual_Type
(E
) then
4701 return Has_Preelaborable_Initialization
(Base_Type
(E
));
4704 -- All elementary types have preelaborable initialization
4706 if Is_Elementary_Type
(E
) then
4709 -- Array types have PI if the component type has PI
4711 elsif Is_Array_Type
(E
) then
4712 Has_PE
:= Has_Preelaborable_Initialization
(Component_Type
(E
));
4714 -- A derived type has preelaborable initialization if its parent type
4715 -- has preelaborable initialization and (in the case of a derived record
4716 -- extension) if the non-inherited components all have preelaborable
4717 -- initialization. However, a user-defined controlled type with an
4718 -- overriding Initialize procedure does not have preelaborable
4721 elsif Is_Derived_Type
(E
) then
4723 -- If the derived type is a private extension then it doesn't have
4724 -- preelaborable initialization.
4726 if Ekind
(Base_Type
(E
)) = E_Record_Type_With_Private
then
4730 -- First check whether ancestor type has preelaborable initialization
4732 Has_PE
:= Has_Preelaborable_Initialization
(Etype
(Base_Type
(E
)));
4734 -- If OK, check extension components (if any)
4736 if Has_PE
and then Is_Record_Type
(E
) then
4737 Check_Components
(First_Entity
(E
));
4740 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
4741 -- with a user defined Initialize procedure does not have PI.
4744 and then Is_Controlled
(E
)
4745 and then Has_Overriding_Initialize
(E
)
4750 -- Private types not derived from a type having preelaborable init and
4751 -- that are not marked with pragma Preelaborable_Initialization do not
4752 -- have preelaborable initialization.
4754 elsif Is_Private_Type
(E
) then
4757 -- Record type has PI if it is non private and all components have PI
4759 elsif Is_Record_Type
(E
) then
4761 Check_Components
(First_Entity
(E
));
4763 -- Protected types must not have entries, and components must meet
4764 -- same set of rules as for record components.
4766 elsif Is_Protected_Type
(E
) then
4767 if Has_Entries
(E
) then
4771 Check_Components
(First_Entity
(E
));
4772 Check_Components
(First_Private_Entity
(E
));
4775 -- Type System.Address always has preelaborable initialization
4777 elsif Is_RTE
(E
, RE_Address
) then
4780 -- In all other cases, type does not have preelaborable initialization
4786 -- If type has preelaborable initialization, cache result
4789 Set_Known_To_Have_Preelab_Init
(E
);
4793 end Has_Preelaborable_Initialization
;
4795 ---------------------------
4796 -- Has_Private_Component --
4797 ---------------------------
4799 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
4800 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
4801 Component
: Entity_Id
;
4804 if Error_Posted
(Type_Id
)
4805 or else Error_Posted
(Btype
)
4810 if Is_Class_Wide_Type
(Btype
) then
4811 Btype
:= Root_Type
(Btype
);
4814 if Is_Private_Type
(Btype
) then
4816 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
4819 if No
(Full_View
(Btype
)) then
4820 return not Is_Generic_Type
(Btype
)
4821 and then not Is_Generic_Type
(Root_Type
(Btype
));
4823 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
4826 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
4830 elsif Is_Array_Type
(Btype
) then
4831 return Has_Private_Component
(Component_Type
(Btype
));
4833 elsif Is_Record_Type
(Btype
) then
4834 Component
:= First_Component
(Btype
);
4835 while Present
(Component
) loop
4836 if Has_Private_Component
(Etype
(Component
)) then
4840 Next_Component
(Component
);
4845 elsif Is_Protected_Type
(Btype
)
4846 and then Present
(Corresponding_Record_Type
(Btype
))
4848 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
4853 end Has_Private_Component
;
4859 function Has_Stream
(T
: Entity_Id
) return Boolean is
4866 elsif Is_RTE
(Root_Type
(T
), RE_Root_Stream_Type
) then
4869 elsif Is_Array_Type
(T
) then
4870 return Has_Stream
(Component_Type
(T
));
4872 elsif Is_Record_Type
(T
) then
4873 E
:= First_Component
(T
);
4874 while Present
(E
) loop
4875 if Has_Stream
(Etype
(E
)) then
4884 elsif Is_Private_Type
(T
) then
4885 return Has_Stream
(Underlying_Type
(T
));
4892 --------------------------
4893 -- Has_Tagged_Component --
4894 --------------------------
4896 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
4900 if Is_Private_Type
(Typ
)
4901 and then Present
(Underlying_Type
(Typ
))
4903 return Has_Tagged_Component
(Underlying_Type
(Typ
));
4905 elsif Is_Array_Type
(Typ
) then
4906 return Has_Tagged_Component
(Component_Type
(Typ
));
4908 elsif Is_Tagged_Type
(Typ
) then
4911 elsif Is_Record_Type
(Typ
) then
4912 Comp
:= First_Component
(Typ
);
4913 while Present
(Comp
) loop
4914 if Has_Tagged_Component
(Etype
(Comp
)) then
4918 Next_Component
(Comp
);
4926 end Has_Tagged_Component
;
4928 --------------------------
4929 -- Implements_Interface --
4930 --------------------------
4932 function Implements_Interface
4933 (Typ_Ent
: Entity_Id
;
4934 Iface_Ent
: Entity_Id
;
4935 Exclude_Parents
: Boolean := False) return Boolean
4937 Ifaces_List
: Elist_Id
;
4939 Iface
: Entity_Id
:= Base_Type
(Iface_Ent
);
4940 Typ
: Entity_Id
:= Base_Type
(Typ_Ent
);
4943 if Is_Class_Wide_Type
(Typ
) then
4944 Typ
:= Root_Type
(Typ
);
4947 if not Has_Interfaces
(Typ
) then
4951 if Is_Class_Wide_Type
(Iface
) then
4952 Iface
:= Root_Type
(Iface
);
4955 Collect_Interfaces
(Typ
, Ifaces_List
);
4957 Elmt
:= First_Elmt
(Ifaces_List
);
4958 while Present
(Elmt
) loop
4959 if Is_Ancestor
(Node
(Elmt
), Typ
)
4960 and then Exclude_Parents
4964 elsif Node
(Elmt
) = Iface
then
4972 end Implements_Interface
;
4978 function In_Instance
return Boolean is
4979 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
4985 and then S
/= Standard_Standard
4987 if (Ekind
(S
) = E_Function
4988 or else Ekind
(S
) = E_Package
4989 or else Ekind
(S
) = E_Procedure
)
4990 and then Is_Generic_Instance
(S
)
4992 -- A child instance is always compiled in the context of a parent
4993 -- instance. Nevertheless, the actuals are not analyzed in an
4994 -- instance context. We detect this case by examining the current
4995 -- compilation unit, which must be a child instance, and checking
4996 -- that it is not currently on the scope stack.
4998 if Is_Child_Unit
(Curr_Unit
)
5000 Nkind
(Unit
(Cunit
(Current_Sem_Unit
)))
5001 = N_Package_Instantiation
5002 and then not In_Open_Scopes
(Curr_Unit
)
5016 ----------------------
5017 -- In_Instance_Body --
5018 ----------------------
5020 function In_Instance_Body
return Boolean is
5026 and then S
/= Standard_Standard
5028 if (Ekind
(S
) = E_Function
5029 or else Ekind
(S
) = E_Procedure
)
5030 and then Is_Generic_Instance
(S
)
5034 elsif Ekind
(S
) = E_Package
5035 and then In_Package_Body
(S
)
5036 and then Is_Generic_Instance
(S
)
5045 end In_Instance_Body
;
5047 -----------------------------
5048 -- In_Instance_Not_Visible --
5049 -----------------------------
5051 function In_Instance_Not_Visible
return Boolean is
5057 and then S
/= Standard_Standard
5059 if (Ekind
(S
) = E_Function
5060 or else Ekind
(S
) = E_Procedure
)
5061 and then Is_Generic_Instance
(S
)
5065 elsif Ekind
(S
) = E_Package
5066 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
5067 and then Is_Generic_Instance
(S
)
5076 end In_Instance_Not_Visible
;
5078 ------------------------------
5079 -- In_Instance_Visible_Part --
5080 ------------------------------
5082 function In_Instance_Visible_Part
return Boolean is
5088 and then S
/= Standard_Standard
5090 if Ekind
(S
) = E_Package
5091 and then Is_Generic_Instance
(S
)
5092 and then not In_Package_Body
(S
)
5093 and then not In_Private_Part
(S
)
5102 end In_Instance_Visible_Part
;
5104 ---------------------
5105 -- In_Package_Body --
5106 ---------------------
5108 function In_Package_Body
return Boolean is
5114 and then S
/= Standard_Standard
5116 if Ekind
(S
) = E_Package
5117 and then In_Package_Body
(S
)
5126 end In_Package_Body
;
5128 --------------------------------
5129 -- In_Parameter_Specification --
5130 --------------------------------
5132 function In_Parameter_Specification
(N
: Node_Id
) return Boolean is
5137 while Present
(PN
) loop
5138 if Nkind
(PN
) = N_Parameter_Specification
then
5146 end In_Parameter_Specification
;
5148 --------------------------------------
5149 -- In_Subprogram_Or_Concurrent_Unit --
5150 --------------------------------------
5152 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
5157 -- Use scope chain to check successively outer scopes
5163 if K
in Subprogram_Kind
5164 or else K
in Concurrent_Kind
5165 or else K
in Generic_Subprogram_Kind
5169 elsif E
= Standard_Standard
then
5175 end In_Subprogram_Or_Concurrent_Unit
;
5177 ---------------------
5178 -- In_Visible_Part --
5179 ---------------------
5181 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
5184 Is_Package_Or_Generic_Package
(Scope_Id
)
5185 and then In_Open_Scopes
(Scope_Id
)
5186 and then not In_Package_Body
(Scope_Id
)
5187 and then not In_Private_Part
(Scope_Id
);
5188 end In_Visible_Part
;
5190 ---------------------------------
5191 -- Insert_Explicit_Dereference --
5192 ---------------------------------
5194 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
5195 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
5196 Ent
: Entity_Id
:= Empty
;
5203 Save_Interps
(N
, New_Prefix
);
5204 Rewrite
(N
, Make_Explicit_Dereference
(Sloc
(N
), Prefix
=> New_Prefix
));
5206 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
5208 if Is_Overloaded
(New_Prefix
) then
5210 -- The deference is also overloaded, and its interpretations are the
5211 -- designated types of the interpretations of the original node.
5213 Set_Etype
(N
, Any_Type
);
5215 Get_First_Interp
(New_Prefix
, I
, It
);
5216 while Present
(It
.Nam
) loop
5219 if Is_Access_Type
(T
) then
5220 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
5223 Get_Next_Interp
(I
, It
);
5229 -- Prefix is unambiguous: mark the original prefix (which might
5230 -- Come_From_Source) as a reference, since the new (relocated) one
5231 -- won't be taken into account.
5233 if Is_Entity_Name
(New_Prefix
) then
5234 Ent
:= Entity
(New_Prefix
);
5236 -- For a retrieval of a subcomponent of some composite object,
5237 -- retrieve the ultimate entity if there is one.
5239 elsif Nkind
(New_Prefix
) = N_Selected_Component
5240 or else Nkind
(New_Prefix
) = N_Indexed_Component
5242 Pref
:= Prefix
(New_Prefix
);
5243 while Present
(Pref
)
5245 (Nkind
(Pref
) = N_Selected_Component
5246 or else Nkind
(Pref
) = N_Indexed_Component
)
5248 Pref
:= Prefix
(Pref
);
5251 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
5252 Ent
:= Entity
(Pref
);
5256 if Present
(Ent
) then
5257 Generate_Reference
(Ent
, New_Prefix
);
5260 end Insert_Explicit_Dereference
;
5262 ------------------------------------------
5263 -- Inspect_Deferred_Constant_Completion --
5264 ------------------------------------------
5266 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
5270 Decl
:= First
(Decls
);
5271 while Present
(Decl
) loop
5273 -- Deferred constant signature
5275 if Nkind
(Decl
) = N_Object_Declaration
5276 and then Constant_Present
(Decl
)
5277 and then No
(Expression
(Decl
))
5279 -- No need to check internally generated constants
5281 and then Comes_From_Source
(Decl
)
5283 -- The constant is not completed. A full object declaration
5284 -- or a pragma Import complete a deferred constant.
5286 and then not Has_Completion
(Defining_Identifier
(Decl
))
5289 ("constant declaration requires initialization expression",
5290 Defining_Identifier
(Decl
));
5293 Decl
:= Next
(Decl
);
5295 end Inspect_Deferred_Constant_Completion
;
5301 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
5302 pragma Assert
(Is_Type
(E
));
5304 return AAMP_On_Target
5305 and then Is_Floating_Point_Type
(E
)
5306 and then E
= Base_Type
(E
);
5309 -------------------------
5310 -- Is_Actual_Parameter --
5311 -------------------------
5313 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
5314 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
5318 when N_Parameter_Association
=>
5319 return N
= Explicit_Actual_Parameter
(Parent
(N
));
5321 when N_Function_Call | N_Procedure_Call_Statement
=>
5322 return Is_List_Member
(N
)
5324 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
5329 end Is_Actual_Parameter
;
5331 ---------------------
5332 -- Is_Aliased_View --
5333 ---------------------
5335 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
5339 if Is_Entity_Name
(Obj
) then
5347 or else (Present
(Renamed_Object
(E
))
5348 and then Is_Aliased_View
(Renamed_Object
(E
)))))
5350 or else ((Is_Formal
(E
)
5351 or else Ekind
(E
) = E_Generic_In_Out_Parameter
5352 or else Ekind
(E
) = E_Generic_In_Parameter
)
5353 and then Is_Tagged_Type
(Etype
(E
)))
5355 or else (Is_Concurrent_Type
(E
)
5356 and then In_Open_Scopes
(E
))
5358 -- Current instance of type, either directly or as rewritten
5359 -- reference to the current object.
5361 or else (Is_Entity_Name
(Original_Node
(Obj
))
5362 and then Present
(Entity
(Original_Node
(Obj
)))
5363 and then Is_Type
(Entity
(Original_Node
(Obj
))))
5365 or else (Is_Type
(E
) and then E
= Current_Scope
)
5367 or else (Is_Incomplete_Or_Private_Type
(E
)
5368 and then Full_View
(E
) = Current_Scope
);
5370 elsif Nkind
(Obj
) = N_Selected_Component
then
5371 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
5373 elsif Nkind
(Obj
) = N_Indexed_Component
then
5374 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
5376 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
5378 Has_Aliased_Components
5379 (Designated_Type
(Etype
(Prefix
(Obj
)))));
5381 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
5382 or else Nkind
(Obj
) = N_Type_Conversion
5384 return Is_Tagged_Type
(Etype
(Obj
))
5385 and then Is_Aliased_View
(Expression
(Obj
));
5387 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
5388 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
5393 end Is_Aliased_View
;
5395 -------------------------
5396 -- Is_Ancestor_Package --
5397 -------------------------
5399 function Is_Ancestor_Package
5401 E2
: Entity_Id
) return Boolean
5408 and then Par
/= Standard_Standard
5418 end Is_Ancestor_Package
;
5420 ----------------------
5421 -- Is_Atomic_Object --
5422 ----------------------
5424 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
5426 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
5427 -- Determines if given object has atomic components
5429 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
5430 -- If prefix is an implicit dereference, examine designated type
5432 ----------------------
5433 -- Is_Atomic_Prefix --
5434 ----------------------
5436 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
5438 if Is_Access_Type
(Etype
(N
)) then
5440 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
5442 return Object_Has_Atomic_Components
(N
);
5444 end Is_Atomic_Prefix
;
5446 ----------------------------------
5447 -- Object_Has_Atomic_Components --
5448 ----------------------------------
5450 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
5452 if Has_Atomic_Components
(Etype
(N
))
5453 or else Is_Atomic
(Etype
(N
))
5457 elsif Is_Entity_Name
(N
)
5458 and then (Has_Atomic_Components
(Entity
(N
))
5459 or else Is_Atomic
(Entity
(N
)))
5463 elsif Nkind
(N
) = N_Indexed_Component
5464 or else Nkind
(N
) = N_Selected_Component
5466 return Is_Atomic_Prefix
(Prefix
(N
));
5471 end Object_Has_Atomic_Components
;
5473 -- Start of processing for Is_Atomic_Object
5476 if Is_Atomic
(Etype
(N
))
5477 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
5481 elsif Nkind
(N
) = N_Indexed_Component
5482 or else Nkind
(N
) = N_Selected_Component
5484 return Is_Atomic_Prefix
(Prefix
(N
));
5489 end Is_Atomic_Object
;
5491 -------------------------
5492 -- Is_Coextension_Root --
5493 -------------------------
5495 function Is_Coextension_Root
(N
: Node_Id
) return Boolean is
5498 Nkind
(N
) = N_Allocator
5499 and then Present
(Coextensions
(N
))
5501 -- Anonymous access discriminants carry a list of all nested
5502 -- controlled coextensions.
5504 and then not Is_Dynamic_Coextension
(N
)
5505 and then not Is_Static_Coextension
(N
);
5506 end Is_Coextension_Root
;
5508 -----------------------------
5509 -- Is_Concurrent_Interface --
5510 -----------------------------
5512 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
5517 (Is_Protected_Interface
(T
)
5518 or else Is_Synchronized_Interface
(T
)
5519 or else Is_Task_Interface
(T
));
5520 end Is_Concurrent_Interface
;
5522 --------------------------------------
5523 -- Is_Controlling_Limited_Procedure --
5524 --------------------------------------
5526 function Is_Controlling_Limited_Procedure
5527 (Proc_Nam
: Entity_Id
) return Boolean
5529 Param_Typ
: Entity_Id
:= Empty
;
5532 if Ekind
(Proc_Nam
) = E_Procedure
5533 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
5535 Param_Typ
:= Etype
(Parameter_Type
(First
(
5536 Parameter_Specifications
(Parent
(Proc_Nam
)))));
5538 -- In this case where an Itype was created, the procedure call has been
5541 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
5542 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
5544 Present
(Parameter_Associations
5545 (Associated_Node_For_Itype
(Proc_Nam
)))
5548 Etype
(First
(Parameter_Associations
5549 (Associated_Node_For_Itype
(Proc_Nam
))));
5552 if Present
(Param_Typ
) then
5554 Is_Interface
(Param_Typ
)
5555 and then Is_Limited_Record
(Param_Typ
);
5559 end Is_Controlling_Limited_Procedure
;
5561 -----------------------------
5562 -- Is_CPP_Constructor_Call --
5563 -----------------------------
5565 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
5567 return Nkind
(N
) = N_Function_Call
5568 and then Is_CPP_Class
(Etype
(Etype
(N
)))
5569 and then Is_Constructor
(Entity
(Name
(N
)))
5570 and then Is_Imported
(Entity
(Name
(N
)));
5571 end Is_CPP_Constructor_Call
;
5573 ----------------------------------------------
5574 -- Is_Dependent_Component_Of_Mutable_Object --
5575 ----------------------------------------------
5577 function Is_Dependent_Component_Of_Mutable_Object
5578 (Object
: Node_Id
) return Boolean
5581 Prefix_Type
: Entity_Id
;
5582 P_Aliased
: Boolean := False;
5585 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
5586 -- Returns True if and only if Comp is declared within a variant part
5588 --------------------------------
5589 -- Is_Declared_Within_Variant --
5590 --------------------------------
5592 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
5593 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
5594 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
5596 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
5597 end Is_Declared_Within_Variant
;
5599 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
5602 if Is_Variable
(Object
) then
5604 if Nkind
(Object
) = N_Selected_Component
then
5605 P
:= Prefix
(Object
);
5606 Prefix_Type
:= Etype
(P
);
5608 if Is_Entity_Name
(P
) then
5610 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
5611 Prefix_Type
:= Base_Type
(Prefix_Type
);
5614 if Is_Aliased
(Entity
(P
)) then
5618 -- A discriminant check on a selected component may be
5619 -- expanded into a dereference when removing side-effects.
5620 -- Recover the original node and its type, which may be
5623 elsif Nkind
(P
) = N_Explicit_Dereference
5624 and then not (Comes_From_Source
(P
))
5626 P
:= Original_Node
(P
);
5627 Prefix_Type
:= Etype
(P
);
5630 -- Check for prefix being an aliased component ???
5635 -- A heap object is constrained by its initial value
5637 -- Ada 2005 (AI-363): Always assume the object could be mutable in
5638 -- the dereferenced case, since the access value might denote an
5639 -- unconstrained aliased object, whereas in Ada 95 the designated
5640 -- object is guaranteed to be constrained. A worst-case assumption
5641 -- has to apply in Ada 2005 because we can't tell at compile time
5642 -- whether the object is "constrained by its initial value"
5643 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
5644 -- semantic rules -- these rules are acknowledged to need fixing).
5646 if Ada_Version
< Ada_05
then
5647 if Is_Access_Type
(Prefix_Type
)
5648 or else Nkind
(P
) = N_Explicit_Dereference
5653 elsif Ada_Version
>= Ada_05
then
5654 if Is_Access_Type
(Prefix_Type
) then
5656 -- If the access type is pool-specific, and there is no
5657 -- constrained partial view of the designated type, then the
5658 -- designated object is known to be constrained.
5660 if Ekind
(Prefix_Type
) = E_Access_Type
5661 and then not Has_Constrained_Partial_View
5662 (Designated_Type
(Prefix_Type
))
5666 -- Otherwise (general access type, or there is a constrained
5667 -- partial view of the designated type), we need to check
5668 -- based on the designated type.
5671 Prefix_Type
:= Designated_Type
(Prefix_Type
);
5677 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
5679 -- As per AI-0017, the renaming is illegal in a generic body,
5680 -- even if the subtype is indefinite.
5682 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
5684 if not Is_Constrained
(Prefix_Type
)
5685 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
5687 (Is_Generic_Type
(Prefix_Type
)
5688 and then Ekind
(Current_Scope
) = E_Generic_Package
5689 and then In_Package_Body
(Current_Scope
)))
5691 and then (Is_Declared_Within_Variant
(Comp
)
5692 or else Has_Discriminant_Dependent_Constraint
(Comp
))
5693 and then (not P_Aliased
or else Ada_Version
>= Ada_05
)
5699 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
5703 elsif Nkind
(Object
) = N_Indexed_Component
5704 or else Nkind
(Object
) = N_Slice
5706 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
5708 -- A type conversion that Is_Variable is a view conversion:
5709 -- go back to the denoted object.
5711 elsif Nkind
(Object
) = N_Type_Conversion
then
5713 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
5718 end Is_Dependent_Component_Of_Mutable_Object
;
5720 ---------------------
5721 -- Is_Dereferenced --
5722 ---------------------
5724 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
5725 P
: constant Node_Id
:= Parent
(N
);
5728 (Nkind
(P
) = N_Selected_Component
5730 Nkind
(P
) = N_Explicit_Dereference
5732 Nkind
(P
) = N_Indexed_Component
5734 Nkind
(P
) = N_Slice
)
5735 and then Prefix
(P
) = N
;
5736 end Is_Dereferenced
;
5738 ----------------------
5739 -- Is_Descendent_Of --
5740 ----------------------
5742 function Is_Descendent_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
5747 pragma Assert
(Nkind
(T1
) in N_Entity
);
5748 pragma Assert
(Nkind
(T2
) in N_Entity
);
5750 T
:= Base_Type
(T1
);
5752 -- Immediate return if the types match
5757 -- Comment needed here ???
5759 elsif Ekind
(T
) = E_Class_Wide_Type
then
5760 return Etype
(T
) = T2
;
5768 -- Done if we found the type we are looking for
5773 -- Done if no more derivations to check
5780 -- Following test catches error cases resulting from prev errors
5782 elsif No
(Etyp
) then
5785 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
5788 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
5792 T
:= Base_Type
(Etyp
);
5795 end Is_Descendent_Of
;
5801 function Is_False
(U
: Uint
) return Boolean is
5806 ---------------------------
5807 -- Is_Fixed_Model_Number --
5808 ---------------------------
5810 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
5811 S
: constant Ureal
:= Small_Value
(T
);
5812 M
: Urealp
.Save_Mark
;
5816 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
5819 end Is_Fixed_Model_Number
;
5821 -------------------------------
5822 -- Is_Fully_Initialized_Type --
5823 -------------------------------
5825 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
5827 if Is_Scalar_Type
(Typ
) then
5830 elsif Is_Access_Type
(Typ
) then
5833 elsif Is_Array_Type
(Typ
) then
5834 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
5838 -- An interesting case, if we have a constrained type one of whose
5839 -- bounds is known to be null, then there are no elements to be
5840 -- initialized, so all the elements are initialized!
5842 if Is_Constrained
(Typ
) then
5845 Indx_Typ
: Entity_Id
;
5849 Indx
:= First_Index
(Typ
);
5850 while Present
(Indx
) loop
5851 if Etype
(Indx
) = Any_Type
then
5854 -- If index is a range, use directly
5856 elsif Nkind
(Indx
) = N_Range
then
5857 Lbd
:= Low_Bound
(Indx
);
5858 Hbd
:= High_Bound
(Indx
);
5861 Indx_Typ
:= Etype
(Indx
);
5863 if Is_Private_Type
(Indx_Typ
) then
5864 Indx_Typ
:= Full_View
(Indx_Typ
);
5867 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
5870 Lbd
:= Type_Low_Bound
(Indx_Typ
);
5871 Hbd
:= Type_High_Bound
(Indx_Typ
);
5875 if Compile_Time_Known_Value
(Lbd
)
5876 and then Compile_Time_Known_Value
(Hbd
)
5878 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
5888 -- If no null indexes, then type is not fully initialized
5894 elsif Is_Record_Type
(Typ
) then
5895 if Has_Discriminants
(Typ
)
5897 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
5898 and then Is_Fully_Initialized_Variant
(Typ
)
5903 -- Controlled records are considered to be fully initialized if
5904 -- there is a user defined Initialize routine. This may not be
5905 -- entirely correct, but as the spec notes, we are guessing here
5906 -- what is best from the point of view of issuing warnings.
5908 if Is_Controlled
(Typ
) then
5910 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
5913 if Present
(Utyp
) then
5915 Init
: constant Entity_Id
:=
5917 (Underlying_Type
(Typ
), Name_Initialize
));
5921 and then Comes_From_Source
(Init
)
5923 Is_Predefined_File_Name
5924 (File_Name
(Get_Source_File_Index
(Sloc
(Init
))))
5928 elsif Has_Null_Extension
(Typ
)
5930 Is_Fully_Initialized_Type
5931 (Etype
(Base_Type
(Typ
)))
5940 -- Otherwise see if all record components are initialized
5946 Ent
:= First_Entity
(Typ
);
5947 while Present
(Ent
) loop
5948 if Chars
(Ent
) = Name_uController
then
5951 elsif Ekind
(Ent
) = E_Component
5952 and then (No
(Parent
(Ent
))
5953 or else No
(Expression
(Parent
(Ent
))))
5954 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
5956 -- Special VM case for tag components, which need to be
5957 -- defined in this case, but are never initialized as VMs
5958 -- are using other dispatching mechanisms. Ignore this
5959 -- uninitialized case. Note that this applies both to the
5960 -- uTag entry and the main vtable pointer (CPP_Class case).
5962 and then (Tagged_Type_Expansion
or else not Is_Tag
(Ent
))
5971 -- No uninitialized components, so type is fully initialized.
5972 -- Note that this catches the case of no components as well.
5976 elsif Is_Concurrent_Type
(Typ
) then
5979 elsif Is_Private_Type
(Typ
) then
5981 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
5987 return Is_Fully_Initialized_Type
(U
);
5994 end Is_Fully_Initialized_Type
;
5996 ----------------------------------
5997 -- Is_Fully_Initialized_Variant --
5998 ----------------------------------
6000 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
6001 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6002 Constraints
: constant List_Id
:= New_List
;
6003 Components
: constant Elist_Id
:= New_Elmt_List
;
6004 Comp_Elmt
: Elmt_Id
;
6006 Comp_List
: Node_Id
;
6008 Discr_Val
: Node_Id
;
6010 Report_Errors
: Boolean;
6011 pragma Warnings
(Off
, Report_Errors
);
6014 if Serious_Errors_Detected
> 0 then
6018 if Is_Record_Type
(Typ
)
6019 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
6020 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
6022 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
6024 Discr
:= First_Discriminant
(Typ
);
6025 while Present
(Discr
) loop
6026 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
6027 Discr_Val
:= Expression
(Parent
(Discr
));
6029 if Present
(Discr_Val
)
6030 and then Is_OK_Static_Expression
(Discr_Val
)
6032 Append_To
(Constraints
,
6033 Make_Component_Association
(Loc
,
6034 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
6035 Expression
=> New_Copy
(Discr_Val
)));
6043 Next_Discriminant
(Discr
);
6048 Comp_List
=> Comp_List
,
6049 Governed_By
=> Constraints
,
6051 Report_Errors
=> Report_Errors
);
6053 -- Check that each component present is fully initialized
6055 Comp_Elmt
:= First_Elmt
(Components
);
6056 while Present
(Comp_Elmt
) loop
6057 Comp_Id
:= Node
(Comp_Elmt
);
6059 if Ekind
(Comp_Id
) = E_Component
6060 and then (No
(Parent
(Comp_Id
))
6061 or else No
(Expression
(Parent
(Comp_Id
))))
6062 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
6067 Next_Elmt
(Comp_Elmt
);
6072 elsif Is_Private_Type
(Typ
) then
6074 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
6080 return Is_Fully_Initialized_Variant
(U
);
6086 end Is_Fully_Initialized_Variant
;
6088 ----------------------------
6089 -- Is_Inherited_Operation --
6090 ----------------------------
6092 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
6093 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
6095 pragma Assert
(Is_Overloadable
(E
));
6096 return Kind
= N_Full_Type_Declaration
6097 or else Kind
= N_Private_Extension_Declaration
6098 or else Kind
= N_Subtype_Declaration
6099 or else (Ekind
(E
) = E_Enumeration_Literal
6100 and then Is_Derived_Type
(Etype
(E
)));
6101 end Is_Inherited_Operation
;
6103 -----------------------------
6104 -- Is_Library_Level_Entity --
6105 -----------------------------
6107 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
6109 -- The following is a small optimization, and it also properly handles
6110 -- discriminals, which in task bodies might appear in expressions before
6111 -- the corresponding procedure has been created, and which therefore do
6112 -- not have an assigned scope.
6114 if Ekind
(E
) in Formal_Kind
then
6118 -- Normal test is simply that the enclosing dynamic scope is Standard
6120 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
6121 end Is_Library_Level_Entity
;
6123 ---------------------------------
6124 -- Is_Local_Variable_Reference --
6125 ---------------------------------
6127 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
6129 if not Is_Entity_Name
(Expr
) then
6134 Ent
: constant Entity_Id
:= Entity
(Expr
);
6135 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
6137 if Ekind
(Ent
) /= E_Variable
6139 Ekind
(Ent
) /= E_In_Out_Parameter
6143 return Present
(Sub
) and then Sub
= Current_Subprogram
;
6147 end Is_Local_Variable_Reference
;
6149 -------------------------
6150 -- Is_Object_Reference --
6151 -------------------------
6153 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
6155 if Is_Entity_Name
(N
) then
6156 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
6160 when N_Indexed_Component | N_Slice
=>
6162 Is_Object_Reference
(Prefix
(N
))
6163 or else Is_Access_Type
(Etype
(Prefix
(N
)));
6165 -- In Ada95, a function call is a constant object; a procedure
6168 when N_Function_Call
=>
6169 return Etype
(N
) /= Standard_Void_Type
;
6171 -- A reference to the stream attribute Input is a function call
6173 when N_Attribute_Reference
=>
6174 return Attribute_Name
(N
) = Name_Input
;
6176 when N_Selected_Component
=>
6178 Is_Object_Reference
(Selector_Name
(N
))
6180 (Is_Object_Reference
(Prefix
(N
))
6181 or else Is_Access_Type
(Etype
(Prefix
(N
))));
6183 when N_Explicit_Dereference
=>
6186 -- A view conversion of a tagged object is an object reference
6188 when N_Type_Conversion
=>
6189 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
6190 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
6191 and then Is_Object_Reference
(Expression
(N
));
6193 -- An unchecked type conversion is considered to be an object if
6194 -- the operand is an object (this construction arises only as a
6195 -- result of expansion activities).
6197 when N_Unchecked_Type_Conversion
=>
6204 end Is_Object_Reference
;
6206 -----------------------------------
6207 -- Is_OK_Variable_For_Out_Formal --
6208 -----------------------------------
6210 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
6212 Note_Possible_Modification
(AV
, Sure
=> True);
6214 -- We must reject parenthesized variable names. The check for
6215 -- Comes_From_Source is present because there are currently
6216 -- cases where the compiler violates this rule (e.g. passing
6217 -- a task object to its controlled Initialize routine).
6219 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
6222 -- A variable is always allowed
6224 elsif Is_Variable
(AV
) then
6227 -- Unchecked conversions are allowed only if they come from the
6228 -- generated code, which sometimes uses unchecked conversions for out
6229 -- parameters in cases where code generation is unaffected. We tell
6230 -- source unchecked conversions by seeing if they are rewrites of an
6231 -- original Unchecked_Conversion function call, or of an explicit
6232 -- conversion of a function call.
6234 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
6235 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
6238 elsif Comes_From_Source
(AV
)
6239 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
6243 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
6244 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
6250 -- Normal type conversions are allowed if argument is a variable
6252 elsif Nkind
(AV
) = N_Type_Conversion
then
6253 if Is_Variable
(Expression
(AV
))
6254 and then Paren_Count
(Expression
(AV
)) = 0
6256 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
6259 -- We also allow a non-parenthesized expression that raises
6260 -- constraint error if it rewrites what used to be a variable
6262 elsif Raises_Constraint_Error
(Expression
(AV
))
6263 and then Paren_Count
(Expression
(AV
)) = 0
6264 and then Is_Variable
(Original_Node
(Expression
(AV
)))
6268 -- Type conversion of something other than a variable
6274 -- If this node is rewritten, then test the original form, if that is
6275 -- OK, then we consider the rewritten node OK (for example, if the
6276 -- original node is a conversion, then Is_Variable will not be true
6277 -- but we still want to allow the conversion if it converts a variable).
6279 elsif Original_Node
(AV
) /= AV
then
6280 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
6282 -- All other non-variables are rejected
6287 end Is_OK_Variable_For_Out_Formal
;
6289 -----------------------------------
6290 -- Is_Partially_Initialized_Type --
6291 -----------------------------------
6293 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
6295 if Is_Scalar_Type
(Typ
) then
6298 elsif Is_Access_Type
(Typ
) then
6301 elsif Is_Array_Type
(Typ
) then
6303 -- If component type is partially initialized, so is array type
6305 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
6308 -- Otherwise we are only partially initialized if we are fully
6309 -- initialized (this is the empty array case, no point in us
6310 -- duplicating that code here).
6313 return Is_Fully_Initialized_Type
(Typ
);
6316 elsif Is_Record_Type
(Typ
) then
6318 -- A discriminated type is always partially initialized
6320 if Has_Discriminants
(Typ
) then
6323 -- A tagged type is always partially initialized
6325 elsif Is_Tagged_Type
(Typ
) then
6328 -- Case of non-discriminated record
6334 Component_Present
: Boolean := False;
6335 -- Set True if at least one component is present. If no
6336 -- components are present, then record type is fully
6337 -- initialized (another odd case, like the null array).
6340 -- Loop through components
6342 Ent
:= First_Entity
(Typ
);
6343 while Present
(Ent
) loop
6344 if Ekind
(Ent
) = E_Component
then
6345 Component_Present
:= True;
6347 -- If a component has an initialization expression then
6348 -- the enclosing record type is partially initialized
6350 if Present
(Parent
(Ent
))
6351 and then Present
(Expression
(Parent
(Ent
)))
6355 -- If a component is of a type which is itself partially
6356 -- initialized, then the enclosing record type is also.
6358 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
6366 -- No initialized components found. If we found any components
6367 -- they were all uninitialized so the result is false.
6369 if Component_Present
then
6372 -- But if we found no components, then all the components are
6373 -- initialized so we consider the type to be initialized.
6381 -- Concurrent types are always fully initialized
6383 elsif Is_Concurrent_Type
(Typ
) then
6386 -- For a private type, go to underlying type. If there is no underlying
6387 -- type then just assume this partially initialized. Not clear if this
6388 -- can happen in a non-error case, but no harm in testing for this.
6390 elsif Is_Private_Type
(Typ
) then
6392 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
6397 return Is_Partially_Initialized_Type
(U
);
6401 -- For any other type (are there any?) assume partially initialized
6406 end Is_Partially_Initialized_Type
;
6408 ------------------------------------
6409 -- Is_Potentially_Persistent_Type --
6410 ------------------------------------
6412 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
6417 -- For private type, test corresponding full type
6419 if Is_Private_Type
(T
) then
6420 return Is_Potentially_Persistent_Type
(Full_View
(T
));
6422 -- Scalar types are potentially persistent
6424 elsif Is_Scalar_Type
(T
) then
6427 -- Record type is potentially persistent if not tagged and the types of
6428 -- all it components are potentially persistent, and no component has
6429 -- an initialization expression.
6431 elsif Is_Record_Type
(T
)
6432 and then not Is_Tagged_Type
(T
)
6433 and then not Is_Partially_Initialized_Type
(T
)
6435 Comp
:= First_Component
(T
);
6436 while Present
(Comp
) loop
6437 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
6446 -- Array type is potentially persistent if its component type is
6447 -- potentially persistent and if all its constraints are static.
6449 elsif Is_Array_Type
(T
) then
6450 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
6454 Indx
:= First_Index
(T
);
6455 while Present
(Indx
) loop
6456 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
6465 -- All other types are not potentially persistent
6470 end Is_Potentially_Persistent_Type
;
6472 ---------------------------------
6473 -- Is_Protected_Self_Reference --
6474 ---------------------------------
6476 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
6478 function In_Access_Definition
(N
: Node_Id
) return Boolean;
6479 -- Returns true if N belongs to an access definition
6481 --------------------------
6482 -- In_Access_Definition --
6483 --------------------------
6485 function In_Access_Definition
(N
: Node_Id
) return Boolean is
6490 while Present
(P
) loop
6491 if Nkind
(P
) = N_Access_Definition
then
6499 end In_Access_Definition
;
6501 -- Start of processing for Is_Protected_Self_Reference
6504 -- Verify that prefix is analyzed and has the proper form. Note that
6505 -- the attributes Elab_Spec, Elab_Body, and UET_Address, which also
6506 -- produce the address of an entity, do not analyze their prefix
6507 -- because they denote entities that are not necessarily visible.
6508 -- Neither of them can apply to a protected type.
6510 return Ada_Version
>= Ada_05
6511 and then Is_Entity_Name
(N
)
6512 and then Present
(Entity
(N
))
6513 and then Is_Protected_Type
(Entity
(N
))
6514 and then In_Open_Scopes
(Entity
(N
))
6515 and then not In_Access_Definition
(N
);
6516 end Is_Protected_Self_Reference
;
6518 -----------------------------
6519 -- Is_RCI_Pkg_Spec_Or_Body --
6520 -----------------------------
6522 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
6524 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
6525 -- Return True if the unit of Cunit is an RCI package declaration
6527 ---------------------------
6528 -- Is_RCI_Pkg_Decl_Cunit --
6529 ---------------------------
6531 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
6532 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
6535 if Nkind
(The_Unit
) /= N_Package_Declaration
then
6539 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
6540 end Is_RCI_Pkg_Decl_Cunit
;
6542 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
6545 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
6547 (Nkind
(Unit
(Cunit
)) = N_Package_Body
6548 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
6549 end Is_RCI_Pkg_Spec_Or_Body
;
6551 -----------------------------------------
6552 -- Is_Remote_Access_To_Class_Wide_Type --
6553 -----------------------------------------
6555 function Is_Remote_Access_To_Class_Wide_Type
6556 (E
: Entity_Id
) return Boolean
6559 -- A remote access to class-wide type is a general access to object type
6560 -- declared in the visible part of a Remote_Types or Remote_Call_
6563 return Ekind
(E
) = E_General_Access_Type
6564 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
6565 end Is_Remote_Access_To_Class_Wide_Type
;
6567 -----------------------------------------
6568 -- Is_Remote_Access_To_Subprogram_Type --
6569 -----------------------------------------
6571 function Is_Remote_Access_To_Subprogram_Type
6572 (E
: Entity_Id
) return Boolean
6575 return (Ekind
(E
) = E_Access_Subprogram_Type
6576 or else (Ekind
(E
) = E_Record_Type
6577 and then Present
(Corresponding_Remote_Type
(E
))))
6578 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
6579 end Is_Remote_Access_To_Subprogram_Type
;
6581 --------------------
6582 -- Is_Remote_Call --
6583 --------------------
6585 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
6587 if Nkind
(N
) /= N_Procedure_Call_Statement
6588 and then Nkind
(N
) /= N_Function_Call
6590 -- An entry call cannot be remote
6594 elsif Nkind
(Name
(N
)) in N_Has_Entity
6595 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
6597 -- A subprogram declared in the spec of a RCI package is remote
6601 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
6602 and then Is_Remote_Access_To_Subprogram_Type
6603 (Etype
(Prefix
(Name
(N
))))
6605 -- The dereference of a RAS is a remote call
6609 elsif Present
(Controlling_Argument
(N
))
6610 and then Is_Remote_Access_To_Class_Wide_Type
6611 (Etype
(Controlling_Argument
(N
)))
6613 -- Any primitive operation call with a controlling argument of
6614 -- a RACW type is a remote call.
6619 -- All other calls are local calls
6624 ----------------------
6625 -- Is_Renamed_Entry --
6626 ----------------------
6628 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
6629 Orig_Node
: Node_Id
:= Empty
;
6630 Subp_Decl
: Node_Id
:= Parent
(Parent
(Proc_Nam
));
6632 function Is_Entry
(Nam
: Node_Id
) return Boolean;
6633 -- Determine whether Nam is an entry. Traverse selectors if there are
6634 -- nested selected components.
6640 function Is_Entry
(Nam
: Node_Id
) return Boolean is
6642 if Nkind
(Nam
) = N_Selected_Component
then
6643 return Is_Entry
(Selector_Name
(Nam
));
6646 return Ekind
(Entity
(Nam
)) = E_Entry
;
6649 -- Start of processing for Is_Renamed_Entry
6652 if Present
(Alias
(Proc_Nam
)) then
6653 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
6656 -- Look for a rewritten subprogram renaming declaration
6658 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
6659 and then Present
(Original_Node
(Subp_Decl
))
6661 Orig_Node
:= Original_Node
(Subp_Decl
);
6664 -- The rewritten subprogram is actually an entry
6666 if Present
(Orig_Node
)
6667 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
6668 and then Is_Entry
(Name
(Orig_Node
))
6674 end Is_Renamed_Entry
;
6676 ----------------------
6677 -- Is_Selector_Name --
6678 ----------------------
6680 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
6682 if not Is_List_Member
(N
) then
6684 P
: constant Node_Id
:= Parent
(N
);
6685 K
: constant Node_Kind
:= Nkind
(P
);
6688 (K
= N_Expanded_Name
or else
6689 K
= N_Generic_Association
or else
6690 K
= N_Parameter_Association
or else
6691 K
= N_Selected_Component
)
6692 and then Selector_Name
(P
) = N
;
6697 L
: constant List_Id
:= List_Containing
(N
);
6698 P
: constant Node_Id
:= Parent
(L
);
6700 return (Nkind
(P
) = N_Discriminant_Association
6701 and then Selector_Names
(P
) = L
)
6703 (Nkind
(P
) = N_Component_Association
6704 and then Choices
(P
) = L
);
6707 end Is_Selector_Name
;
6713 function Is_Statement
(N
: Node_Id
) return Boolean is
6716 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
6717 or else Nkind
(N
) = N_Procedure_Call_Statement
;
6720 ---------------------------------
6721 -- Is_Synchronized_Tagged_Type --
6722 ---------------------------------
6724 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
6725 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
6728 -- A task or protected type derived from an interface is a tagged type.
6729 -- Such a tagged type is called a synchronized tagged type, as are
6730 -- synchronized interfaces and private extensions whose declaration
6731 -- includes the reserved word synchronized.
6733 return (Is_Tagged_Type
(E
)
6734 and then (Kind
= E_Task_Type
6735 or else Kind
= E_Protected_Type
))
6738 and then Is_Synchronized_Interface
(E
))
6740 (Ekind
(E
) = E_Record_Type_With_Private
6741 and then (Synchronized_Present
(Parent
(E
))
6742 or else Is_Synchronized_Interface
(Etype
(E
))));
6743 end Is_Synchronized_Tagged_Type
;
6749 function Is_Transfer
(N
: Node_Id
) return Boolean is
6750 Kind
: constant Node_Kind
:= Nkind
(N
);
6753 if Kind
= N_Simple_Return_Statement
6755 Kind
= N_Extended_Return_Statement
6757 Kind
= N_Goto_Statement
6759 Kind
= N_Raise_Statement
6761 Kind
= N_Requeue_Statement
6765 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
6766 and then No
(Condition
(N
))
6770 elsif Kind
= N_Procedure_Call_Statement
6771 and then Is_Entity_Name
(Name
(N
))
6772 and then Present
(Entity
(Name
(N
)))
6773 and then No_Return
(Entity
(Name
(N
)))
6777 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
6789 function Is_True
(U
: Uint
) return Boolean is
6798 function Is_Value_Type
(T
: Entity_Id
) return Boolean is
6800 return VM_Target
= CLI_Target
6801 and then Chars
(T
) /= No_Name
6802 and then Get_Name_String
(Chars
(T
)) = "valuetype";
6809 function Is_Variable
(N
: Node_Id
) return Boolean is
6811 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
6812 -- We do the test on the original node, since this is basically a
6813 -- test of syntactic categories, so it must not be disturbed by
6814 -- whatever rewriting might have occurred. For example, an aggregate,
6815 -- which is certainly NOT a variable, could be turned into a variable
6818 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
6819 -- Within a protected function, the private components of the
6820 -- enclosing protected type are constants. A function nested within
6821 -- a (protected) procedure is not itself protected.
6823 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
6824 -- Prefixes can involve implicit dereferences, in which case we
6825 -- must test for the case of a reference of a constant access
6826 -- type, which can never be a variable.
6828 ---------------------------
6829 -- In_Protected_Function --
6830 ---------------------------
6832 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
6833 Prot
: constant Entity_Id
:= Scope
(E
);
6837 if not Is_Protected_Type
(Prot
) then
6841 while Present
(S
) and then S
/= Prot
loop
6842 if Ekind
(S
) = E_Function
6843 and then Scope
(S
) = Prot
6853 end In_Protected_Function
;
6855 ------------------------
6856 -- Is_Variable_Prefix --
6857 ------------------------
6859 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
6861 if Is_Access_Type
(Etype
(P
)) then
6862 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
6864 -- For the case of an indexed component whose prefix has a packed
6865 -- array type, the prefix has been rewritten into a type conversion.
6866 -- Determine variable-ness from the converted expression.
6868 elsif Nkind
(P
) = N_Type_Conversion
6869 and then not Comes_From_Source
(P
)
6870 and then Is_Array_Type
(Etype
(P
))
6871 and then Is_Packed
(Etype
(P
))
6873 return Is_Variable
(Expression
(P
));
6876 return Is_Variable
(P
);
6878 end Is_Variable_Prefix
;
6880 -- Start of processing for Is_Variable
6883 -- Definitely OK if Assignment_OK is set. Since this is something that
6884 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
6886 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
6889 -- Normally we go to the original node, but there is one exception
6890 -- where we use the rewritten node, namely when it is an explicit
6891 -- dereference. The generated code may rewrite a prefix which is an
6892 -- access type with an explicit dereference. The dereference is a
6893 -- variable, even though the original node may not be (since it could
6894 -- be a constant of the access type).
6896 -- In Ada 2005 we have a further case to consider: the prefix may be
6897 -- a function call given in prefix notation. The original node appears
6898 -- to be a selected component, but we need to examine the call.
6900 elsif Nkind
(N
) = N_Explicit_Dereference
6901 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
6902 and then Present
(Etype
(Orig_Node
))
6903 and then Is_Access_Type
(Etype
(Orig_Node
))
6905 -- Note that if the prefix is an explicit dereference that does not
6906 -- come from source, we must check for a rewritten function call in
6907 -- prefixed notation before other forms of rewriting, to prevent a
6911 (Nkind
(Orig_Node
) = N_Function_Call
6912 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
6914 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
6916 -- A function call is never a variable
6918 elsif Nkind
(N
) = N_Function_Call
then
6921 -- All remaining checks use the original node
6923 elsif Is_Entity_Name
(Orig_Node
)
6924 and then Present
(Entity
(Orig_Node
))
6927 E
: constant Entity_Id
:= Entity
(Orig_Node
);
6928 K
: constant Entity_Kind
:= Ekind
(E
);
6931 return (K
= E_Variable
6932 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
6933 or else (K
= E_Component
6934 and then not In_Protected_Function
(E
))
6935 or else K
= E_Out_Parameter
6936 or else K
= E_In_Out_Parameter
6937 or else K
= E_Generic_In_Out_Parameter
6939 -- Current instance of type:
6941 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
6942 or else (Is_Incomplete_Or_Private_Type
(E
)
6943 and then In_Open_Scopes
(Full_View
(E
)));
6947 case Nkind
(Orig_Node
) is
6948 when N_Indexed_Component | N_Slice
=>
6949 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
6951 when N_Selected_Component
=>
6952 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
6953 and then Is_Variable
(Selector_Name
(Orig_Node
));
6955 -- For an explicit dereference, the type of the prefix cannot
6956 -- be an access to constant or an access to subprogram.
6958 when N_Explicit_Dereference
=>
6960 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
6962 return Is_Access_Type
(Typ
)
6963 and then not Is_Access_Constant
(Root_Type
(Typ
))
6964 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
6967 -- The type conversion is the case where we do not deal with the
6968 -- context dependent special case of an actual parameter. Thus
6969 -- the type conversion is only considered a variable for the
6970 -- purposes of this routine if the target type is tagged. However,
6971 -- a type conversion is considered to be a variable if it does not
6972 -- come from source (this deals for example with the conversions
6973 -- of expressions to their actual subtypes).
6975 when N_Type_Conversion
=>
6976 return Is_Variable
(Expression
(Orig_Node
))
6978 (not Comes_From_Source
(Orig_Node
)
6980 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
6982 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
6984 -- GNAT allows an unchecked type conversion as a variable. This
6985 -- only affects the generation of internal expanded code, since
6986 -- calls to instantiations of Unchecked_Conversion are never
6987 -- considered variables (since they are function calls).
6988 -- This is also true for expression actions.
6990 when N_Unchecked_Type_Conversion
=>
6991 return Is_Variable
(Expression
(Orig_Node
));
6999 ------------------------
7000 -- Is_Volatile_Object --
7001 ------------------------
7003 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
7005 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
7006 -- Determines if given object has volatile components
7008 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
7009 -- If prefix is an implicit dereference, examine designated type
7011 ------------------------
7012 -- Is_Volatile_Prefix --
7013 ------------------------
7015 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
7016 Typ
: constant Entity_Id
:= Etype
(N
);
7019 if Is_Access_Type
(Typ
) then
7021 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
7024 return Is_Volatile
(Dtyp
)
7025 or else Has_Volatile_Components
(Dtyp
);
7029 return Object_Has_Volatile_Components
(N
);
7031 end Is_Volatile_Prefix
;
7033 ------------------------------------
7034 -- Object_Has_Volatile_Components --
7035 ------------------------------------
7037 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
7038 Typ
: constant Entity_Id
:= Etype
(N
);
7041 if Is_Volatile
(Typ
)
7042 or else Has_Volatile_Components
(Typ
)
7046 elsif Is_Entity_Name
(N
)
7047 and then (Has_Volatile_Components
(Entity
(N
))
7048 or else Is_Volatile
(Entity
(N
)))
7052 elsif Nkind
(N
) = N_Indexed_Component
7053 or else Nkind
(N
) = N_Selected_Component
7055 return Is_Volatile_Prefix
(Prefix
(N
));
7060 end Object_Has_Volatile_Components
;
7062 -- Start of processing for Is_Volatile_Object
7065 if Is_Volatile
(Etype
(N
))
7066 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
7070 elsif Nkind
(N
) = N_Indexed_Component
7071 or else Nkind
(N
) = N_Selected_Component
7073 return Is_Volatile_Prefix
(Prefix
(N
));
7078 end Is_Volatile_Object
;
7080 -------------------------
7081 -- Kill_Current_Values --
7082 -------------------------
7084 procedure Kill_Current_Values
7086 Last_Assignment_Only
: Boolean := False)
7089 if Is_Assignable
(Ent
) then
7090 Set_Last_Assignment
(Ent
, Empty
);
7093 if not Last_Assignment_Only
and then Is_Object
(Ent
) then
7095 Set_Current_Value
(Ent
, Empty
);
7097 if not Can_Never_Be_Null
(Ent
) then
7098 Set_Is_Known_Non_Null
(Ent
, False);
7101 Set_Is_Known_Null
(Ent
, False);
7103 end Kill_Current_Values
;
7105 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
7108 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
7109 -- Clear current value for entity E and all entities chained to E
7111 ------------------------------------------
7112 -- Kill_Current_Values_For_Entity_Chain --
7113 ------------------------------------------
7115 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
7119 while Present
(Ent
) loop
7120 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
7123 end Kill_Current_Values_For_Entity_Chain
;
7125 -- Start of processing for Kill_Current_Values
7128 -- Kill all saved checks, a special case of killing saved values
7130 if not Last_Assignment_Only
then
7134 -- Loop through relevant scopes, which includes the current scope and
7135 -- any parent scopes if the current scope is a block or a package.
7140 -- Clear current values of all entities in current scope
7142 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
7144 -- If scope is a package, also clear current values of all
7145 -- private entities in the scope.
7147 if Is_Package_Or_Generic_Package
(S
)
7148 or else Is_Concurrent_Type
(S
)
7150 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
7153 -- If this is a not a subprogram, deal with parents
7155 if not Is_Subprogram
(S
) then
7157 exit Scope_Loop
when S
= Standard_Standard
;
7161 end loop Scope_Loop
;
7162 end Kill_Current_Values
;
7164 --------------------------
7165 -- Kill_Size_Check_Code --
7166 --------------------------
7168 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
7170 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
7171 and then Present
(Size_Check_Code
(E
))
7173 Remove
(Size_Check_Code
(E
));
7174 Set_Size_Check_Code
(E
, Empty
);
7176 end Kill_Size_Check_Code
;
7178 --------------------------
7179 -- Known_To_Be_Assigned --
7180 --------------------------
7182 function Known_To_Be_Assigned
(N
: Node_Id
) return Boolean is
7183 P
: constant Node_Id
:= Parent
(N
);
7188 -- Test left side of assignment
7190 when N_Assignment_Statement
=>
7191 return N
= Name
(P
);
7193 -- Function call arguments are never lvalues
7195 when N_Function_Call
=>
7198 -- Positional parameter for procedure or accept call
7200 when N_Procedure_Call_Statement |
7209 Proc
:= Get_Subprogram_Entity
(P
);
7215 -- If we are not a list member, something is strange, so
7216 -- be conservative and return False.
7218 if not Is_List_Member
(N
) then
7222 -- We are going to find the right formal by stepping forward
7223 -- through the formals, as we step backwards in the actuals.
7225 Form
:= First_Formal
(Proc
);
7228 -- If no formal, something is weird, so be conservative
7229 -- and return False.
7240 return Ekind
(Form
) /= E_In_Parameter
;
7243 -- Named parameter for procedure or accept call
7245 when N_Parameter_Association
=>
7251 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
7257 -- Loop through formals to find the one that matches
7259 Form
:= First_Formal
(Proc
);
7261 -- If no matching formal, that's peculiar, some kind of
7262 -- previous error, so return False to be conservative.
7268 -- Else test for match
7270 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
7271 return Ekind
(Form
) /= E_In_Parameter
;
7278 -- Test for appearing in a conversion that itself appears
7279 -- in an lvalue context, since this should be an lvalue.
7281 when N_Type_Conversion
=>
7282 return Known_To_Be_Assigned
(P
);
7284 -- All other references are definitely not known to be modifications
7290 end Known_To_Be_Assigned
;
7296 function May_Be_Lvalue
(N
: Node_Id
) return Boolean is
7297 P
: constant Node_Id
:= Parent
(N
);
7302 -- Test left side of assignment
7304 when N_Assignment_Statement
=>
7305 return N
= Name
(P
);
7307 -- Test prefix of component or attribute. Note that the prefix of an
7308 -- explicit or implicit dereference cannot be an l-value.
7310 when N_Attribute_Reference
=>
7311 return N
= Prefix
(P
)
7312 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
));
7314 -- For an expanded name, the name is an lvalue if the expanded name
7315 -- is an lvalue, but the prefix is never an lvalue, since it is just
7316 -- the scope where the name is found.
7318 when N_Expanded_Name
=>
7319 if N
= Prefix
(P
) then
7320 return May_Be_Lvalue
(P
);
7325 -- For a selected component A.B, A is certainly an lvalue if A.B is.
7326 -- B is a little interesting, if we have A.B := 3, there is some
7327 -- discussion as to whether B is an lvalue or not, we choose to say
7328 -- it is. Note however that A is not an lvalue if it is of an access
7329 -- type since this is an implicit dereference.
7331 when N_Selected_Component
=>
7333 and then Present
(Etype
(N
))
7334 and then Is_Access_Type
(Etype
(N
))
7338 return May_Be_Lvalue
(P
);
7341 -- For an indexed component or slice, the index or slice bounds is
7342 -- never an lvalue. The prefix is an lvalue if the indexed component
7343 -- or slice is an lvalue, except if it is an access type, where we
7344 -- have an implicit dereference.
7346 when N_Indexed_Component
=>
7348 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
7352 return May_Be_Lvalue
(P
);
7355 -- Prefix of a reference is an lvalue if the reference is an lvalue
7358 return May_Be_Lvalue
(P
);
7360 -- Prefix of explicit dereference is never an lvalue
7362 when N_Explicit_Dereference
=>
7365 -- Function call arguments are never lvalues
7367 when N_Function_Call
=>
7370 -- Positional parameter for procedure, entry, or accept call
7372 when N_Procedure_Call_Statement |
7373 N_Entry_Call_Statement |
7382 Proc
:= Get_Subprogram_Entity
(P
);
7388 -- If we are not a list member, something is strange, so
7389 -- be conservative and return True.
7391 if not Is_List_Member
(N
) then
7395 -- We are going to find the right formal by stepping forward
7396 -- through the formals, as we step backwards in the actuals.
7398 Form
:= First_Formal
(Proc
);
7401 -- If no formal, something is weird, so be conservative
7413 return Ekind
(Form
) /= E_In_Parameter
;
7416 -- Named parameter for procedure or accept call
7418 when N_Parameter_Association
=>
7424 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
7430 -- Loop through formals to find the one that matches
7432 Form
:= First_Formal
(Proc
);
7434 -- If no matching formal, that's peculiar, some kind of
7435 -- previous error, so return True to be conservative.
7441 -- Else test for match
7443 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
7444 return Ekind
(Form
) /= E_In_Parameter
;
7451 -- Test for appearing in a conversion that itself appears in an
7452 -- lvalue context, since this should be an lvalue.
7454 when N_Type_Conversion
=>
7455 return May_Be_Lvalue
(P
);
7457 -- Test for appearance in object renaming declaration
7459 when N_Object_Renaming_Declaration
=>
7462 -- All other references are definitely not lvalues
7470 -----------------------
7471 -- Mark_Coextensions --
7472 -----------------------
7474 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
7475 Is_Dynamic
: Boolean;
7476 -- Indicates whether the context causes nested coextensions to be
7477 -- dynamic or static
7479 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
7480 -- Recognize an allocator node and label it as a dynamic coextension
7482 --------------------
7483 -- Mark_Allocator --
7484 --------------------
7486 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
7488 if Nkind
(N
) = N_Allocator
then
7490 Set_Is_Dynamic_Coextension
(N
);
7492 Set_Is_Static_Coextension
(N
);
7499 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
7501 -- Start of processing Mark_Coextensions
7504 case Nkind
(Context_Nod
) is
7505 when N_Assignment_Statement |
7506 N_Simple_Return_Statement
=>
7507 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) = N_Allocator
;
7509 when N_Object_Declaration
=>
7510 Is_Dynamic
:= Nkind
(Root_Nod
) = N_Allocator
;
7512 -- This routine should not be called for constructs which may not
7513 -- contain coextensions.
7516 raise Program_Error
;
7519 Mark_Allocators
(Root_Nod
);
7520 end Mark_Coextensions
;
7522 ----------------------
7523 -- Needs_One_Actual --
7524 ----------------------
7526 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
7530 if Ada_Version
>= Ada_05
7531 and then Present
(First_Formal
(E
))
7533 Formal
:= Next_Formal
(First_Formal
(E
));
7534 while Present
(Formal
) loop
7535 if No
(Default_Value
(Formal
)) then
7539 Next_Formal
(Formal
);
7547 end Needs_One_Actual
;
7549 ------------------------
7550 -- New_Copy_List_Tree --
7551 ------------------------
7553 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
7558 if List
= No_List
then
7565 while Present
(E
) loop
7566 Append
(New_Copy_Tree
(E
), NL
);
7572 end New_Copy_List_Tree
;
7578 use Atree
.Unchecked_Access
;
7579 use Atree_Private_Part
;
7581 -- Our approach here requires a two pass traversal of the tree. The
7582 -- first pass visits all nodes that eventually will be copied looking
7583 -- for defining Itypes. If any defining Itypes are found, then they are
7584 -- copied, and an entry is added to the replacement map. In the second
7585 -- phase, the tree is copied, using the replacement map to replace any
7586 -- Itype references within the copied tree.
7588 -- The following hash tables are used if the Map supplied has more
7589 -- than hash threshhold entries to speed up access to the map. If
7590 -- there are fewer entries, then the map is searched sequentially
7591 -- (because setting up a hash table for only a few entries takes
7592 -- more time than it saves.
7594 function New_Copy_Hash
(E
: Entity_Id
) return NCT_Header_Num
;
7595 -- Hash function used for hash operations
7601 function New_Copy_Hash
(E
: Entity_Id
) return NCT_Header_Num
is
7603 return Nat
(E
) mod (NCT_Header_Num
'Last + 1);
7610 -- The hash table NCT_Assoc associates old entities in the table
7611 -- with their corresponding new entities (i.e. the pairs of entries
7612 -- presented in the original Map argument are Key-Element pairs).
7614 package NCT_Assoc
is new Simple_HTable
(
7615 Header_Num
=> NCT_Header_Num
,
7616 Element
=> Entity_Id
,
7617 No_Element
=> Empty
,
7619 Hash
=> New_Copy_Hash
,
7620 Equal
=> Types
."=");
7622 ---------------------
7623 -- NCT_Itype_Assoc --
7624 ---------------------
7626 -- The hash table NCT_Itype_Assoc contains entries only for those
7627 -- old nodes which have a non-empty Associated_Node_For_Itype set.
7628 -- The key is the associated node, and the element is the new node
7629 -- itself (NOT the associated node for the new node).
7631 package NCT_Itype_Assoc
is new Simple_HTable
(
7632 Header_Num
=> NCT_Header_Num
,
7633 Element
=> Entity_Id
,
7634 No_Element
=> Empty
,
7636 Hash
=> New_Copy_Hash
,
7637 Equal
=> Types
."=");
7639 -- Start of processing for New_Copy_Tree function
7641 function New_Copy_Tree
7643 Map
: Elist_Id
:= No_Elist
;
7644 New_Sloc
: Source_Ptr
:= No_Location
;
7645 New_Scope
: Entity_Id
:= Empty
) return Node_Id
7647 Actual_Map
: Elist_Id
:= Map
;
7648 -- This is the actual map for the copy. It is initialized with the
7649 -- given elements, and then enlarged as required for Itypes that are
7650 -- copied during the first phase of the copy operation. The visit
7651 -- procedures add elements to this map as Itypes are encountered.
7652 -- The reason we cannot use Map directly, is that it may well be
7653 -- (and normally is) initialized to No_Elist, and if we have mapped
7654 -- entities, we have to reset it to point to a real Elist.
7656 function Assoc
(N
: Node_Or_Entity_Id
) return Node_Id
;
7657 -- Called during second phase to map entities into their corresponding
7658 -- copies using Actual_Map. If the argument is not an entity, or is not
7659 -- in Actual_Map, then it is returned unchanged.
7661 procedure Build_NCT_Hash_Tables
;
7662 -- Builds hash tables (number of elements >= threshold value)
7664 function Copy_Elist_With_Replacement
7665 (Old_Elist
: Elist_Id
) return Elist_Id
;
7666 -- Called during second phase to copy element list doing replacements
7668 procedure Copy_Itype_With_Replacement
(New_Itype
: Entity_Id
);
7669 -- Called during the second phase to process a copied Itype. The actual
7670 -- copy happened during the first phase (so that we could make the entry
7671 -- in the mapping), but we still have to deal with the descendents of
7672 -- the copied Itype and copy them where necessary.
7674 function Copy_List_With_Replacement
(Old_List
: List_Id
) return List_Id
;
7675 -- Called during second phase to copy list doing replacements
7677 function Copy_Node_With_Replacement
(Old_Node
: Node_Id
) return Node_Id
;
7678 -- Called during second phase to copy node doing replacements
7680 procedure Visit_Elist
(E
: Elist_Id
);
7681 -- Called during first phase to visit all elements of an Elist
7683 procedure Visit_Field
(F
: Union_Id
; N
: Node_Id
);
7684 -- Visit a single field, recursing to call Visit_Node or Visit_List
7685 -- if the field is a syntactic descendent of the current node (i.e.
7686 -- its parent is Node N).
7688 procedure Visit_Itype
(Old_Itype
: Entity_Id
);
7689 -- Called during first phase to visit subsidiary fields of a defining
7690 -- Itype, and also create a copy and make an entry in the replacement
7691 -- map for the new copy.
7693 procedure Visit_List
(L
: List_Id
);
7694 -- Called during first phase to visit all elements of a List
7696 procedure Visit_Node
(N
: Node_Or_Entity_Id
);
7697 -- Called during first phase to visit a node and all its subtrees
7703 function Assoc
(N
: Node_Or_Entity_Id
) return Node_Id
is
7708 if not Has_Extension
(N
) or else No
(Actual_Map
) then
7711 elsif NCT_Hash_Tables_Used
then
7712 Ent
:= NCT_Assoc
.Get
(Entity_Id
(N
));
7714 if Present
(Ent
) then
7720 -- No hash table used, do serial search
7723 E
:= First_Elmt
(Actual_Map
);
7724 while Present
(E
) loop
7725 if Node
(E
) = N
then
7726 return Node
(Next_Elmt
(E
));
7728 E
:= Next_Elmt
(Next_Elmt
(E
));
7736 ---------------------------
7737 -- Build_NCT_Hash_Tables --
7738 ---------------------------
7740 procedure Build_NCT_Hash_Tables
is
7744 if NCT_Hash_Table_Setup
then
7746 NCT_Itype_Assoc
.Reset
;
7749 Elmt
:= First_Elmt
(Actual_Map
);
7750 while Present
(Elmt
) loop
7753 -- Get new entity, and associate old and new
7756 NCT_Assoc
.Set
(Ent
, Node
(Elmt
));
7758 if Is_Type
(Ent
) then
7760 Anode
: constant Entity_Id
:=
7761 Associated_Node_For_Itype
(Ent
);
7764 if Present
(Anode
) then
7766 -- Enter a link between the associated node of the
7767 -- old Itype and the new Itype, for updating later
7768 -- when node is copied.
7770 NCT_Itype_Assoc
.Set
(Anode
, Node
(Elmt
));
7778 NCT_Hash_Tables_Used
:= True;
7779 NCT_Hash_Table_Setup
:= True;
7780 end Build_NCT_Hash_Tables
;
7782 ---------------------------------
7783 -- Copy_Elist_With_Replacement --
7784 ---------------------------------
7786 function Copy_Elist_With_Replacement
7787 (Old_Elist
: Elist_Id
) return Elist_Id
7790 New_Elist
: Elist_Id
;
7793 if No
(Old_Elist
) then
7797 New_Elist
:= New_Elmt_List
;
7799 M
:= First_Elmt
(Old_Elist
);
7800 while Present
(M
) loop
7801 Append_Elmt
(Copy_Node_With_Replacement
(Node
(M
)), New_Elist
);
7807 end Copy_Elist_With_Replacement
;
7809 ---------------------------------
7810 -- Copy_Itype_With_Replacement --
7811 ---------------------------------
7813 -- This routine exactly parallels its phase one analog Visit_Itype,
7815 procedure Copy_Itype_With_Replacement
(New_Itype
: Entity_Id
) is
7817 -- Translate Next_Entity, Scope and Etype fields, in case they
7818 -- reference entities that have been mapped into copies.
7820 Set_Next_Entity
(New_Itype
, Assoc
(Next_Entity
(New_Itype
)));
7821 Set_Etype
(New_Itype
, Assoc
(Etype
(New_Itype
)));
7823 if Present
(New_Scope
) then
7824 Set_Scope
(New_Itype
, New_Scope
);
7826 Set_Scope
(New_Itype
, Assoc
(Scope
(New_Itype
)));
7829 -- Copy referenced fields
7831 if Is_Discrete_Type
(New_Itype
) then
7832 Set_Scalar_Range
(New_Itype
,
7833 Copy_Node_With_Replacement
(Scalar_Range
(New_Itype
)));
7835 elsif Has_Discriminants
(Base_Type
(New_Itype
)) then
7836 Set_Discriminant_Constraint
(New_Itype
,
7837 Copy_Elist_With_Replacement
7838 (Discriminant_Constraint
(New_Itype
)));
7840 elsif Is_Array_Type
(New_Itype
) then
7841 if Present
(First_Index
(New_Itype
)) then
7842 Set_First_Index
(New_Itype
,
7843 First
(Copy_List_With_Replacement
7844 (List_Containing
(First_Index
(New_Itype
)))));
7847 if Is_Packed
(New_Itype
) then
7848 Set_Packed_Array_Type
(New_Itype
,
7849 Copy_Node_With_Replacement
7850 (Packed_Array_Type
(New_Itype
)));
7853 end Copy_Itype_With_Replacement
;
7855 --------------------------------
7856 -- Copy_List_With_Replacement --
7857 --------------------------------
7859 function Copy_List_With_Replacement
7860 (Old_List
: List_Id
) return List_Id
7866 if Old_List
= No_List
then
7870 New_List
:= Empty_List
;
7872 E
:= First
(Old_List
);
7873 while Present
(E
) loop
7874 Append
(Copy_Node_With_Replacement
(E
), New_List
);
7880 end Copy_List_With_Replacement
;
7882 --------------------------------
7883 -- Copy_Node_With_Replacement --
7884 --------------------------------
7886 function Copy_Node_With_Replacement
7887 (Old_Node
: Node_Id
) return Node_Id
7891 procedure Adjust_Named_Associations
7892 (Old_Node
: Node_Id
;
7893 New_Node
: Node_Id
);
7894 -- If a call node has named associations, these are chained through
7895 -- the First_Named_Actual, Next_Named_Actual links. These must be
7896 -- propagated separately to the new parameter list, because these
7897 -- are not syntactic fields.
7899 function Copy_Field_With_Replacement
7900 (Field
: Union_Id
) return Union_Id
;
7901 -- Given Field, which is a field of Old_Node, return a copy of it
7902 -- if it is a syntactic field (i.e. its parent is Node), setting
7903 -- the parent of the copy to poit to New_Node. Otherwise returns
7904 -- the field (possibly mapped if it is an entity).
7906 -------------------------------
7907 -- Adjust_Named_Associations --
7908 -------------------------------
7910 procedure Adjust_Named_Associations
7911 (Old_Node
: Node_Id
;
7921 Old_E
:= First
(Parameter_Associations
(Old_Node
));
7922 New_E
:= First
(Parameter_Associations
(New_Node
));
7923 while Present
(Old_E
) loop
7924 if Nkind
(Old_E
) = N_Parameter_Association
7925 and then Present
(Next_Named_Actual
(Old_E
))
7927 if First_Named_Actual
(Old_Node
)
7928 = Explicit_Actual_Parameter
(Old_E
)
7930 Set_First_Named_Actual
7931 (New_Node
, Explicit_Actual_Parameter
(New_E
));
7934 -- Now scan parameter list from the beginning,to locate
7935 -- next named actual, which can be out of order.
7937 Old_Next
:= First
(Parameter_Associations
(Old_Node
));
7938 New_Next
:= First
(Parameter_Associations
(New_Node
));
7940 while Nkind
(Old_Next
) /= N_Parameter_Association
7941 or else Explicit_Actual_Parameter
(Old_Next
)
7942 /= Next_Named_Actual
(Old_E
)
7948 Set_Next_Named_Actual
7949 (New_E
, Explicit_Actual_Parameter
(New_Next
));
7955 end Adjust_Named_Associations
;
7957 ---------------------------------
7958 -- Copy_Field_With_Replacement --
7959 ---------------------------------
7961 function Copy_Field_With_Replacement
7962 (Field
: Union_Id
) return Union_Id
7965 if Field
= Union_Id
(Empty
) then
7968 elsif Field
in Node_Range
then
7970 Old_N
: constant Node_Id
:= Node_Id
(Field
);
7974 -- If syntactic field, as indicated by the parent pointer
7975 -- being set, then copy the referenced node recursively.
7977 if Parent
(Old_N
) = Old_Node
then
7978 New_N
:= Copy_Node_With_Replacement
(Old_N
);
7980 if New_N
/= Old_N
then
7981 Set_Parent
(New_N
, New_Node
);
7984 -- For semantic fields, update possible entity reference
7985 -- from the replacement map.
7988 New_N
:= Assoc
(Old_N
);
7991 return Union_Id
(New_N
);
7994 elsif Field
in List_Range
then
7996 Old_L
: constant List_Id
:= List_Id
(Field
);
8000 -- If syntactic field, as indicated by the parent pointer,
8001 -- then recursively copy the entire referenced list.
8003 if Parent
(Old_L
) = Old_Node
then
8004 New_L
:= Copy_List_With_Replacement
(Old_L
);
8005 Set_Parent
(New_L
, New_Node
);
8007 -- For semantic list, just returned unchanged
8013 return Union_Id
(New_L
);
8016 -- Anything other than a list or a node is returned unchanged
8021 end Copy_Field_With_Replacement
;
8023 -- Start of processing for Copy_Node_With_Replacement
8026 if Old_Node
<= Empty_Or_Error
then
8029 elsif Has_Extension
(Old_Node
) then
8030 return Assoc
(Old_Node
);
8033 New_Node
:= New_Copy
(Old_Node
);
8035 -- If the node we are copying is the associated node of a
8036 -- previously copied Itype, then adjust the associated node
8037 -- of the copy of that Itype accordingly.
8039 if Present
(Actual_Map
) then
8045 -- Case of hash table used
8047 if NCT_Hash_Tables_Used
then
8048 Ent
:= NCT_Itype_Assoc
.Get
(Old_Node
);
8050 if Present
(Ent
) then
8051 Set_Associated_Node_For_Itype
(Ent
, New_Node
);
8054 -- Case of no hash table used
8057 E
:= First_Elmt
(Actual_Map
);
8058 while Present
(E
) loop
8059 if Is_Itype
(Node
(E
))
8061 Old_Node
= Associated_Node_For_Itype
(Node
(E
))
8063 Set_Associated_Node_For_Itype
8064 (Node
(Next_Elmt
(E
)), New_Node
);
8067 E
:= Next_Elmt
(Next_Elmt
(E
));
8073 -- Recursively copy descendents
8076 (New_Node
, Copy_Field_With_Replacement
(Field1
(New_Node
)));
8078 (New_Node
, Copy_Field_With_Replacement
(Field2
(New_Node
)));
8080 (New_Node
, Copy_Field_With_Replacement
(Field3
(New_Node
)));
8082 (New_Node
, Copy_Field_With_Replacement
(Field4
(New_Node
)));
8084 (New_Node
, Copy_Field_With_Replacement
(Field5
(New_Node
)));
8086 -- Adjust Sloc of new node if necessary
8088 if New_Sloc
/= No_Location
then
8089 Set_Sloc
(New_Node
, New_Sloc
);
8091 -- If we adjust the Sloc, then we are essentially making
8092 -- a completely new node, so the Comes_From_Source flag
8093 -- should be reset to the proper default value.
8095 Nodes
.Table
(New_Node
).Comes_From_Source
:=
8096 Default_Node
.Comes_From_Source
;
8099 -- If the node is call and has named associations,
8100 -- set the corresponding links in the copy.
8102 if (Nkind
(Old_Node
) = N_Function_Call
8103 or else Nkind
(Old_Node
) = N_Entry_Call_Statement
8105 Nkind
(Old_Node
) = N_Procedure_Call_Statement
)
8106 and then Present
(First_Named_Actual
(Old_Node
))
8108 Adjust_Named_Associations
(Old_Node
, New_Node
);
8111 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
8112 -- The replacement mechanism applies to entities, and is not used
8113 -- here. Eventually we may need a more general graph-copying
8114 -- routine. For now, do a sequential search to find desired node.
8116 if Nkind
(Old_Node
) = N_Handled_Sequence_Of_Statements
8117 and then Present
(First_Real_Statement
(Old_Node
))
8120 Old_F
: constant Node_Id
:= First_Real_Statement
(Old_Node
);
8124 N1
:= First
(Statements
(Old_Node
));
8125 N2
:= First
(Statements
(New_Node
));
8127 while N1
/= Old_F
loop
8132 Set_First_Real_Statement
(New_Node
, N2
);
8137 -- All done, return copied node
8140 end Copy_Node_With_Replacement
;
8146 procedure Visit_Elist
(E
: Elist_Id
) is
8150 Elmt
:= First_Elmt
(E
);
8152 while Elmt
/= No_Elmt
loop
8153 Visit_Node
(Node
(Elmt
));
8163 procedure Visit_Field
(F
: Union_Id
; N
: Node_Id
) is
8165 if F
= Union_Id
(Empty
) then
8168 elsif F
in Node_Range
then
8170 -- Copy node if it is syntactic, i.e. its parent pointer is
8171 -- set to point to the field that referenced it (certain
8172 -- Itypes will also meet this criterion, which is fine, since
8173 -- these are clearly Itypes that do need to be copied, since
8174 -- we are copying their parent.)
8176 if Parent
(Node_Id
(F
)) = N
then
8177 Visit_Node
(Node_Id
(F
));
8180 -- Another case, if we are pointing to an Itype, then we want
8181 -- to copy it if its associated node is somewhere in the tree
8184 -- Note: the exclusion of self-referential copies is just an
8185 -- optimization, since the search of the already copied list
8186 -- would catch it, but it is a common case (Etype pointing
8187 -- to itself for an Itype that is a base type).
8189 elsif Has_Extension
(Node_Id
(F
))
8190 and then Is_Itype
(Entity_Id
(F
))
8191 and then Node_Id
(F
) /= N
8197 P
:= Associated_Node_For_Itype
(Node_Id
(F
));
8198 while Present
(P
) loop
8200 Visit_Node
(Node_Id
(F
));
8207 -- An Itype whose parent is not being copied definitely
8208 -- should NOT be copied, since it does not belong in any
8209 -- sense to the copied subtree.
8215 elsif F
in List_Range
8216 and then Parent
(List_Id
(F
)) = N
8218 Visit_List
(List_Id
(F
));
8227 procedure Visit_Itype
(Old_Itype
: Entity_Id
) is
8228 New_Itype
: Entity_Id
;
8233 -- Itypes that describe the designated type of access to subprograms
8234 -- have the structure of subprogram declarations, with signatures,
8235 -- etc. Either we duplicate the signatures completely, or choose to
8236 -- share such itypes, which is fine because their elaboration will
8237 -- have no side effects.
8239 if Ekind
(Old_Itype
) = E_Subprogram_Type
then
8243 New_Itype
:= New_Copy
(Old_Itype
);
8245 -- The new Itype has all the attributes of the old one, and
8246 -- we just copy the contents of the entity. However, the back-end
8247 -- needs different names for debugging purposes, so we create a
8248 -- new internal name for it in all cases.
8250 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
8252 -- If our associated node is an entity that has already been copied,
8253 -- then set the associated node of the copy to point to the right
8254 -- copy. If we have copied an Itype that is itself the associated
8255 -- node of some previously copied Itype, then we set the right
8256 -- pointer in the other direction.
8258 if Present
(Actual_Map
) then
8260 -- Case of hash tables used
8262 if NCT_Hash_Tables_Used
then
8264 Ent
:= NCT_Assoc
.Get
(Associated_Node_For_Itype
(Old_Itype
));
8266 if Present
(Ent
) then
8267 Set_Associated_Node_For_Itype
(New_Itype
, Ent
);
8270 Ent
:= NCT_Itype_Assoc
.Get
(Old_Itype
);
8271 if Present
(Ent
) then
8272 Set_Associated_Node_For_Itype
(Ent
, New_Itype
);
8274 -- If the hash table has no association for this Itype and
8275 -- its associated node, enter one now.
8279 (Associated_Node_For_Itype
(Old_Itype
), New_Itype
);
8282 -- Case of hash tables not used
8285 E
:= First_Elmt
(Actual_Map
);
8286 while Present
(E
) loop
8287 if Associated_Node_For_Itype
(Old_Itype
) = Node
(E
) then
8288 Set_Associated_Node_For_Itype
8289 (New_Itype
, Node
(Next_Elmt
(E
)));
8292 if Is_Type
(Node
(E
))
8294 Old_Itype
= Associated_Node_For_Itype
(Node
(E
))
8296 Set_Associated_Node_For_Itype
8297 (Node
(Next_Elmt
(E
)), New_Itype
);
8300 E
:= Next_Elmt
(Next_Elmt
(E
));
8305 if Present
(Freeze_Node
(New_Itype
)) then
8306 Set_Is_Frozen
(New_Itype
, False);
8307 Set_Freeze_Node
(New_Itype
, Empty
);
8310 -- Add new association to map
8312 if No
(Actual_Map
) then
8313 Actual_Map
:= New_Elmt_List
;
8316 Append_Elmt
(Old_Itype
, Actual_Map
);
8317 Append_Elmt
(New_Itype
, Actual_Map
);
8319 if NCT_Hash_Tables_Used
then
8320 NCT_Assoc
.Set
(Old_Itype
, New_Itype
);
8323 NCT_Table_Entries
:= NCT_Table_Entries
+ 1;
8325 if NCT_Table_Entries
> NCT_Hash_Threshhold
then
8326 Build_NCT_Hash_Tables
;
8330 -- If a record subtype is simply copied, the entity list will be
8331 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
8333 if Ekind
(Old_Itype
) = E_Record_Subtype
8334 or else Ekind
(Old_Itype
) = E_Class_Wide_Subtype
8336 Set_Cloned_Subtype
(New_Itype
, Old_Itype
);
8339 -- Visit descendents that eventually get copied
8341 Visit_Field
(Union_Id
(Etype
(Old_Itype
)), Old_Itype
);
8343 if Is_Discrete_Type
(Old_Itype
) then
8344 Visit_Field
(Union_Id
(Scalar_Range
(Old_Itype
)), Old_Itype
);
8346 elsif Has_Discriminants
(Base_Type
(Old_Itype
)) then
8347 -- ??? This should involve call to Visit_Field
8348 Visit_Elist
(Discriminant_Constraint
(Old_Itype
));
8350 elsif Is_Array_Type
(Old_Itype
) then
8351 if Present
(First_Index
(Old_Itype
)) then
8352 Visit_Field
(Union_Id
(List_Containing
8353 (First_Index
(Old_Itype
))),
8357 if Is_Packed
(Old_Itype
) then
8358 Visit_Field
(Union_Id
(Packed_Array_Type
(Old_Itype
)),
8368 procedure Visit_List
(L
: List_Id
) is
8371 if L
/= No_List
then
8374 while Present
(N
) loop
8385 procedure Visit_Node
(N
: Node_Or_Entity_Id
) is
8387 -- Start of processing for Visit_Node
8390 -- Handle case of an Itype, which must be copied
8392 if Has_Extension
(N
)
8393 and then Is_Itype
(N
)
8395 -- Nothing to do if already in the list. This can happen with an
8396 -- Itype entity that appears more than once in the tree.
8397 -- Note that we do not want to visit descendents in this case.
8399 -- Test for already in list when hash table is used
8401 if NCT_Hash_Tables_Used
then
8402 if Present
(NCT_Assoc
.Get
(Entity_Id
(N
))) then
8406 -- Test for already in list when hash table not used
8412 if Present
(Actual_Map
) then
8413 E
:= First_Elmt
(Actual_Map
);
8414 while Present
(E
) loop
8415 if Node
(E
) = N
then
8418 E
:= Next_Elmt
(Next_Elmt
(E
));
8428 -- Visit descendents
8430 Visit_Field
(Field1
(N
), N
);
8431 Visit_Field
(Field2
(N
), N
);
8432 Visit_Field
(Field3
(N
), N
);
8433 Visit_Field
(Field4
(N
), N
);
8434 Visit_Field
(Field5
(N
), N
);
8437 -- Start of processing for New_Copy_Tree
8442 -- See if we should use hash table
8444 if No
(Actual_Map
) then
8445 NCT_Hash_Tables_Used
:= False;
8452 NCT_Table_Entries
:= 0;
8454 Elmt
:= First_Elmt
(Actual_Map
);
8455 while Present
(Elmt
) loop
8456 NCT_Table_Entries
:= NCT_Table_Entries
+ 1;
8461 if NCT_Table_Entries
> NCT_Hash_Threshhold
then
8462 Build_NCT_Hash_Tables
;
8464 NCT_Hash_Tables_Used
:= False;
8469 -- Hash table set up if required, now start phase one by visiting
8470 -- top node (we will recursively visit the descendents).
8472 Visit_Node
(Source
);
8474 -- Now the second phase of the copy can start. First we process
8475 -- all the mapped entities, copying their descendents.
8477 if Present
(Actual_Map
) then
8480 New_Itype
: Entity_Id
;
8482 Elmt
:= First_Elmt
(Actual_Map
);
8483 while Present
(Elmt
) loop
8485 New_Itype
:= Node
(Elmt
);
8486 Copy_Itype_With_Replacement
(New_Itype
);
8492 -- Now we can copy the actual tree
8494 return Copy_Node_With_Replacement
(Source
);
8497 -------------------------
8498 -- New_External_Entity --
8499 -------------------------
8501 function New_External_Entity
8502 (Kind
: Entity_Kind
;
8503 Scope_Id
: Entity_Id
;
8504 Sloc_Value
: Source_Ptr
;
8505 Related_Id
: Entity_Id
;
8507 Suffix_Index
: Nat
:= 0;
8508 Prefix
: Character := ' ') return Entity_Id
8510 N
: constant Entity_Id
:=
8511 Make_Defining_Identifier
(Sloc_Value
,
8513 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
8516 Set_Ekind
(N
, Kind
);
8517 Set_Is_Internal
(N
, True);
8518 Append_Entity
(N
, Scope_Id
);
8519 Set_Public_Status
(N
);
8521 if Kind
in Type_Kind
then
8522 Init_Size_Align
(N
);
8526 end New_External_Entity
;
8528 -------------------------
8529 -- New_Internal_Entity --
8530 -------------------------
8532 function New_Internal_Entity
8533 (Kind
: Entity_Kind
;
8534 Scope_Id
: Entity_Id
;
8535 Sloc_Value
: Source_Ptr
;
8536 Id_Char
: Character) return Entity_Id
8538 N
: constant Entity_Id
:=
8539 Make_Defining_Identifier
(Sloc_Value
, New_Internal_Name
(Id_Char
));
8542 Set_Ekind
(N
, Kind
);
8543 Set_Is_Internal
(N
, True);
8544 Append_Entity
(N
, Scope_Id
);
8546 if Kind
in Type_Kind
then
8547 Init_Size_Align
(N
);
8551 end New_Internal_Entity
;
8557 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
8561 -- If we are pointing at a positional parameter, it is a member of a
8562 -- node list (the list of parameters), and the next parameter is the
8563 -- next node on the list, unless we hit a parameter association, then
8564 -- we shift to using the chain whose head is the First_Named_Actual in
8565 -- the parent, and then is threaded using the Next_Named_Actual of the
8566 -- Parameter_Association. All this fiddling is because the original node
8567 -- list is in the textual call order, and what we need is the
8568 -- declaration order.
8570 if Is_List_Member
(Actual_Id
) then
8571 N
:= Next
(Actual_Id
);
8573 if Nkind
(N
) = N_Parameter_Association
then
8574 return First_Named_Actual
(Parent
(Actual_Id
));
8580 return Next_Named_Actual
(Parent
(Actual_Id
));
8584 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
8586 Actual_Id
:= Next_Actual
(Actual_Id
);
8589 -----------------------
8590 -- Normalize_Actuals --
8591 -----------------------
8593 -- Chain actuals according to formals of subprogram. If there are no named
8594 -- associations, the chain is simply the list of Parameter Associations,
8595 -- since the order is the same as the declaration order. If there are named
8596 -- associations, then the First_Named_Actual field in the N_Function_Call
8597 -- or N_Procedure_Call_Statement node points to the Parameter_Association
8598 -- node for the parameter that comes first in declaration order. The
8599 -- remaining named parameters are then chained in declaration order using
8600 -- Next_Named_Actual.
8602 -- This routine also verifies that the number of actuals is compatible with
8603 -- the number and default values of formals, but performs no type checking
8604 -- (type checking is done by the caller).
8606 -- If the matching succeeds, Success is set to True and the caller proceeds
8607 -- with type-checking. If the match is unsuccessful, then Success is set to
8608 -- False, and the caller attempts a different interpretation, if there is
8611 -- If the flag Report is on, the call is not overloaded, and a failure to
8612 -- match can be reported here, rather than in the caller.
8614 procedure Normalize_Actuals
8618 Success
: out Boolean)
8620 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
8621 Actual
: Node_Id
:= Empty
;
8623 Last
: Node_Id
:= Empty
;
8624 First_Named
: Node_Id
:= Empty
;
8627 Formals_To_Match
: Integer := 0;
8628 Actuals_To_Match
: Integer := 0;
8630 procedure Chain
(A
: Node_Id
);
8631 -- Add named actual at the proper place in the list, using the
8632 -- Next_Named_Actual link.
8634 function Reporting
return Boolean;
8635 -- Determines if an error is to be reported. To report an error, we
8636 -- need Report to be True, and also we do not report errors caused
8637 -- by calls to init procs that occur within other init procs. Such
8638 -- errors must always be cascaded errors, since if all the types are
8639 -- declared correctly, the compiler will certainly build decent calls!
8645 procedure Chain
(A
: Node_Id
) is
8649 -- Call node points to first actual in list
8651 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
8654 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
8658 Set_Next_Named_Actual
(Last
, Empty
);
8665 function Reporting
return Boolean is
8670 elsif not Within_Init_Proc
then
8673 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
8681 -- Start of processing for Normalize_Actuals
8684 if Is_Access_Type
(S
) then
8686 -- The name in the call is a function call that returns an access
8687 -- to subprogram. The designated type has the list of formals.
8689 Formal
:= First_Formal
(Designated_Type
(S
));
8691 Formal
:= First_Formal
(S
);
8694 while Present
(Formal
) loop
8695 Formals_To_Match
:= Formals_To_Match
+ 1;
8696 Next_Formal
(Formal
);
8699 -- Find if there is a named association, and verify that no positional
8700 -- associations appear after named ones.
8702 if Present
(Actuals
) then
8703 Actual
:= First
(Actuals
);
8706 while Present
(Actual
)
8707 and then Nkind
(Actual
) /= N_Parameter_Association
8709 Actuals_To_Match
:= Actuals_To_Match
+ 1;
8713 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
8715 -- Most common case: positional notation, no defaults
8720 elsif Actuals_To_Match
> Formals_To_Match
then
8722 -- Too many actuals: will not work
8725 if Is_Entity_Name
(Name
(N
)) then
8726 Error_Msg_N
("too many arguments in call to&", Name
(N
));
8728 Error_Msg_N
("too many arguments in call", N
);
8736 First_Named
:= Actual
;
8738 while Present
(Actual
) loop
8739 if Nkind
(Actual
) /= N_Parameter_Association
then
8741 ("positional parameters not allowed after named ones", Actual
);
8746 Actuals_To_Match
:= Actuals_To_Match
+ 1;
8752 if Present
(Actuals
) then
8753 Actual
:= First
(Actuals
);
8756 Formal
:= First_Formal
(S
);
8757 while Present
(Formal
) loop
8759 -- Match the formals in order. If the corresponding actual is
8760 -- positional, nothing to do. Else scan the list of named actuals
8761 -- to find the one with the right name.
8764 and then Nkind
(Actual
) /= N_Parameter_Association
8767 Actuals_To_Match
:= Actuals_To_Match
- 1;
8768 Formals_To_Match
:= Formals_To_Match
- 1;
8771 -- For named parameters, search the list of actuals to find
8772 -- one that matches the next formal name.
8774 Actual
:= First_Named
;
8776 while Present
(Actual
) loop
8777 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
8780 Actuals_To_Match
:= Actuals_To_Match
- 1;
8781 Formals_To_Match
:= Formals_To_Match
- 1;
8789 if Ekind
(Formal
) /= E_In_Parameter
8790 or else No
(Default_Value
(Formal
))
8793 if (Comes_From_Source
(S
)
8794 or else Sloc
(S
) = Standard_Location
)
8795 and then Is_Overloadable
(S
)
8799 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
8801 (Nkind
(Parent
(N
)) = N_Function_Call
8803 Nkind
(Parent
(N
)) = N_Parameter_Association
))
8804 and then Ekind
(S
) /= E_Function
8806 Set_Etype
(N
, Etype
(S
));
8808 Error_Msg_Name_1
:= Chars
(S
);
8809 Error_Msg_Sloc
:= Sloc
(S
);
8811 ("missing argument for parameter & " &
8812 "in call to % declared #", N
, Formal
);
8815 elsif Is_Overloadable
(S
) then
8816 Error_Msg_Name_1
:= Chars
(S
);
8818 -- Point to type derivation that generated the
8821 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
8824 ("missing argument for parameter & " &
8825 "in call to % (inherited) #", N
, Formal
);
8829 ("missing argument for parameter &", N
, Formal
);
8837 Formals_To_Match
:= Formals_To_Match
- 1;
8842 Next_Formal
(Formal
);
8845 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
8852 -- Find some superfluous named actual that did not get
8853 -- attached to the list of associations.
8855 Actual
:= First
(Actuals
);
8856 while Present
(Actual
) loop
8857 if Nkind
(Actual
) = N_Parameter_Association
8858 and then Actual
/= Last
8859 and then No
(Next_Named_Actual
(Actual
))
8861 Error_Msg_N
("unmatched actual & in call",
8862 Selector_Name
(Actual
));
8873 end Normalize_Actuals
;
8875 --------------------------------
8876 -- Note_Possible_Modification --
8877 --------------------------------
8879 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
8880 Modification_Comes_From_Source
: constant Boolean :=
8881 Comes_From_Source
(Parent
(N
));
8887 -- Loop to find referenced entity, if there is one
8894 if Is_Entity_Name
(Exp
) then
8895 Ent
:= Entity
(Exp
);
8897 -- If the entity is missing, it is an undeclared identifier,
8898 -- and there is nothing to annotate.
8904 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
8906 P
: constant Node_Id
:= Prefix
(Exp
);
8909 if Nkind
(P
) = N_Selected_Component
8911 Entry_Formal
(Entity
(Selector_Name
(P
))))
8913 -- Case of a reference to an entry formal
8915 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
8917 elsif Nkind
(P
) = N_Identifier
8918 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
8919 and then Present
(Expression
(Parent
(Entity
(P
))))
8920 and then Nkind
(Expression
(Parent
(Entity
(P
))))
8923 -- Case of a reference to a value on which side effects have
8926 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
8935 elsif Nkind
(Exp
) = N_Type_Conversion
8936 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
8938 Exp
:= Expression
(Exp
);
8941 elsif Nkind
(Exp
) = N_Slice
8942 or else Nkind
(Exp
) = N_Indexed_Component
8943 or else Nkind
(Exp
) = N_Selected_Component
8945 Exp
:= Prefix
(Exp
);
8952 -- Now look for entity being referenced
8954 if Present
(Ent
) then
8955 if Is_Object
(Ent
) then
8956 if Comes_From_Source
(Exp
)
8957 or else Modification_Comes_From_Source
8959 if Has_Pragma_Unmodified
(Ent
) then
8960 Error_Msg_NE
("?pragma Unmodified given for &!", N
, Ent
);
8963 Set_Never_Set_In_Source
(Ent
, False);
8966 Set_Is_True_Constant
(Ent
, False);
8967 Set_Current_Value
(Ent
, Empty
);
8968 Set_Is_Known_Null
(Ent
, False);
8970 if not Can_Never_Be_Null
(Ent
) then
8971 Set_Is_Known_Non_Null
(Ent
, False);
8974 -- Follow renaming chain
8976 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
8977 and then Present
(Renamed_Object
(Ent
))
8979 Exp
:= Renamed_Object
(Ent
);
8983 -- Generate a reference only if the assignment comes from
8984 -- source. This excludes, for example, calls to a dispatching
8985 -- assignment operation when the left-hand side is tagged.
8987 if Modification_Comes_From_Source
then
8988 Generate_Reference
(Ent
, Exp
, 'm');
8991 Check_Nested_Access
(Ent
);
8996 -- If we are sure this is a modification from source, and we know
8997 -- this modifies a constant, then give an appropriate warning.
8999 if Overlays_Constant
(Ent
)
9000 and then Modification_Comes_From_Source
9004 A
: constant Node_Id
:= Address_Clause
(Ent
);
9008 Exp
: constant Node_Id
:= Expression
(A
);
9010 if Nkind
(Exp
) = N_Attribute_Reference
9011 and then Attribute_Name
(Exp
) = Name_Address
9012 and then Is_Entity_Name
(Prefix
(Exp
))
9014 Error_Msg_Sloc
:= Sloc
(A
);
9016 ("constant& may be modified via address clause#?",
9017 N
, Entity
(Prefix
(Exp
)));
9027 end Note_Possible_Modification
;
9029 -------------------------
9030 -- Object_Access_Level --
9031 -------------------------
9033 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
9036 -- Returns the static accessibility level of the view denoted by Obj. Note
9037 -- that the value returned is the result of a call to Scope_Depth. Only
9038 -- scope depths associated with dynamic scopes can actually be returned.
9039 -- Since only relative levels matter for accessibility checking, the fact
9040 -- that the distance between successive levels of accessibility is not
9041 -- always one is immaterial (invariant: if level(E2) is deeper than
9042 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
9044 function Reference_To
(Obj
: Node_Id
) return Node_Id
;
9045 -- An explicit dereference is created when removing side-effects from
9046 -- expressions for constraint checking purposes. In this case a local
9047 -- access type is created for it. The correct access level is that of
9048 -- the original source node. We detect this case by noting that the
9049 -- prefix of the dereference is created by an object declaration whose
9050 -- initial expression is a reference.
9056 function Reference_To
(Obj
: Node_Id
) return Node_Id
is
9057 Pref
: constant Node_Id
:= Prefix
(Obj
);
9059 if Is_Entity_Name
(Pref
)
9060 and then Nkind
(Parent
(Entity
(Pref
))) = N_Object_Declaration
9061 and then Present
(Expression
(Parent
(Entity
(Pref
))))
9062 and then Nkind
(Expression
(Parent
(Entity
(Pref
)))) = N_Reference
9064 return (Prefix
(Expression
(Parent
(Entity
(Pref
)))));
9070 -- Start of processing for Object_Access_Level
9073 if Is_Entity_Name
(Obj
) then
9076 if Is_Prival
(E
) then
9077 E
:= Prival_Link
(E
);
9080 -- If E is a type then it denotes a current instance. For this case
9081 -- we add one to the normal accessibility level of the type to ensure
9082 -- that current instances are treated as always being deeper than
9083 -- than the level of any visible named access type (see 3.10.2(21)).
9086 return Type_Access_Level
(E
) + 1;
9088 elsif Present
(Renamed_Object
(E
)) then
9089 return Object_Access_Level
(Renamed_Object
(E
));
9091 -- Similarly, if E is a component of the current instance of a
9092 -- protected type, any instance of it is assumed to be at a deeper
9093 -- level than the type. For a protected object (whose type is an
9094 -- anonymous protected type) its components are at the same level
9095 -- as the type itself.
9097 elsif not Is_Overloadable
(E
)
9098 and then Ekind
(Scope
(E
)) = E_Protected_Type
9099 and then Comes_From_Source
(Scope
(E
))
9101 return Type_Access_Level
(Scope
(E
)) + 1;
9104 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
9107 elsif Nkind
(Obj
) = N_Selected_Component
then
9108 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
9109 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9111 return Object_Access_Level
(Prefix
(Obj
));
9114 elsif Nkind
(Obj
) = N_Indexed_Component
then
9115 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
9116 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9118 return Object_Access_Level
(Prefix
(Obj
));
9121 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
9123 -- If the prefix is a selected access discriminant then we make a
9124 -- recursive call on the prefix, which will in turn check the level
9125 -- of the prefix object of the selected discriminant.
9127 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
9128 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
9130 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
9132 return Object_Access_Level
(Prefix
(Obj
));
9134 elsif not (Comes_From_Source
(Obj
)) then
9136 Ref
: constant Node_Id
:= Reference_To
(Obj
);
9138 if Present
(Ref
) then
9139 return Object_Access_Level
(Ref
);
9141 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9146 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9149 elsif Nkind
(Obj
) = N_Type_Conversion
9150 or else Nkind
(Obj
) = N_Unchecked_Type_Conversion
9152 return Object_Access_Level
(Expression
(Obj
));
9154 -- Function results are objects, so we get either the access level of
9155 -- the function or, in the case of an indirect call, the level of the
9156 -- access-to-subprogram type.
9158 elsif Nkind
(Obj
) = N_Function_Call
then
9159 if Is_Entity_Name
(Name
(Obj
)) then
9160 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
9162 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
9165 -- For convenience we handle qualified expressions, even though
9166 -- they aren't technically object names.
9168 elsif Nkind
(Obj
) = N_Qualified_Expression
then
9169 return Object_Access_Level
(Expression
(Obj
));
9171 -- Otherwise return the scope level of Standard.
9172 -- (If there are cases that fall through
9173 -- to this point they will be treated as
9174 -- having global accessibility for now. ???)
9177 return Scope_Depth
(Standard_Standard
);
9179 end Object_Access_Level
;
9181 -----------------------
9182 -- Private_Component --
9183 -----------------------
9185 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
9186 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
9188 function Trace_Components
9190 Check
: Boolean) return Entity_Id
;
9191 -- Recursive function that does the work, and checks against circular
9192 -- definition for each subcomponent type.
9194 ----------------------
9195 -- Trace_Components --
9196 ----------------------
9198 function Trace_Components
9200 Check
: Boolean) return Entity_Id
9202 Btype
: constant Entity_Id
:= Base_Type
(T
);
9203 Component
: Entity_Id
;
9205 Candidate
: Entity_Id
:= Empty
;
9208 if Check
and then Btype
= Ancestor
then
9209 Error_Msg_N
("circular type definition", Type_Id
);
9213 if Is_Private_Type
(Btype
)
9214 and then not Is_Generic_Type
(Btype
)
9216 if Present
(Full_View
(Btype
))
9217 and then Is_Record_Type
(Full_View
(Btype
))
9218 and then not Is_Frozen
(Btype
)
9220 -- To indicate that the ancestor depends on a private type, the
9221 -- current Btype is sufficient. However, to check for circular
9222 -- definition we must recurse on the full view.
9224 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
9226 if Candidate
= Any_Type
then
9236 elsif Is_Array_Type
(Btype
) then
9237 return Trace_Components
(Component_Type
(Btype
), True);
9239 elsif Is_Record_Type
(Btype
) then
9240 Component
:= First_Entity
(Btype
);
9241 while Present
(Component
) loop
9243 -- Skip anonymous types generated by constrained components
9245 if not Is_Type
(Component
) then
9246 P
:= Trace_Components
(Etype
(Component
), True);
9249 if P
= Any_Type
then
9257 Next_Entity
(Component
);
9265 end Trace_Components
;
9267 -- Start of processing for Private_Component
9270 return Trace_Components
(Type_Id
, False);
9271 end Private_Component
;
9273 ---------------------------
9274 -- Primitive_Names_Match --
9275 ---------------------------
9277 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
9279 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
9280 -- Given an internal name, returns the corresponding non-internal name
9282 ------------------------
9283 -- Non_Internal_Name --
9284 ------------------------
9286 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
9288 Get_Name_String
(Chars
(E
));
9289 Name_Len
:= Name_Len
- 1;
9291 end Non_Internal_Name
;
9293 -- Start of processing for Primitive_Names_Match
9296 pragma Assert
(Present
(E1
) and then Present
(E2
));
9298 return Chars
(E1
) = Chars
(E2
)
9300 (not Is_Internal_Name
(Chars
(E1
))
9301 and then Is_Internal_Name
(Chars
(E2
))
9302 and then Non_Internal_Name
(E2
) = Chars
(E1
))
9304 (not Is_Internal_Name
(Chars
(E2
))
9305 and then Is_Internal_Name
(Chars
(E1
))
9306 and then Non_Internal_Name
(E1
) = Chars
(E2
))
9308 (Is_Predefined_Dispatching_Operation
(E1
)
9309 and then Is_Predefined_Dispatching_Operation
(E2
)
9310 and then Same_TSS
(E1
, E2
))
9312 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
9313 end Primitive_Names_Match
;
9315 -----------------------
9316 -- Process_End_Label --
9317 -----------------------
9319 procedure Process_End_Label
9328 Label_Ref
: Boolean;
9329 -- Set True if reference to end label itself is required
9332 -- Gets set to the operator symbol or identifier that references the
9333 -- entity Ent. For the child unit case, this is the identifier from the
9334 -- designator. For other cases, this is simply Endl.
9336 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
9337 -- N is an identifier node that appears as a parent unit reference in
9338 -- the case where Ent is a child unit. This procedure generates an
9339 -- appropriate cross-reference entry. E is the corresponding entity.
9341 -------------------------
9342 -- Generate_Parent_Ref --
9343 -------------------------
9345 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
9347 -- If names do not match, something weird, skip reference
9349 if Chars
(E
) = Chars
(N
) then
9351 -- Generate the reference. We do NOT consider this as a reference
9352 -- for unreferenced symbol purposes.
9354 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
9357 Style
.Check_Identifier
(N
, E
);
9360 end Generate_Parent_Ref
;
9362 -- Start of processing for Process_End_Label
9365 -- If no node, ignore. This happens in some error situations, and
9366 -- also for some internally generated structures where no end label
9367 -- references are required in any case.
9373 -- Nothing to do if no End_Label, happens for internally generated
9374 -- constructs where we don't want an end label reference anyway. Also
9375 -- nothing to do if Endl is a string literal, which means there was
9376 -- some prior error (bad operator symbol)
9378 Endl
:= End_Label
(N
);
9380 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
9384 -- Reference node is not in extended main source unit
9386 if not In_Extended_Main_Source_Unit
(N
) then
9388 -- Generally we do not collect references except for the extended
9389 -- main source unit. The one exception is the 'e' entry for a
9390 -- package spec, where it is useful for a client to have the
9391 -- ending information to define scopes.
9399 -- For this case, we can ignore any parent references, but we
9400 -- need the package name itself for the 'e' entry.
9402 if Nkind
(Endl
) = N_Designator
then
9403 Endl
:= Identifier
(Endl
);
9407 -- Reference is in extended main source unit
9412 -- For designator, generate references for the parent entries
9414 if Nkind
(Endl
) = N_Designator
then
9416 -- Generate references for the prefix if the END line comes from
9417 -- source (otherwise we do not need these references) We climb the
9418 -- scope stack to find the expected entities.
9420 if Comes_From_Source
(Endl
) then
9422 Scop
:= Current_Scope
;
9423 while Nkind
(Nam
) = N_Selected_Component
loop
9424 Scop
:= Scope
(Scop
);
9425 exit when No
(Scop
);
9426 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
9427 Nam
:= Prefix
(Nam
);
9430 if Present
(Scop
) then
9431 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
9435 Endl
:= Identifier
(Endl
);
9439 -- If the end label is not for the given entity, then either we have
9440 -- some previous error, or this is a generic instantiation for which
9441 -- we do not need to make a cross-reference in this case anyway. In
9442 -- either case we simply ignore the call.
9444 if Chars
(Ent
) /= Chars
(Endl
) then
9448 -- If label was really there, then generate a normal reference and then
9449 -- adjust the location in the end label to point past the name (which
9450 -- should almost always be the semicolon).
9454 if Comes_From_Source
(Endl
) then
9456 -- If a label reference is required, then do the style check and
9457 -- generate an l-type cross-reference entry for the label
9461 Style
.Check_Identifier
(Endl
, Ent
);
9464 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
9467 -- Set the location to point past the label (normally this will
9468 -- mean the semicolon immediately following the label). This is
9469 -- done for the sake of the 'e' or 't' entry generated below.
9471 Get_Decoded_Name_String
(Chars
(Endl
));
9472 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
9475 -- Now generate the e/t reference
9477 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
9479 -- Restore Sloc, in case modified above, since we have an identifier
9480 -- and the normal Sloc should be left set in the tree.
9482 Set_Sloc
(Endl
, Loc
);
9483 end Process_End_Label
;
9489 -- We do the conversion to get the value of the real string by using
9490 -- the scanner, see Sinput for details on use of the internal source
9491 -- buffer for scanning internal strings.
9493 function Real_Convert
(S
: String) return Node_Id
is
9494 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
9498 Source
:= Internal_Source_Ptr
;
9501 for J
in S
'Range loop
9502 Source
(Source_Ptr
(J
)) := S
(J
);
9505 Source
(S
'Length + 1) := EOF
;
9507 if Source
(Scan_Ptr
) = '-' then
9509 Scan_Ptr
:= Scan_Ptr
+ 1;
9517 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
9524 ------------------------------------
9525 -- References_Generic_Formal_Type --
9526 ------------------------------------
9528 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
9530 function Process
(N
: Node_Id
) return Traverse_Result
;
9531 -- Process one node in search for generic formal type
9537 function Process
(N
: Node_Id
) return Traverse_Result
is
9539 if Nkind
(N
) in N_Has_Entity
then
9541 E
: constant Entity_Id
:= Entity
(N
);
9544 if Is_Generic_Type
(E
) then
9546 elsif Present
(Etype
(E
))
9547 and then Is_Generic_Type
(Etype
(E
))
9558 function Traverse
is new Traverse_Func
(Process
);
9559 -- Traverse tree to look for generic type
9562 if Inside_A_Generic
then
9563 return Traverse
(N
) = Abandon
;
9567 end References_Generic_Formal_Type
;
9569 --------------------
9570 -- Remove_Homonym --
9571 --------------------
9573 procedure Remove_Homonym
(E
: Entity_Id
) is
9574 Prev
: Entity_Id
:= Empty
;
9578 if E
= Current_Entity
(E
) then
9579 if Present
(Homonym
(E
)) then
9580 Set_Current_Entity
(Homonym
(E
));
9582 Set_Name_Entity_Id
(Chars
(E
), Empty
);
9585 H
:= Current_Entity
(E
);
9586 while Present
(H
) and then H
/= E
loop
9591 Set_Homonym
(Prev
, Homonym
(E
));
9595 ---------------------
9596 -- Rep_To_Pos_Flag --
9597 ---------------------
9599 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
9601 return New_Occurrence_Of
9602 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
9603 end Rep_To_Pos_Flag
;
9605 --------------------
9606 -- Require_Entity --
9607 --------------------
9609 procedure Require_Entity
(N
: Node_Id
) is
9611 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
9612 if Total_Errors_Detected
/= 0 then
9613 Set_Entity
(N
, Any_Id
);
9615 raise Program_Error
;
9620 ------------------------------
9621 -- Requires_Transient_Scope --
9622 ------------------------------
9624 -- A transient scope is required when variable-sized temporaries are
9625 -- allocated in the primary or secondary stack, or when finalization
9626 -- actions must be generated before the next instruction.
9628 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
9629 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
9631 -- Start of processing for Requires_Transient_Scope
9634 -- This is a private type which is not completed yet. This can only
9635 -- happen in a default expression (of a formal parameter or of a
9636 -- record component). Do not expand transient scope in this case
9641 -- Do not expand transient scope for non-existent procedure return
9643 elsif Typ
= Standard_Void_Type
then
9646 -- Elementary types do not require a transient scope
9648 elsif Is_Elementary_Type
(Typ
) then
9651 -- Generally, indefinite subtypes require a transient scope, since the
9652 -- back end cannot generate temporaries, since this is not a valid type
9653 -- for declaring an object. It might be possible to relax this in the
9654 -- future, e.g. by declaring the maximum possible space for the type.
9656 elsif Is_Indefinite_Subtype
(Typ
) then
9659 -- Functions returning tagged types may dispatch on result so their
9660 -- returned value is allocated on the secondary stack. Controlled
9661 -- type temporaries need finalization.
9663 elsif Is_Tagged_Type
(Typ
)
9664 or else Has_Controlled_Component
(Typ
)
9666 return not Is_Value_Type
(Typ
);
9670 elsif Is_Record_Type
(Typ
) then
9674 Comp
:= First_Entity
(Typ
);
9675 while Present
(Comp
) loop
9676 if Ekind
(Comp
) = E_Component
9677 and then Requires_Transient_Scope
(Etype
(Comp
))
9688 -- String literal types never require transient scope
9690 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
9693 -- Array type. Note that we already know that this is a constrained
9694 -- array, since unconstrained arrays will fail the indefinite test.
9696 elsif Is_Array_Type
(Typ
) then
9698 -- If component type requires a transient scope, the array does too
9700 if Requires_Transient_Scope
(Component_Type
(Typ
)) then
9703 -- Otherwise, we only need a transient scope if the size is not
9704 -- known at compile time.
9707 return not Size_Known_At_Compile_Time
(Typ
);
9710 -- All other cases do not require a transient scope
9715 end Requires_Transient_Scope
;
9717 --------------------------
9718 -- Reset_Analyzed_Flags --
9719 --------------------------
9721 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
9723 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
9724 -- Function used to reset Analyzed flags in tree. Note that we do
9725 -- not reset Analyzed flags in entities, since there is no need to
9726 -- reanalyze entities, and indeed, it is wrong to do so, since it
9727 -- can result in generating auxiliary stuff more than once.
9729 --------------------
9730 -- Clear_Analyzed --
9731 --------------------
9733 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
9735 if not Has_Extension
(N
) then
9736 Set_Analyzed
(N
, False);
9742 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
9744 -- Start of processing for Reset_Analyzed_Flags
9748 end Reset_Analyzed_Flags
;
9750 ---------------------------
9751 -- Safe_To_Capture_Value --
9752 ---------------------------
9754 function Safe_To_Capture_Value
9757 Cond
: Boolean := False) return Boolean
9760 -- The only entities for which we track constant values are variables
9761 -- which are not renamings, constants, out parameters, and in out
9762 -- parameters, so check if we have this case.
9764 -- Note: it may seem odd to track constant values for constants, but in
9765 -- fact this routine is used for other purposes than simply capturing
9766 -- the value. In particular, the setting of Known[_Non]_Null.
9768 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
9770 Ekind
(Ent
) = E_Constant
9772 Ekind
(Ent
) = E_Out_Parameter
9774 Ekind
(Ent
) = E_In_Out_Parameter
9778 -- For conditionals, we also allow loop parameters and all formals,
9779 -- including in parameters.
9783 (Ekind
(Ent
) = E_Loop_Parameter
9785 Ekind
(Ent
) = E_In_Parameter
)
9789 -- For all other cases, not just unsafe, but impossible to capture
9790 -- Current_Value, since the above are the only entities which have
9791 -- Current_Value fields.
9797 -- Skip if volatile or aliased, since funny things might be going on in
9798 -- these cases which we cannot necessarily track. Also skip any variable
9799 -- for which an address clause is given, or whose address is taken. Also
9800 -- never capture value of library level variables (an attempt to do so
9801 -- can occur in the case of package elaboration code).
9803 if Treat_As_Volatile
(Ent
)
9804 or else Is_Aliased
(Ent
)
9805 or else Present
(Address_Clause
(Ent
))
9806 or else Address_Taken
(Ent
)
9807 or else (Is_Library_Level_Entity
(Ent
)
9808 and then Ekind
(Ent
) = E_Variable
)
9813 -- OK, all above conditions are met. We also require that the scope of
9814 -- the reference be the same as the scope of the entity, not counting
9815 -- packages and blocks and loops.
9818 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
9819 R_Scope
: Entity_Id
;
9822 R_Scope
:= Current_Scope
;
9823 while R_Scope
/= Standard_Standard
loop
9824 exit when R_Scope
= E_Scope
;
9826 if Ekind
(R_Scope
) /= E_Package
9828 Ekind
(R_Scope
) /= E_Block
9830 Ekind
(R_Scope
) /= E_Loop
9834 R_Scope
:= Scope
(R_Scope
);
9839 -- We also require that the reference does not appear in a context
9840 -- where it is not sure to be executed (i.e. a conditional context
9841 -- or an exception handler). We skip this if Cond is True, since the
9842 -- capturing of values from conditional tests handles this ok.
9856 while Present
(P
) loop
9857 if Nkind
(P
) = N_If_Statement
9858 or else Nkind
(P
) = N_Case_Statement
9859 or else (Nkind
(P
) in N_Short_Circuit
9860 and then Desc
= Right_Opnd
(P
))
9861 or else (Nkind
(P
) = N_Conditional_Expression
9862 and then Desc
/= First
(Expressions
(P
)))
9863 or else Nkind
(P
) = N_Exception_Handler
9864 or else Nkind
(P
) = N_Selective_Accept
9865 or else Nkind
(P
) = N_Conditional_Entry_Call
9866 or else Nkind
(P
) = N_Timed_Entry_Call
9867 or else Nkind
(P
) = N_Asynchronous_Select
9877 -- OK, looks safe to set value
9880 end Safe_To_Capture_Value
;
9886 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
9887 K1
: constant Node_Kind
:= Nkind
(N1
);
9888 K2
: constant Node_Kind
:= Nkind
(N2
);
9891 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
9892 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
9894 return Chars
(N1
) = Chars
(N2
);
9896 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
9897 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
9899 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
9900 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
9911 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
9912 N1
: constant Node_Id
:= Original_Node
(Node1
);
9913 N2
: constant Node_Id
:= Original_Node
(Node2
);
9914 -- We do the tests on original nodes, since we are most interested
9915 -- in the original source, not any expansion that got in the way.
9917 K1
: constant Node_Kind
:= Nkind
(N1
);
9918 K2
: constant Node_Kind
:= Nkind
(N2
);
9921 -- First case, both are entities with same entity
9923 if K1
in N_Has_Entity
9924 and then K2
in N_Has_Entity
9925 and then Present
(Entity
(N1
))
9926 and then Present
(Entity
(N2
))
9927 and then (Ekind
(Entity
(N1
)) = E_Variable
9929 Ekind
(Entity
(N1
)) = E_Constant
)
9930 and then Entity
(N1
) = Entity
(N2
)
9934 -- Second case, selected component with same selector, same record
9936 elsif K1
= N_Selected_Component
9937 and then K2
= N_Selected_Component
9938 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
9940 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
9942 -- Third case, indexed component with same subscripts, same array
9944 elsif K1
= N_Indexed_Component
9945 and then K2
= N_Indexed_Component
9946 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
9951 E1
:= First
(Expressions
(N1
));
9952 E2
:= First
(Expressions
(N2
));
9953 while Present
(E1
) loop
9954 if not Same_Value
(E1
, E2
) then
9965 -- Fourth case, slice of same array with same bounds
9968 and then K2
= N_Slice
9969 and then Nkind
(Discrete_Range
(N1
)) = N_Range
9970 and then Nkind
(Discrete_Range
(N2
)) = N_Range
9971 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
9972 Low_Bound
(Discrete_Range
(N2
)))
9973 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
9974 High_Bound
(Discrete_Range
(N2
)))
9976 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
9978 -- All other cases, not clearly the same object
9989 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
9994 elsif not Is_Constrained
(T1
)
9995 and then not Is_Constrained
(T2
)
9996 and then Base_Type
(T1
) = Base_Type
(T2
)
10000 -- For now don't bother with case of identical constraints, to be
10001 -- fiddled with later on perhaps (this is only used for optimization
10002 -- purposes, so it is not critical to do a best possible job)
10013 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
10015 if Compile_Time_Known_Value
(Node1
)
10016 and then Compile_Time_Known_Value
(Node2
)
10017 and then Expr_Value
(Node1
) = Expr_Value
(Node2
)
10020 elsif Same_Object
(Node1
, Node2
) then
10027 ------------------------
10028 -- Scope_Is_Transient --
10029 ------------------------
10031 function Scope_Is_Transient
return Boolean is
10033 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
10034 end Scope_Is_Transient
;
10040 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
10045 while Scop
/= Standard_Standard
loop
10046 Scop
:= Scope
(Scop
);
10048 if Scop
= Scope2
then
10056 --------------------------
10057 -- Scope_Within_Or_Same --
10058 --------------------------
10060 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
10065 while Scop
/= Standard_Standard
loop
10066 if Scop
= Scope2
then
10069 Scop
:= Scope
(Scop
);
10074 end Scope_Within_Or_Same
;
10076 --------------------
10077 -- Set_Convention --
10078 --------------------
10080 procedure Set_Convention
(E
: Entity_Id
; Val
: Snames
.Convention_Id
) is
10082 Basic_Set_Convention
(E
, Val
);
10085 and then Is_Access_Subprogram_Type
(Base_Type
(E
))
10086 and then Has_Foreign_Convention
(E
)
10088 Set_Can_Use_Internal_Rep
(E
, False);
10090 end Set_Convention
;
10092 ------------------------
10093 -- Set_Current_Entity --
10094 ------------------------
10096 -- The given entity is to be set as the currently visible definition
10097 -- of its associated name (i.e. the Node_Id associated with its name).
10098 -- All we have to do is to get the name from the identifier, and
10099 -- then set the associated Node_Id to point to the given entity.
10101 procedure Set_Current_Entity
(E
: Entity_Id
) is
10103 Set_Name_Entity_Id
(Chars
(E
), E
);
10104 end Set_Current_Entity
;
10106 ---------------------------
10107 -- Set_Debug_Info_Needed --
10108 ---------------------------
10110 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
10112 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
10113 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
10114 -- Used to set debug info in a related node if not set already
10116 --------------------------------------
10117 -- Set_Debug_Info_Needed_If_Not_Set --
10118 --------------------------------------
10120 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
10123 and then not Needs_Debug_Info
(E
)
10125 Set_Debug_Info_Needed
(E
);
10127 -- For a private type, indicate that the full view also needs
10128 -- debug information.
10131 and then Is_Private_Type
(E
)
10132 and then Present
(Full_View
(E
))
10134 Set_Debug_Info_Needed
(Full_View
(E
));
10137 end Set_Debug_Info_Needed_If_Not_Set
;
10139 -- Start of processing for Set_Debug_Info_Needed
10142 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
10143 -- indicates that Debug_Info_Needed is never required for the entity.
10146 or else Debug_Info_Off
(T
)
10151 -- Set flag in entity itself. Note that we will go through the following
10152 -- circuitry even if the flag is already set on T. That's intentional,
10153 -- it makes sure that the flag will be set in subsidiary entities.
10155 Set_Needs_Debug_Info
(T
);
10157 -- Set flag on subsidiary entities if not set already
10159 if Is_Object
(T
) then
10160 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
10162 elsif Is_Type
(T
) then
10163 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
10165 if Is_Record_Type
(T
) then
10167 Ent
: Entity_Id
:= First_Entity
(T
);
10169 while Present
(Ent
) loop
10170 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
10175 elsif Is_Array_Type
(T
) then
10176 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
10179 Indx
: Node_Id
:= First_Index
(T
);
10181 while Present
(Indx
) loop
10182 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
10183 Indx
:= Next_Index
(Indx
);
10187 if Is_Packed
(T
) then
10188 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Type
(T
));
10191 elsif Is_Access_Type
(T
) then
10192 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
10194 elsif Is_Private_Type
(T
) then
10195 Set_Debug_Info_Needed_If_Not_Set
(Full_View
(T
));
10197 elsif Is_Protected_Type
(T
) then
10198 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
10201 end Set_Debug_Info_Needed
;
10203 ---------------------------------
10204 -- Set_Entity_With_Style_Check --
10205 ---------------------------------
10207 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
10208 Val_Actual
: Entity_Id
;
10212 Set_Entity
(N
, Val
);
10215 and then not Suppress_Style_Checks
(Val
)
10216 and then not In_Instance
10218 if Nkind
(N
) = N_Identifier
then
10220 elsif Nkind
(N
) = N_Expanded_Name
then
10221 Nod
:= Selector_Name
(N
);
10226 -- A special situation arises for derived operations, where we want
10227 -- to do the check against the parent (since the Sloc of the derived
10228 -- operation points to the derived type declaration itself).
10231 while not Comes_From_Source
(Val_Actual
)
10232 and then Nkind
(Val_Actual
) in N_Entity
10233 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
10234 or else Is_Subprogram
(Val_Actual
)
10235 or else Is_Generic_Subprogram
(Val_Actual
))
10236 and then Present
(Alias
(Val_Actual
))
10238 Val_Actual
:= Alias
(Val_Actual
);
10241 -- Renaming declarations for generic actuals do not come from source,
10242 -- and have a different name from that of the entity they rename, so
10243 -- there is no style check to perform here.
10245 if Chars
(Nod
) = Chars
(Val_Actual
) then
10246 Style
.Check_Identifier
(Nod
, Val_Actual
);
10250 Set_Entity
(N
, Val
);
10251 end Set_Entity_With_Style_Check
;
10253 ------------------------
10254 -- Set_Name_Entity_Id --
10255 ------------------------
10257 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
10259 Set_Name_Table_Info
(Id
, Int
(Val
));
10260 end Set_Name_Entity_Id
;
10262 ---------------------
10263 -- Set_Next_Actual --
10264 ---------------------
10266 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
10268 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
10269 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
10271 end Set_Next_Actual
;
10273 ----------------------------------
10274 -- Set_Optimize_Alignment_Flags --
10275 ----------------------------------
10277 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
10279 if Optimize_Alignment
= 'S' then
10280 Set_Optimize_Alignment_Space
(E
);
10281 elsif Optimize_Alignment
= 'T' then
10282 Set_Optimize_Alignment_Time
(E
);
10284 end Set_Optimize_Alignment_Flags
;
10286 -----------------------
10287 -- Set_Public_Status --
10288 -----------------------
10290 procedure Set_Public_Status
(Id
: Entity_Id
) is
10291 S
: constant Entity_Id
:= Current_Scope
;
10293 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
10294 -- Determines if E is defined within handled statement sequence or
10295 -- an if statement, returns True if so, False otherwise.
10297 ----------------------
10298 -- Within_HSS_Or_If --
10299 ----------------------
10301 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
10304 N
:= Declaration_Node
(E
);
10311 elsif Nkind_In
(N
, N_Handled_Sequence_Of_Statements
,
10317 end Within_HSS_Or_If
;
10319 -- Start of processing for Set_Public_Status
10322 -- Everything in the scope of Standard is public
10324 if S
= Standard_Standard
then
10325 Set_Is_Public
(Id
);
10327 -- Entity is definitely not public if enclosing scope is not public
10329 elsif not Is_Public
(S
) then
10332 -- An object or function declaration that occurs in a handled sequence
10333 -- of statements or within an if statement is the declaration for a
10334 -- temporary object or local subprogram generated by the expander. It
10335 -- never needs to be made public and furthermore, making it public can
10336 -- cause back end problems.
10338 elsif Nkind_In
(Parent
(Id
), N_Object_Declaration
,
10339 N_Function_Specification
)
10340 and then Within_HSS_Or_If
(Id
)
10344 -- Entities in public packages or records are public
10346 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
10347 Set_Is_Public
(Id
);
10349 -- The bounds of an entry family declaration can generate object
10350 -- declarations that are visible to the back-end, e.g. in the
10351 -- the declaration of a composite type that contains tasks.
10353 elsif Is_Concurrent_Type
(S
)
10354 and then not Has_Completion
(S
)
10355 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
10357 Set_Is_Public
(Id
);
10359 end Set_Public_Status
;
10361 -----------------------------
10362 -- Set_Referenced_Modified --
10363 -----------------------------
10365 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
10369 -- Deal with indexed or selected component where prefix is modified
10371 if Nkind
(N
) = N_Indexed_Component
10373 Nkind
(N
) = N_Selected_Component
10375 Pref
:= Prefix
(N
);
10377 -- If prefix is access type, then it is the designated object that is
10378 -- being modified, which means we have no entity to set the flag on.
10380 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
10383 -- Otherwise chase the prefix
10386 Set_Referenced_Modified
(Pref
, Out_Param
);
10389 -- Otherwise see if we have an entity name (only other case to process)
10391 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
10392 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
10393 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
10395 end Set_Referenced_Modified
;
10397 ----------------------------
10398 -- Set_Scope_Is_Transient --
10399 ----------------------------
10401 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
10403 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
10404 end Set_Scope_Is_Transient
;
10406 -------------------
10407 -- Set_Size_Info --
10408 -------------------
10410 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
10412 -- We copy Esize, but not RM_Size, since in general RM_Size is
10413 -- subtype specific and does not get inherited by all subtypes.
10415 Set_Esize
(T1
, Esize
(T2
));
10416 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
10418 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
10420 Is_Discrete_Or_Fixed_Point_Type
(T2
)
10422 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
10425 Set_Alignment
(T1
, Alignment
(T2
));
10428 --------------------
10429 -- Static_Integer --
10430 --------------------
10432 function Static_Integer
(N
: Node_Id
) return Uint
is
10434 Analyze_And_Resolve
(N
, Any_Integer
);
10437 or else Error_Posted
(N
)
10438 or else Etype
(N
) = Any_Type
10443 if Is_Static_Expression
(N
) then
10444 if not Raises_Constraint_Error
(N
) then
10445 return Expr_Value
(N
);
10450 elsif Etype
(N
) = Any_Type
then
10454 Flag_Non_Static_Expr
10455 ("static integer expression required here", N
);
10458 end Static_Integer
;
10460 --------------------------
10461 -- Statically_Different --
10462 --------------------------
10464 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
10465 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
10466 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
10468 return Is_Entity_Name
(R1
)
10469 and then Is_Entity_Name
(R2
)
10470 and then Entity
(R1
) /= Entity
(R2
)
10471 and then not Is_Formal
(Entity
(R1
))
10472 and then not Is_Formal
(Entity
(R2
));
10473 end Statically_Different
;
10475 -----------------------------
10476 -- Subprogram_Access_Level --
10477 -----------------------------
10479 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
10481 if Present
(Alias
(Subp
)) then
10482 return Subprogram_Access_Level
(Alias
(Subp
));
10484 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
10486 end Subprogram_Access_Level
;
10492 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
10494 if Debug_Flag_W
then
10495 for J
in 0 .. Scope_Stack
.Last
loop
10500 Write_Name
(Chars
(E
));
10501 Write_Str
(" from ");
10502 Write_Location
(Sloc
(N
));
10507 -----------------------
10508 -- Transfer_Entities --
10509 -----------------------
10511 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
10512 Ent
: Entity_Id
:= First_Entity
(From
);
10519 if (Last_Entity
(To
)) = Empty
then
10520 Set_First_Entity
(To
, Ent
);
10522 Set_Next_Entity
(Last_Entity
(To
), Ent
);
10525 Set_Last_Entity
(To
, Last_Entity
(From
));
10527 while Present
(Ent
) loop
10528 Set_Scope
(Ent
, To
);
10530 if not Is_Public
(Ent
) then
10531 Set_Public_Status
(Ent
);
10534 and then Ekind
(Ent
) = E_Record_Subtype
10537 -- The components of the propagated Itype must be public
10543 Comp
:= First_Entity
(Ent
);
10544 while Present
(Comp
) loop
10545 Set_Is_Public
(Comp
);
10546 Next_Entity
(Comp
);
10555 Set_First_Entity
(From
, Empty
);
10556 Set_Last_Entity
(From
, Empty
);
10557 end Transfer_Entities
;
10559 -----------------------
10560 -- Type_Access_Level --
10561 -----------------------
10563 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
10567 Btyp
:= Base_Type
(Typ
);
10569 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
10570 -- simply use the level where the type is declared. This is true for
10571 -- stand-alone object declarations, and for anonymous access types
10572 -- associated with components the level is the same as that of the
10573 -- enclosing composite type. However, special treatment is needed for
10574 -- the cases of access parameters, return objects of an anonymous access
10575 -- type, and, in Ada 95, access discriminants of limited types.
10577 if Ekind
(Btyp
) in Access_Kind
then
10578 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
10580 -- If the type is a nonlocal anonymous access type (such as for
10581 -- an access parameter) we treat it as being declared at the
10582 -- library level to ensure that names such as X.all'access don't
10583 -- fail static accessibility checks.
10585 if not Is_Local_Anonymous_Access
(Typ
) then
10586 return Scope_Depth
(Standard_Standard
);
10588 -- If this is a return object, the accessibility level is that of
10589 -- the result subtype of the enclosing function. The test here is
10590 -- little complicated, because we have to account for extended
10591 -- return statements that have been rewritten as blocks, in which
10592 -- case we have to find and the Is_Return_Object attribute of the
10593 -- itype's associated object. It would be nice to find a way to
10594 -- simplify this test, but it doesn't seem worthwhile to add a new
10595 -- flag just for purposes of this test. ???
10597 elsif Ekind
(Scope
(Btyp
)) = E_Return_Statement
10600 and then Nkind
(Associated_Node_For_Itype
(Btyp
)) =
10601 N_Object_Declaration
10602 and then Is_Return_Object
10603 (Defining_Identifier
10604 (Associated_Node_For_Itype
(Btyp
))))
10610 Scop
:= Scope
(Scope
(Btyp
));
10611 while Present
(Scop
) loop
10612 exit when Ekind
(Scop
) = E_Function
;
10613 Scop
:= Scope
(Scop
);
10616 -- Treat the return object's type as having the level of the
10617 -- function's result subtype (as per RM05-6.5(5.3/2)).
10619 return Type_Access_Level
(Etype
(Scop
));
10624 Btyp
:= Root_Type
(Btyp
);
10626 -- The accessibility level of anonymous access types associated with
10627 -- discriminants is that of the current instance of the type, and
10628 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
10630 -- AI-402: access discriminants have accessibility based on the
10631 -- object rather than the type in Ada 2005, so the above paragraph
10634 -- ??? Needs completion with rules from AI-416
10636 if Ada_Version
<= Ada_95
10637 and then Ekind
(Typ
) = E_Anonymous_Access_Type
10638 and then Present
(Associated_Node_For_Itype
(Typ
))
10639 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
10640 N_Discriminant_Specification
10642 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
10646 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
10647 end Type_Access_Level
;
10649 --------------------
10650 -- Ultimate_Alias --
10651 --------------------
10652 -- To do: add occurrences calling this new subprogram
10654 function Ultimate_Alias
(Prim
: Entity_Id
) return Entity_Id
is
10655 E
: Entity_Id
:= Prim
;
10658 while Present
(Alias
(E
)) loop
10663 end Ultimate_Alias
;
10665 --------------------------
10666 -- Unit_Declaration_Node --
10667 --------------------------
10669 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
10670 N
: Node_Id
:= Parent
(Unit_Id
);
10673 -- Predefined operators do not have a full function declaration
10675 if Ekind
(Unit_Id
) = E_Operator
then
10679 -- Isn't there some better way to express the following ???
10681 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
10682 and then Nkind
(N
) /= N_Formal_Package_Declaration
10683 and then Nkind
(N
) /= N_Function_Instantiation
10684 and then Nkind
(N
) /= N_Generic_Package_Declaration
10685 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
10686 and then Nkind
(N
) /= N_Package_Declaration
10687 and then Nkind
(N
) /= N_Package_Body
10688 and then Nkind
(N
) /= N_Package_Instantiation
10689 and then Nkind
(N
) /= N_Package_Renaming_Declaration
10690 and then Nkind
(N
) /= N_Procedure_Instantiation
10691 and then Nkind
(N
) /= N_Protected_Body
10692 and then Nkind
(N
) /= N_Subprogram_Declaration
10693 and then Nkind
(N
) /= N_Subprogram_Body
10694 and then Nkind
(N
) /= N_Subprogram_Body_Stub
10695 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
10696 and then Nkind
(N
) /= N_Task_Body
10697 and then Nkind
(N
) /= N_Task_Type_Declaration
10698 and then Nkind
(N
) not in N_Formal_Subprogram_Declaration
10699 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
10702 pragma Assert
(Present
(N
));
10706 end Unit_Declaration_Node
;
10708 ------------------------------
10709 -- Universal_Interpretation --
10710 ------------------------------
10712 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
10713 Index
: Interp_Index
;
10717 -- The argument may be a formal parameter of an operator or subprogram
10718 -- with multiple interpretations, or else an expression for an actual.
10720 if Nkind
(Opnd
) = N_Defining_Identifier
10721 or else not Is_Overloaded
(Opnd
)
10723 if Etype
(Opnd
) = Universal_Integer
10724 or else Etype
(Opnd
) = Universal_Real
10726 return Etype
(Opnd
);
10732 Get_First_Interp
(Opnd
, Index
, It
);
10733 while Present
(It
.Typ
) loop
10734 if It
.Typ
= Universal_Integer
10735 or else It
.Typ
= Universal_Real
10740 Get_Next_Interp
(Index
, It
);
10745 end Universal_Interpretation
;
10751 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
10753 -- Recurse to handle unlikely case of multiple levels of qualification
10755 if Nkind
(Expr
) = N_Qualified_Expression
then
10756 return Unqualify
(Expression
(Expr
));
10758 -- Normal case, not a qualified expression
10765 ----------------------
10766 -- Within_Init_Proc --
10767 ----------------------
10769 function Within_Init_Proc
return Boolean is
10773 S
:= Current_Scope
;
10774 while not Is_Overloadable
(S
) loop
10775 if S
= Standard_Standard
then
10782 return Is_Init_Proc
(S
);
10783 end Within_Init_Proc
;
10789 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
10790 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
10791 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
10793 function Has_One_Matching_Field
return Boolean;
10794 -- Determines if Expec_Type is a record type with a single component or
10795 -- discriminant whose type matches the found type or is one dimensional
10796 -- array whose component type matches the found type.
10798 ----------------------------
10799 -- Has_One_Matching_Field --
10800 ----------------------------
10802 function Has_One_Matching_Field
return Boolean is
10806 if Is_Array_Type
(Expec_Type
)
10807 and then Number_Dimensions
(Expec_Type
) = 1
10809 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
10813 elsif not Is_Record_Type
(Expec_Type
) then
10817 E
:= First_Entity
(Expec_Type
);
10822 elsif (Ekind
(E
) /= E_Discriminant
10823 and then Ekind
(E
) /= E_Component
)
10824 or else (Chars
(E
) = Name_uTag
10825 or else Chars
(E
) = Name_uParent
)
10834 if not Covers
(Etype
(E
), Found_Type
) then
10837 elsif Present
(Next_Entity
(E
)) then
10844 end Has_One_Matching_Field
;
10846 -- Start of processing for Wrong_Type
10849 -- Don't output message if either type is Any_Type, or if a message
10850 -- has already been posted for this node. We need to do the latter
10851 -- check explicitly (it is ordinarily done in Errout), because we
10852 -- are using ! to force the output of the error messages.
10854 if Expec_Type
= Any_Type
10855 or else Found_Type
= Any_Type
10856 or else Error_Posted
(Expr
)
10860 -- In an instance, there is an ongoing problem with completion of
10861 -- type derived from private types. Their structure is what Gigi
10862 -- expects, but the Etype is the parent type rather than the
10863 -- derived private type itself. Do not flag error in this case. The
10864 -- private completion is an entity without a parent, like an Itype.
10865 -- Similarly, full and partial views may be incorrect in the instance.
10866 -- There is no simple way to insure that it is consistent ???
10868 elsif In_Instance
then
10869 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
10871 (Has_Private_Declaration
(Expected_Type
)
10872 or else Has_Private_Declaration
(Etype
(Expr
)))
10873 and then No
(Parent
(Expected_Type
))
10879 -- An interesting special check. If the expression is parenthesized
10880 -- and its type corresponds to the type of the sole component of the
10881 -- expected record type, or to the component type of the expected one
10882 -- dimensional array type, then assume we have a bad aggregate attempt.
10884 if Nkind
(Expr
) in N_Subexpr
10885 and then Paren_Count
(Expr
) /= 0
10886 and then Has_One_Matching_Field
10888 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
10890 -- Another special check, if we are looking for a pool-specific access
10891 -- type and we found an E_Access_Attribute_Type, then we have the case
10892 -- of an Access attribute being used in a context which needs a pool-
10893 -- specific type, which is never allowed. The one extra check we make
10894 -- is that the expected designated type covers the Found_Type.
10896 elsif Is_Access_Type
(Expec_Type
)
10897 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
10898 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
10899 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
10901 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
10903 Error_Msg_N
("result must be general access type!", Expr
);
10904 Error_Msg_NE
("add ALL to }!", Expr
, Expec_Type
);
10906 -- Another special check, if the expected type is an integer type,
10907 -- but the expression is of type System.Address, and the parent is
10908 -- an addition or subtraction operation whose left operand is the
10909 -- expression in question and whose right operand is of an integral
10910 -- type, then this is an attempt at address arithmetic, so give
10911 -- appropriate message.
10913 elsif Is_Integer_Type
(Expec_Type
)
10914 and then Is_RTE
(Found_Type
, RE_Address
)
10915 and then (Nkind
(Parent
(Expr
)) = N_Op_Add
10917 Nkind
(Parent
(Expr
)) = N_Op_Subtract
)
10918 and then Expr
= Left_Opnd
(Parent
(Expr
))
10919 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
10922 ("address arithmetic not predefined in package System",
10925 ("\possible missing with/use of System.Storage_Elements",
10929 -- If the expected type is an anonymous access type, as for access
10930 -- parameters and discriminants, the error is on the designated types.
10932 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
10933 if Comes_From_Source
(Expec_Type
) then
10934 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
10937 ("expected an access type with designated}",
10938 Expr
, Designated_Type
(Expec_Type
));
10941 if Is_Access_Type
(Found_Type
)
10942 and then not Comes_From_Source
(Found_Type
)
10945 ("\\found an access type with designated}!",
10946 Expr
, Designated_Type
(Found_Type
));
10948 if From_With_Type
(Found_Type
) then
10949 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
10950 Error_Msg_Qual_Level
:= 99;
10951 Error_Msg_NE
("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
10952 Error_Msg_Qual_Level
:= 0;
10954 Error_Msg_NE
("found}!", Expr
, Found_Type
);
10958 -- Normal case of one type found, some other type expected
10961 -- If the names of the two types are the same, see if some number
10962 -- of levels of qualification will help. Don't try more than three
10963 -- levels, and if we get to standard, it's no use (and probably
10964 -- represents an error in the compiler) Also do not bother with
10965 -- internal scope names.
10968 Expec_Scope
: Entity_Id
;
10969 Found_Scope
: Entity_Id
;
10972 Expec_Scope
:= Expec_Type
;
10973 Found_Scope
:= Found_Type
;
10975 for Levels
in Int
range 0 .. 3 loop
10976 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
10977 Error_Msg_Qual_Level
:= Levels
;
10981 Expec_Scope
:= Scope
(Expec_Scope
);
10982 Found_Scope
:= Scope
(Found_Scope
);
10984 exit when Expec_Scope
= Standard_Standard
10985 or else Found_Scope
= Standard_Standard
10986 or else not Comes_From_Source
(Expec_Scope
)
10987 or else not Comes_From_Source
(Found_Scope
);
10991 if Is_Record_Type
(Expec_Type
)
10992 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
10994 Error_Msg_NE
("expected}!", Expr
,
10995 Corresponding_Remote_Type
(Expec_Type
));
10997 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
11000 if Is_Entity_Name
(Expr
)
11001 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
11003 Error_Msg_N
("\\found package name!", Expr
);
11005 elsif Is_Entity_Name
(Expr
)
11007 (Ekind
(Entity
(Expr
)) = E_Procedure
11009 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
11011 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
11013 ("found procedure name, possibly missing Access attribute!",
11017 ("\\found procedure name instead of function!", Expr
);
11020 elsif Nkind
(Expr
) = N_Function_Call
11021 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
11022 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
11023 and then No
(Parameter_Associations
(Expr
))
11026 ("found function name, possibly missing Access attribute!",
11029 -- Catch common error: a prefix or infix operator which is not
11030 -- directly visible because the type isn't.
11032 elsif Nkind
(Expr
) in N_Op
11033 and then Is_Overloaded
(Expr
)
11034 and then not Is_Immediately_Visible
(Expec_Type
)
11035 and then not Is_Potentially_Use_Visible
(Expec_Type
)
11036 and then not In_Use
(Expec_Type
)
11037 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
11040 ("operator of the type is not directly visible!", Expr
);
11042 elsif Ekind
(Found_Type
) = E_Void
11043 and then Present
(Parent
(Found_Type
))
11044 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
11046 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
11049 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
11052 Error_Msg_Qual_Level
:= 0;