1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Errout
; use Errout
;
32 with Elists
; use Elists
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Exp_Util
; use Exp_Util
;
35 with Fname
; use Fname
;
36 with Freeze
; use Freeze
;
38 with Lib
.Xref
; use Lib
.Xref
;
39 with Namet
; use Namet
;
40 with Nlists
; use Nlists
;
41 with Nmake
; use Nmake
;
42 with Output
; use Output
;
44 with Rtsfind
; use Rtsfind
;
45 with Scans
; use Scans
;
48 with Sem_Ch8
; use Sem_Ch8
;
49 with Sem_Eval
; use Sem_Eval
;
50 with Sem_Res
; use Sem_Res
;
51 with Sem_Type
; use Sem_Type
;
52 with Sinfo
; use Sinfo
;
53 with Sinput
; use Sinput
;
54 with Snames
; use Snames
;
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
;
62 package body Sem_Util
is
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 function Build_Component_Subtype
71 T
: Entity_Id
) return Node_Id
;
72 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
73 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
74 -- Loc is the source location, T is the original subtype.
76 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
77 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
78 -- with discriminants whose default values are static, examine only the
79 -- components in the selected variant to determine whether all of them
82 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
83 -- T is a derived tagged type. Check whether the type extension is null.
84 -- If the parent type is fully initialized, T can be treated as such.
86 --------------------------------
87 -- Add_Access_Type_To_Process --
88 --------------------------------
90 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
94 Ensure_Freeze_Node
(E
);
95 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
99 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
103 end Add_Access_Type_To_Process
;
105 -----------------------
106 -- Alignment_In_Bits --
107 -----------------------
109 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
111 return Alignment
(E
) * System_Storage_Unit
;
112 end Alignment_In_Bits
;
114 -----------------------------------------
115 -- Apply_Compile_Time_Constraint_Error --
116 -----------------------------------------
118 procedure Apply_Compile_Time_Constraint_Error
121 Reason
: RT_Exception_Code
;
122 Ent
: Entity_Id
:= Empty
;
123 Typ
: Entity_Id
:= Empty
;
124 Loc
: Source_Ptr
:= No_Location
;
125 Rep
: Boolean := True;
126 Warn
: Boolean := False)
128 Stat
: constant Boolean := Is_Static_Expression
(N
);
139 Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
145 -- Now we replace the node by an N_Raise_Constraint_Error node
146 -- This does not need reanalyzing, so set it as analyzed now.
149 Make_Raise_Constraint_Error
(Sloc
(N
),
151 Set_Analyzed
(N
, True);
153 Set_Raises_Constraint_Error
(N
);
155 -- If the original expression was marked as static, the result is
156 -- still marked as static, but the Raises_Constraint_Error flag is
157 -- always set so that further static evaluation is not attempted.
160 Set_Is_Static_Expression
(N
);
162 end Apply_Compile_Time_Constraint_Error
;
164 --------------------------
165 -- Build_Actual_Subtype --
166 --------------------------
168 function Build_Actual_Subtype
170 N
: Node_Or_Entity_Id
) return Node_Id
174 Loc
: constant Source_Ptr
:= Sloc
(N
);
175 Constraints
: List_Id
;
181 Disc_Type
: Entity_Id
;
184 if Nkind
(N
) = N_Defining_Identifier
then
185 Obj
:= New_Reference_To
(N
, Loc
);
190 if Is_Array_Type
(T
) then
191 Constraints
:= New_List
;
193 for J
in 1 .. Number_Dimensions
(T
) loop
195 -- Build an array subtype declaration with the nominal
196 -- subtype and the bounds of the actual. Add the declaration
197 -- in front of the local declarations for the subprogram, for
198 -- analysis before any reference to the formal in the body.
201 Make_Attribute_Reference
(Loc
,
203 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
204 Attribute_Name
=> Name_First
,
205 Expressions
=> New_List
(
206 Make_Integer_Literal
(Loc
, J
)));
209 Make_Attribute_Reference
(Loc
,
211 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
212 Attribute_Name
=> Name_Last
,
213 Expressions
=> New_List
(
214 Make_Integer_Literal
(Loc
, J
)));
216 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
219 -- If the type has unknown discriminants there is no constrained
220 -- subtype to build. This is never called for a formal or for a
221 -- lhs, so returning the type is ok ???
223 elsif Has_Unknown_Discriminants
(T
) then
227 Constraints
:= New_List
;
229 if Is_Private_Type
(T
) and then No
(Full_View
(T
)) then
231 -- Type is a generic derived type. Inherit discriminants from
234 Disc_Type
:= Etype
(Base_Type
(T
));
239 Discr
:= First_Discriminant
(Disc_Type
);
241 while Present
(Discr
) loop
242 Append_To
(Constraints
,
243 Make_Selected_Component
(Loc
,
245 Duplicate_Subexpr_No_Checks
(Obj
),
246 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
247 Next_Discriminant
(Discr
);
252 Make_Defining_Identifier
(Loc
,
253 Chars
=> New_Internal_Name
('S'));
254 Set_Is_Internal
(Subt
);
257 Make_Subtype_Declaration
(Loc
,
258 Defining_Identifier
=> Subt
,
259 Subtype_Indication
=>
260 Make_Subtype_Indication
(Loc
,
261 Subtype_Mark
=> New_Reference_To
(T
, Loc
),
263 Make_Index_Or_Discriminant_Constraint
(Loc
,
264 Constraints
=> Constraints
)));
266 Mark_Rewrite_Insertion
(Decl
);
268 end Build_Actual_Subtype
;
270 ---------------------------------------
271 -- Build_Actual_Subtype_Of_Component --
272 ---------------------------------------
274 function Build_Actual_Subtype_Of_Component
276 N
: Node_Id
) return Node_Id
278 Loc
: constant Source_Ptr
:= Sloc
(N
);
279 P
: constant Node_Id
:= Prefix
(N
);
282 Indx_Type
: Entity_Id
;
284 Deaccessed_T
: Entity_Id
;
285 -- This is either a copy of T, or if T is an access type, then it is
286 -- the directly designated type of this access type.
288 function Build_Actual_Array_Constraint
return List_Id
;
289 -- If one or more of the bounds of the component depends on
290 -- discriminants, build actual constraint using the discriminants
293 function Build_Actual_Record_Constraint
return List_Id
;
294 -- Similar to previous one, for discriminated components constrained
295 -- by the discriminant of the enclosing object.
297 -----------------------------------
298 -- Build_Actual_Array_Constraint --
299 -----------------------------------
301 function Build_Actual_Array_Constraint
return List_Id
is
302 Constraints
: constant List_Id
:= New_List
;
310 Indx
:= First_Index
(Deaccessed_T
);
311 while Present
(Indx
) loop
312 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
313 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
315 if Denotes_Discriminant
(Old_Lo
) then
317 Make_Selected_Component
(Loc
,
318 Prefix
=> New_Copy_Tree
(P
),
319 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
322 Lo
:= New_Copy_Tree
(Old_Lo
);
324 -- The new bound will be reanalyzed in the enclosing
325 -- declaration. For literal bounds that come from a type
326 -- declaration, the type of the context must be imposed, so
327 -- insure that analysis will take place. For non-universal
328 -- types this is not strictly necessary.
330 Set_Analyzed
(Lo
, False);
333 if Denotes_Discriminant
(Old_Hi
) then
335 Make_Selected_Component
(Loc
,
336 Prefix
=> New_Copy_Tree
(P
),
337 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
340 Hi
:= New_Copy_Tree
(Old_Hi
);
341 Set_Analyzed
(Hi
, False);
344 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
349 end Build_Actual_Array_Constraint
;
351 ------------------------------------
352 -- Build_Actual_Record_Constraint --
353 ------------------------------------
355 function Build_Actual_Record_Constraint
return List_Id
is
356 Constraints
: constant List_Id
:= New_List
;
361 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
362 while Present
(D
) loop
364 if Denotes_Discriminant
(Node
(D
)) then
365 D_Val
:= Make_Selected_Component
(Loc
,
366 Prefix
=> New_Copy_Tree
(P
),
367 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
370 D_Val
:= New_Copy_Tree
(Node
(D
));
373 Append
(D_Val
, Constraints
);
378 end Build_Actual_Record_Constraint
;
380 -- Start of processing for Build_Actual_Subtype_Of_Component
383 if In_Default_Expression
then
386 elsif Nkind
(N
) = N_Explicit_Dereference
then
387 if Is_Composite_Type
(T
)
388 and then not Is_Constrained
(T
)
389 and then not (Is_Class_Wide_Type
(T
)
390 and then Is_Constrained
(Root_Type
(T
)))
391 and then not Has_Unknown_Discriminants
(T
)
393 -- If the type of the dereference is already constrained, it
394 -- is an actual subtype.
396 if Is_Array_Type
(Etype
(N
))
397 and then Is_Constrained
(Etype
(N
))
401 Remove_Side_Effects
(P
);
402 return Build_Actual_Subtype
(T
, N
);
409 if Ekind
(T
) = E_Access_Subtype
then
410 Deaccessed_T
:= Designated_Type
(T
);
415 if Ekind
(Deaccessed_T
) = E_Array_Subtype
then
416 Id
:= First_Index
(Deaccessed_T
);
417 Indx_Type
:= Underlying_Type
(Etype
(Id
));
419 while Present
(Id
) loop
421 if Denotes_Discriminant
(Type_Low_Bound
(Indx_Type
)) or else
422 Denotes_Discriminant
(Type_High_Bound
(Indx_Type
))
424 Remove_Side_Effects
(P
);
426 Build_Component_Subtype
(
427 Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
433 elsif Is_Composite_Type
(Deaccessed_T
)
434 and then Has_Discriminants
(Deaccessed_T
)
435 and then not Has_Unknown_Discriminants
(Deaccessed_T
)
437 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
438 while Present
(D
) loop
440 if Denotes_Discriminant
(Node
(D
)) then
441 Remove_Side_Effects
(P
);
443 Build_Component_Subtype
(
444 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
451 -- If none of the above, the actual and nominal subtypes are the same.
454 end Build_Actual_Subtype_Of_Component
;
456 -----------------------------
457 -- Build_Component_Subtype --
458 -----------------------------
460 function Build_Component_Subtype
463 T
: Entity_Id
) return Node_Id
469 -- Unchecked_Union components do not require component subtypes
471 if Is_Unchecked_Union
(T
) then
476 Make_Defining_Identifier
(Loc
,
477 Chars
=> New_Internal_Name
('S'));
478 Set_Is_Internal
(Subt
);
481 Make_Subtype_Declaration
(Loc
,
482 Defining_Identifier
=> Subt
,
483 Subtype_Indication
=>
484 Make_Subtype_Indication
(Loc
,
485 Subtype_Mark
=> New_Reference_To
(Base_Type
(T
), Loc
),
487 Make_Index_Or_Discriminant_Constraint
(Loc
,
490 Mark_Rewrite_Insertion
(Decl
);
492 end Build_Component_Subtype
;
494 --------------------------------------------
495 -- Build_Discriminal_Subtype_Of_Component --
496 --------------------------------------------
498 function Build_Discriminal_Subtype_Of_Component
499 (T
: Entity_Id
) return Node_Id
501 Loc
: constant Source_Ptr
:= Sloc
(T
);
505 function Build_Discriminal_Array_Constraint
return List_Id
;
506 -- If one or more of the bounds of the component depends on
507 -- discriminants, build actual constraint using the discriminants
510 function Build_Discriminal_Record_Constraint
return List_Id
;
511 -- Similar to previous one, for discriminated components constrained
512 -- by the discriminant of the enclosing object.
514 ----------------------------------------
515 -- Build_Discriminal_Array_Constraint --
516 ----------------------------------------
518 function Build_Discriminal_Array_Constraint
return List_Id
is
519 Constraints
: constant List_Id
:= New_List
;
527 Indx
:= First_Index
(T
);
528 while Present
(Indx
) loop
529 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
530 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
532 if Denotes_Discriminant
(Old_Lo
) then
533 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
536 Lo
:= New_Copy_Tree
(Old_Lo
);
539 if Denotes_Discriminant
(Old_Hi
) then
540 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
543 Hi
:= New_Copy_Tree
(Old_Hi
);
546 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
551 end Build_Discriminal_Array_Constraint
;
553 -----------------------------------------
554 -- Build_Discriminal_Record_Constraint --
555 -----------------------------------------
557 function Build_Discriminal_Record_Constraint
return List_Id
is
558 Constraints
: constant List_Id
:= New_List
;
563 D
:= First_Elmt
(Discriminant_Constraint
(T
));
564 while Present
(D
) loop
565 if Denotes_Discriminant
(Node
(D
)) then
567 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
570 D_Val
:= New_Copy_Tree
(Node
(D
));
573 Append
(D_Val
, Constraints
);
578 end Build_Discriminal_Record_Constraint
;
580 -- Start of processing for Build_Discriminal_Subtype_Of_Component
583 if Ekind
(T
) = E_Array_Subtype
then
584 Id
:= First_Index
(T
);
586 while Present
(Id
) loop
587 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
))) or else
588 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
590 return Build_Component_Subtype
591 (Build_Discriminal_Array_Constraint
, Loc
, T
);
597 elsif Ekind
(T
) = E_Record_Subtype
598 and then Has_Discriminants
(T
)
599 and then not Has_Unknown_Discriminants
(T
)
601 D
:= First_Elmt
(Discriminant_Constraint
(T
));
602 while Present
(D
) loop
603 if Denotes_Discriminant
(Node
(D
)) then
604 return Build_Component_Subtype
605 (Build_Discriminal_Record_Constraint
, Loc
, T
);
612 -- If none of the above, the actual and nominal subtypes are the same.
615 end Build_Discriminal_Subtype_Of_Component
;
617 ------------------------------
618 -- Build_Elaboration_Entity --
619 ------------------------------
621 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
622 Loc
: constant Source_Ptr
:= Sloc
(N
);
623 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
626 Elab_Ent
: Entity_Id
;
629 -- Ignore if already constructed
631 if Present
(Elaboration_Entity
(Spec_Id
)) then
635 -- Construct name of elaboration entity as xxx_E, where xxx
636 -- is the unit name with dots replaced by double underscore.
637 -- We have to manually construct this name, since it will
638 -- be elaborated in the outer scope, and thus will not have
639 -- the unit name automatically prepended.
641 Get_Name_String
(Unit_Name
(Unum
));
643 -- Replace the %s by _E
645 Name_Buffer
(Name_Len
- 1 .. Name_Len
) := "_E";
647 -- Replace dots by double underscore
650 while P
< Name_Len
- 2 loop
651 if Name_Buffer
(P
) = '.' then
652 Name_Buffer
(P
+ 2 .. Name_Len
+ 1) :=
653 Name_Buffer
(P
+ 1 .. Name_Len
);
654 Name_Len
:= Name_Len
+ 1;
655 Name_Buffer
(P
) := '_';
656 Name_Buffer
(P
+ 1) := '_';
663 -- Create elaboration flag
666 Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
667 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
669 if No
(Declarations
(Aux_Decls_Node
(N
))) then
670 Set_Declarations
(Aux_Decls_Node
(N
), New_List
);
674 Make_Object_Declaration
(Loc
,
675 Defining_Identifier
=> Elab_Ent
,
677 New_Occurrence_Of
(Standard_Boolean
, Loc
),
679 New_Occurrence_Of
(Standard_False
, Loc
));
681 Append_To
(Declarations
(Aux_Decls_Node
(N
)), Decl
);
684 -- Reset True_Constant indication, since we will indeed
685 -- assign a value to the variable in the binder main.
687 Set_Is_True_Constant
(Elab_Ent
, False);
688 Set_Current_Value
(Elab_Ent
, Empty
);
690 -- We do not want any further qualification of the name (if we did
691 -- not do this, we would pick up the name of the generic package
692 -- in the case of a library level generic instantiation).
694 Set_Has_Qualified_Name
(Elab_Ent
);
695 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
696 end Build_Elaboration_Entity
;
698 -----------------------------------
699 -- Cannot_Raise_Constraint_Error --
700 -----------------------------------
702 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
704 if Compile_Time_Known_Value
(Expr
) then
707 elsif Do_Range_Check
(Expr
) then
710 elsif Raises_Constraint_Error
(Expr
) then
718 when N_Expanded_Name
=>
721 when N_Selected_Component
=>
722 return not Do_Discriminant_Check
(Expr
);
724 when N_Attribute_Reference
=>
725 if Do_Overflow_Check
(Expr
) then
728 elsif No
(Expressions
(Expr
)) then
733 N
: Node_Id
:= First
(Expressions
(Expr
));
736 while Present
(N
) loop
737 if Cannot_Raise_Constraint_Error
(N
) then
748 when N_Type_Conversion
=>
749 if Do_Overflow_Check
(Expr
)
750 or else Do_Length_Check
(Expr
)
751 or else Do_Tag_Check
(Expr
)
756 Cannot_Raise_Constraint_Error
(Expression
(Expr
));
759 when N_Unchecked_Type_Conversion
=>
760 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
763 if Do_Overflow_Check
(Expr
) then
767 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
774 if Do_Division_Check
(Expr
)
775 or else Do_Overflow_Check
(Expr
)
780 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
782 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
801 N_Op_Shift_Right_Arithmetic |
805 if Do_Overflow_Check
(Expr
) then
809 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
811 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
818 end Cannot_Raise_Constraint_Error
;
820 --------------------------
821 -- Check_Fully_Declared --
822 --------------------------
824 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
826 if Ekind
(T
) = E_Incomplete_Type
then
828 -- Ada 2005 (AI-50217): If the type is available through a limited
829 -- with_clause, verify that its full view has been analyzed.
831 if From_With_Type
(T
)
832 and then Present
(Non_Limited_View
(T
))
833 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
835 -- The non-limited view is fully declared
840 ("premature usage of incomplete}", N
, First_Subtype
(T
));
843 elsif Has_Private_Component
(T
)
844 and then not Is_Generic_Type
(Root_Type
(T
))
845 and then not In_Default_Expression
848 -- Special case: if T is the anonymous type created for a single
849 -- task or protected object, use the name of the source object.
851 if Is_Concurrent_Type
(T
)
852 and then not Comes_From_Source
(T
)
853 and then Nkind
(N
) = N_Object_Declaration
855 Error_Msg_NE
("type of& has incomplete component", N
,
856 Defining_Identifier
(N
));
860 ("premature usage of incomplete}", N
, First_Subtype
(T
));
863 end Check_Fully_Declared
;
865 ------------------------------------------
866 -- Check_Potentially_Blocking_Operation --
867 ------------------------------------------
869 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
873 -- N is one of the potentially blocking operations listed in 9.5.1(8).
874 -- When pragma Detect_Blocking is active, the run time will raise
875 -- Program_Error. Here we only issue a warning, since we generally
876 -- support the use of potentially blocking operations in the absence
879 -- Indirect blocking through a subprogram call cannot be diagnosed
880 -- statically without interprocedural analysis, so we do not attempt
883 S
:= Scope
(Current_Scope
);
884 while Present
(S
) and then S
/= Standard_Standard
loop
885 if Is_Protected_Type
(S
) then
887 ("potentially blocking operation in protected operation?", N
);
894 end Check_Potentially_Blocking_Operation
;
900 procedure Check_VMS
(Construct
: Node_Id
) is
902 if not OpenVMS_On_Target
then
904 ("this construct is allowed only in Open'V'M'S", Construct
);
908 ----------------------------------
909 -- Collect_Primitive_Operations --
910 ----------------------------------
912 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
913 B_Type
: constant Entity_Id
:= Base_Type
(T
);
914 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
915 B_Scope
: Entity_Id
:= Scope
(B_Type
);
919 Formal_Derived
: Boolean := False;
923 -- For tagged types, the primitive operations are collected as they
924 -- are declared, and held in an explicit list which is simply returned.
926 if Is_Tagged_Type
(B_Type
) then
927 return Primitive_Operations
(B_Type
);
929 -- An untagged generic type that is a derived type inherits the
930 -- primitive operations of its parent type. Other formal types only
931 -- have predefined operators, which are not explicitly represented.
933 elsif Is_Generic_Type
(B_Type
) then
934 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
935 and then Nkind
(Formal_Type_Definition
(B_Decl
))
936 = N_Formal_Derived_Type_Definition
938 Formal_Derived
:= True;
940 return New_Elmt_List
;
944 Op_List
:= New_Elmt_List
;
946 if B_Scope
= Standard_Standard
then
947 if B_Type
= Standard_String
then
948 Append_Elmt
(Standard_Op_Concat
, Op_List
);
950 elsif B_Type
= Standard_Wide_String
then
951 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
957 elsif (Is_Package
(B_Scope
)
959 Parent
(Declaration_Node
(First_Subtype
(T
))))
962 or else Is_Derived_Type
(B_Type
)
964 -- The primitive operations appear after the base type, except
965 -- if the derivation happens within the private part of B_Scope
966 -- and the type is a private type, in which case both the type
967 -- and some primitive operations may appear before the base
968 -- type, and the list of candidates starts after the type.
970 if In_Open_Scopes
(B_Scope
)
971 and then Scope
(T
) = B_Scope
972 and then In_Private_Part
(B_Scope
)
974 Id
:= Next_Entity
(T
);
976 Id
:= Next_Entity
(B_Type
);
979 while Present
(Id
) loop
981 -- Note that generic formal subprograms are not
982 -- considered to be primitive operations and thus
983 -- are never inherited.
985 if Is_Overloadable
(Id
)
986 and then Nkind
(Parent
(Parent
(Id
)))
987 /= N_Formal_Subprogram_Declaration
991 if Base_Type
(Etype
(Id
)) = B_Type
then
994 Formal
:= First_Formal
(Id
);
995 while Present
(Formal
) loop
996 if Base_Type
(Etype
(Formal
)) = B_Type
then
1000 elsif Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
1002 (Designated_Type
(Etype
(Formal
))) = B_Type
1008 Next_Formal
(Formal
);
1012 -- For a formal derived type, the only primitives are the
1013 -- ones inherited from the parent type. Operations appearing
1014 -- in the package declaration are not primitive for it.
1017 and then (not Formal_Derived
1018 or else Present
(Alias
(Id
)))
1020 Append_Elmt
(Id
, Op_List
);
1026 -- For a type declared in System, some of its operations
1027 -- may appear in the target-specific extension to System.
1030 and then Chars
(B_Scope
) = Name_System
1031 and then Scope
(B_Scope
) = Standard_Standard
1032 and then Present_System_Aux
1034 B_Scope
:= System_Aux_Id
;
1035 Id
:= First_Entity
(System_Aux_Id
);
1041 end Collect_Primitive_Operations
;
1043 -----------------------------------
1044 -- Compile_Time_Constraint_Error --
1045 -----------------------------------
1047 function Compile_Time_Constraint_Error
1050 Ent
: Entity_Id
:= Empty
;
1051 Loc
: Source_Ptr
:= No_Location
;
1052 Warn
: Boolean := False) return Node_Id
1054 Msgc
: String (1 .. Msg
'Length + 2);
1062 -- A static constraint error in an instance body is not a fatal error.
1063 -- we choose to inhibit the message altogether, because there is no
1064 -- obvious node (for now) on which to post it. On the other hand the
1065 -- offending node must be replaced with a constraint_error in any case.
1067 -- No messages are generated if we already posted an error on this node
1069 if not Error_Posted
(N
) then
1070 if Loc
/= No_Location
then
1076 -- Make all such messages unconditional
1078 Msgc
(1 .. Msg
'Length) := Msg
;
1079 Msgc
(Msg
'Length + 1) := '!';
1080 Msgl
:= Msg
'Length + 1;
1082 -- Message is a warning, even in Ada 95 case
1084 if Msg
(Msg
'Length) = '?' then
1087 -- In Ada 83, all messages are warnings. In the private part and
1088 -- the body of an instance, constraint_checks are only warnings.
1089 -- We also make this a warning if the Warn parameter is set.
1092 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
1098 elsif In_Instance_Not_Visible
then
1103 -- Otherwise we have a real error message (Ada 95 static case)
1109 -- Should we generate a warning? The answer is not quite yes. The
1110 -- very annoying exception occurs in the case of a short circuit
1111 -- operator where the left operand is static and decisive. Climb
1112 -- parents to see if that is the case we have here.
1120 if (Nkind
(P
) = N_And_Then
1121 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1122 and then Is_False
(Expr_Value
(Left_Opnd
(P
))))
1123 or else (Nkind
(P
) = N_Or_Else
1124 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1125 and then Is_True
(Expr_Value
(Left_Opnd
(P
))))
1130 elsif Nkind
(P
) = N_Component_Association
1131 and then Nkind
(Parent
(P
)) = N_Aggregate
1133 null; -- Keep going.
1136 exit when Nkind
(P
) not in N_Subexpr
;
1141 if Present
(Ent
) then
1142 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
1144 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
1148 if Inside_Init_Proc
then
1150 ("\& will be raised for objects of this type!?",
1151 N
, Standard_Constraint_Error
, Eloc
);
1154 ("\& will be raised at run time!?",
1155 N
, Standard_Constraint_Error
, Eloc
);
1159 ("\static expression raises&!",
1160 N
, Standard_Constraint_Error
, Eloc
);
1166 end Compile_Time_Constraint_Error
;
1168 -----------------------
1169 -- Conditional_Delay --
1170 -----------------------
1172 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
1174 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
1175 Set_Has_Delayed_Freeze
(New_Ent
);
1177 end Conditional_Delay
;
1179 --------------------
1180 -- Current_Entity --
1181 --------------------
1183 -- The currently visible definition for a given identifier is the
1184 -- one most chained at the start of the visibility chain, i.e. the
1185 -- one that is referenced by the Node_Id value of the name of the
1186 -- given identifier.
1188 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
1190 return Get_Name_Entity_Id
(Chars
(N
));
1193 -----------------------------
1194 -- Current_Entity_In_Scope --
1195 -----------------------------
1197 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
1199 CS
: constant Entity_Id
:= Current_Scope
;
1201 Transient_Case
: constant Boolean := Scope_Is_Transient
;
1204 E
:= Get_Name_Entity_Id
(Chars
(N
));
1207 and then Scope
(E
) /= CS
1208 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
1214 end Current_Entity_In_Scope
;
1220 function Current_Scope
return Entity_Id
is
1222 if Scope_Stack
.Last
= -1 then
1223 return Standard_Standard
;
1226 C
: constant Entity_Id
:=
1227 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
1232 return Standard_Standard
;
1238 ------------------------
1239 -- Current_Subprogram --
1240 ------------------------
1242 function Current_Subprogram
return Entity_Id
is
1243 Scop
: constant Entity_Id
:= Current_Scope
;
1246 if Is_Subprogram
(Scop
) or else Is_Generic_Subprogram
(Scop
) then
1249 return Enclosing_Subprogram
(Scop
);
1251 end Current_Subprogram
;
1253 ---------------------
1254 -- Defining_Entity --
1255 ---------------------
1257 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
1258 K
: constant Node_Kind
:= Nkind
(N
);
1259 Err
: Entity_Id
:= Empty
;
1264 N_Subprogram_Declaration |
1265 N_Abstract_Subprogram_Declaration |
1267 N_Package_Declaration |
1268 N_Subprogram_Renaming_Declaration |
1269 N_Subprogram_Body_Stub |
1270 N_Generic_Subprogram_Declaration |
1271 N_Generic_Package_Declaration |
1272 N_Formal_Subprogram_Declaration
1274 return Defining_Entity
(Specification
(N
));
1277 N_Component_Declaration |
1278 N_Defining_Program_Unit_Name |
1279 N_Discriminant_Specification |
1281 N_Entry_Declaration |
1282 N_Entry_Index_Specification |
1283 N_Exception_Declaration |
1284 N_Exception_Renaming_Declaration |
1285 N_Formal_Object_Declaration |
1286 N_Formal_Package_Declaration |
1287 N_Formal_Type_Declaration |
1288 N_Full_Type_Declaration |
1289 N_Implicit_Label_Declaration |
1290 N_Incomplete_Type_Declaration |
1291 N_Loop_Parameter_Specification |
1292 N_Number_Declaration |
1293 N_Object_Declaration |
1294 N_Object_Renaming_Declaration |
1295 N_Package_Body_Stub |
1296 N_Parameter_Specification |
1297 N_Private_Extension_Declaration |
1298 N_Private_Type_Declaration |
1300 N_Protected_Body_Stub |
1301 N_Protected_Type_Declaration |
1302 N_Single_Protected_Declaration |
1303 N_Single_Task_Declaration |
1304 N_Subtype_Declaration |
1307 N_Task_Type_Declaration
1309 return Defining_Identifier
(N
);
1312 return Defining_Entity
(Proper_Body
(N
));
1315 N_Function_Instantiation |
1316 N_Function_Specification |
1317 N_Generic_Function_Renaming_Declaration |
1318 N_Generic_Package_Renaming_Declaration |
1319 N_Generic_Procedure_Renaming_Declaration |
1321 N_Package_Instantiation |
1322 N_Package_Renaming_Declaration |
1323 N_Package_Specification |
1324 N_Procedure_Instantiation |
1325 N_Procedure_Specification
1328 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
1331 if Nkind
(Nam
) in N_Entity
then
1334 -- For Error, make up a name and attach to declaration
1335 -- so we can continue semantic analysis
1337 elsif Nam
= Error
then
1339 Make_Defining_Identifier
(Sloc
(N
),
1340 Chars
=> New_Internal_Name
('T'));
1341 Set_Defining_Unit_Name
(N
, Err
);
1344 -- If not an entity, get defining identifier
1347 return Defining_Identifier
(Nam
);
1351 when N_Block_Statement
=>
1352 return Entity
(Identifier
(N
));
1355 raise Program_Error
;
1358 end Defining_Entity
;
1360 --------------------------
1361 -- Denotes_Discriminant --
1362 --------------------------
1364 function Denotes_Discriminant
1366 Check_Protected
: Boolean := False) return Boolean
1370 if not Is_Entity_Name
(N
)
1371 or else No
(Entity
(N
))
1378 -- If we are checking for a protected type, the discriminant may have
1379 -- been rewritten as the corresponding discriminal of the original type
1380 -- or of the corresponding concurrent record, depending on whether we
1381 -- are in the spec or body of the protected type.
1383 return Ekind
(E
) = E_Discriminant
1386 and then Ekind
(E
) = E_In_Parameter
1387 and then Present
(Discriminal_Link
(E
))
1389 (Is_Protected_Type
(Scope
(Discriminal_Link
(E
)))
1391 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
1393 end Denotes_Discriminant
;
1395 -----------------------------
1396 -- Depends_On_Discriminant --
1397 -----------------------------
1399 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
1404 Get_Index_Bounds
(N
, L
, H
);
1405 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
1406 end Depends_On_Discriminant
;
1408 -------------------------
1409 -- Designate_Same_Unit --
1410 -------------------------
1412 function Designate_Same_Unit
1414 Name2
: Node_Id
) return Boolean
1416 K1
: constant Node_Kind
:= Nkind
(Name1
);
1417 K2
: constant Node_Kind
:= Nkind
(Name2
);
1419 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
1420 -- Returns the parent unit name node of a defining program unit name
1421 -- or the prefix if N is a selected component or an expanded name.
1423 function Select_Node
(N
: Node_Id
) return Node_Id
;
1424 -- Returns the defining identifier node of a defining program unit
1425 -- name or the selector node if N is a selected component or an
1432 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
1434 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1446 function Select_Node
(N
: Node_Id
) return Node_Id
is
1448 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1449 return Defining_Identifier
(N
);
1452 return Selector_Name
(N
);
1456 -- Start of processing for Designate_Next_Unit
1459 if (K1
= N_Identifier
or else
1460 K1
= N_Defining_Identifier
)
1462 (K2
= N_Identifier
or else
1463 K2
= N_Defining_Identifier
)
1465 return Chars
(Name1
) = Chars
(Name2
);
1468 (K1
= N_Expanded_Name
or else
1469 K1
= N_Selected_Component
or else
1470 K1
= N_Defining_Program_Unit_Name
)
1472 (K2
= N_Expanded_Name
or else
1473 K2
= N_Selected_Component
or else
1474 K2
= N_Defining_Program_Unit_Name
)
1477 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
1479 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
1484 end Designate_Same_Unit
;
1486 ----------------------------
1487 -- Enclosing_Generic_Body --
1488 ----------------------------
1490 function Enclosing_Generic_Body
1491 (E
: Entity_Id
) return Node_Id
1500 while Present
(P
) loop
1501 if Nkind
(P
) = N_Package_Body
1502 or else Nkind
(P
) = N_Subprogram_Body
1504 Spec
:= Corresponding_Spec
(P
);
1506 if Present
(Spec
) then
1507 Decl
:= Unit_Declaration_Node
(Spec
);
1509 if Nkind
(Decl
) = N_Generic_Package_Declaration
1510 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
1521 end Enclosing_Generic_Body
;
1523 -------------------------------
1524 -- Enclosing_Lib_Unit_Entity --
1525 -------------------------------
1527 function Enclosing_Lib_Unit_Entity
return Entity_Id
is
1528 Unit_Entity
: Entity_Id
:= Current_Scope
;
1531 -- Look for enclosing library unit entity by following scope links.
1532 -- Equivalent to, but faster than indexing through the scope stack.
1534 while (Present
(Scope
(Unit_Entity
))
1535 and then Scope
(Unit_Entity
) /= Standard_Standard
)
1536 and not Is_Child_Unit
(Unit_Entity
)
1538 Unit_Entity
:= Scope
(Unit_Entity
);
1542 end Enclosing_Lib_Unit_Entity
;
1544 -----------------------------
1545 -- Enclosing_Lib_Unit_Node --
1546 -----------------------------
1548 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
1549 Current_Node
: Node_Id
:= N
;
1552 while Present
(Current_Node
)
1553 and then Nkind
(Current_Node
) /= N_Compilation_Unit
1555 Current_Node
:= Parent
(Current_Node
);
1558 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
1562 return Current_Node
;
1563 end Enclosing_Lib_Unit_Node
;
1565 --------------------------
1566 -- Enclosing_Subprogram --
1567 --------------------------
1569 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
1570 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
1573 if Dynamic_Scope
= Standard_Standard
then
1576 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
1577 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
1579 elsif Ekind
(Dynamic_Scope
) = E_Block
then
1580 return Enclosing_Subprogram
(Dynamic_Scope
);
1582 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
1583 return Get_Task_Body_Procedure
(Dynamic_Scope
);
1585 elsif Convention
(Dynamic_Scope
) = Convention_Protected
then
1586 return Protected_Body_Subprogram
(Dynamic_Scope
);
1589 return Dynamic_Scope
;
1591 end Enclosing_Subprogram
;
1593 ------------------------
1594 -- Ensure_Freeze_Node --
1595 ------------------------
1597 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
1601 if No
(Freeze_Node
(E
)) then
1602 FN
:= Make_Freeze_Entity
(Sloc
(E
));
1603 Set_Has_Delayed_Freeze
(E
);
1604 Set_Freeze_Node
(E
, FN
);
1605 Set_Access_Types_To_Process
(FN
, No_Elist
);
1606 Set_TSS_Elist
(FN
, No_Elist
);
1609 end Ensure_Freeze_Node
;
1615 procedure Enter_Name
(Def_Id
: Node_Id
) is
1616 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
1617 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
1618 S
: constant Entity_Id
:= Current_Scope
;
1621 Generate_Definition
(Def_Id
);
1623 -- Add new name to current scope declarations. Check for duplicate
1624 -- declaration, which may or may not be a genuine error.
1628 -- Case of previous entity entered because of a missing declaration
1629 -- or else a bad subtype indication. Best is to use the new entity,
1630 -- and make the previous one invisible.
1632 if Etype
(E
) = Any_Type
then
1633 Set_Is_Immediately_Visible
(E
, False);
1635 -- Case of renaming declaration constructed for package instances.
1636 -- if there is an explicit declaration with the same identifier,
1637 -- the renaming is not immediately visible any longer, but remains
1638 -- visible through selected component notation.
1640 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
1641 and then not Comes_From_Source
(E
)
1643 Set_Is_Immediately_Visible
(E
, False);
1645 -- The new entity may be the package renaming, which has the same
1646 -- same name as a generic formal which has been seen already.
1648 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
1649 and then not Comes_From_Source
(Def_Id
)
1651 Set_Is_Immediately_Visible
(E
, False);
1653 -- For a fat pointer corresponding to a remote access to subprogram,
1654 -- we use the same identifier as the RAS type, so that the proper
1655 -- name appears in the stub. This type is only retrieved through
1656 -- the RAS type and never by visibility, and is not added to the
1657 -- visibility list (see below).
1659 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
1660 and then Present
(Corresponding_Remote_Type
(Def_Id
))
1664 -- A controller component for a type extension overrides the
1665 -- inherited component.
1667 elsif Chars
(E
) = Name_uController
then
1670 -- Case of an implicit operation or derived literal. The new entity
1671 -- hides the implicit one, which is removed from all visibility,
1672 -- i.e. the entity list of its scope, and homonym chain of its name.
1674 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
1675 or else Is_Internal
(E
)
1679 Prev_Vis
: Entity_Id
;
1680 Decl
: constant Node_Id
:= Parent
(E
);
1683 -- If E is an implicit declaration, it cannot be the first
1684 -- entity in the scope.
1686 Prev
:= First_Entity
(Current_Scope
);
1688 while Present
(Prev
)
1689 and then Next_Entity
(Prev
) /= E
1696 -- If E is not on the entity chain of the current scope,
1697 -- it is an implicit declaration in the generic formal
1698 -- part of a generic subprogram. When analyzing the body,
1699 -- the generic formals are visible but not on the entity
1700 -- chain of the subprogram. The new entity will become
1701 -- the visible one in the body.
1704 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
1708 Set_Next_Entity
(Prev
, Next_Entity
(E
));
1710 if No
(Next_Entity
(Prev
)) then
1711 Set_Last_Entity
(Current_Scope
, Prev
);
1714 if E
= Current_Entity
(E
) then
1718 Prev_Vis
:= Current_Entity
(E
);
1719 while Homonym
(Prev_Vis
) /= E
loop
1720 Prev_Vis
:= Homonym
(Prev_Vis
);
1724 if Present
(Prev_Vis
) then
1726 -- Skip E in the visibility chain
1728 Set_Homonym
(Prev_Vis
, Homonym
(E
));
1731 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
1736 -- This section of code could use a comment ???
1738 elsif Present
(Etype
(E
))
1739 and then Is_Concurrent_Type
(Etype
(E
))
1744 -- In the body or private part of an instance, a type extension
1745 -- may introduce a component with the same name as that of an
1746 -- actual. The legality rule is not enforced, but the semantics
1747 -- of the full type with two components of the same name are not
1748 -- clear at this point ???
1750 elsif In_Instance_Not_Visible
then
1753 -- When compiling a package body, some child units may have become
1754 -- visible. They cannot conflict with local entities that hide them.
1756 elsif Is_Child_Unit
(E
)
1757 and then In_Open_Scopes
(Scope
(E
))
1758 and then not Is_Immediately_Visible
(E
)
1762 -- Conversely, with front-end inlining we may compile the parent
1763 -- body first, and a child unit subsequently. The context is now
1764 -- the parent spec, and body entities are not visible.
1766 elsif Is_Child_Unit
(Def_Id
)
1767 and then Is_Package_Body_Entity
(E
)
1768 and then not In_Package_Body
(Current_Scope
)
1772 -- Case of genuine duplicate declaration
1775 Error_Msg_Sloc
:= Sloc
(E
);
1777 -- If the previous declaration is an incomplete type declaration
1778 -- this may be an attempt to complete it with a private type.
1779 -- The following avoids confusing cascaded errors.
1781 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
1782 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
1785 ("incomplete type cannot be completed" &
1786 " with a private declaration",
1788 Set_Is_Immediately_Visible
(E
, False);
1789 Set_Full_View
(E
, Def_Id
);
1791 elsif Ekind
(E
) = E_Discriminant
1792 and then Present
(Scope
(Def_Id
))
1793 and then Scope
(Def_Id
) /= Current_Scope
1795 -- An inherited component of a record conflicts with
1796 -- a new discriminant. The discriminant is inserted first
1797 -- in the scope, but the error should be posted on it, not
1798 -- on the component.
1800 Error_Msg_Sloc
:= Sloc
(Def_Id
);
1801 Error_Msg_N
("& conflicts with declaration#", E
);
1804 -- If the name of the unit appears in its own context clause,
1805 -- a dummy package with the name has already been created, and
1806 -- the error emitted. Try to continue quietly.
1808 elsif Error_Posted
(E
)
1809 and then Sloc
(E
) = No_Location
1810 and then Nkind
(Parent
(E
)) = N_Package_Specification
1811 and then Current_Scope
= Standard_Standard
1813 Set_Scope
(Def_Id
, Current_Scope
);
1817 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
1819 -- Avoid cascaded messages with duplicate components in
1822 if Ekind
(E
) = E_Component
1823 or else Ekind
(E
) = E_Discriminant
1829 if Nkind
(Parent
(Parent
(Def_Id
)))
1830 = N_Generic_Subprogram_Declaration
1832 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
1834 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
1837 -- If entity is in standard, then we are in trouble, because
1838 -- it means that we have a library package with a duplicated
1839 -- name. That's hard to recover from, so abort!
1841 if S
= Standard_Standard
then
1842 raise Unrecoverable_Error
;
1844 -- Otherwise we continue with the declaration. Having two
1845 -- identical declarations should not cause us too much trouble!
1853 -- If we fall through, declaration is OK , or OK enough to continue
1855 -- If Def_Id is a discriminant or a record component we are in the
1856 -- midst of inheriting components in a derived record definition.
1857 -- Preserve their Ekind and Etype.
1859 if Ekind
(Def_Id
) = E_Discriminant
1860 or else Ekind
(Def_Id
) = E_Component
1864 -- If a type is already set, leave it alone (happens whey a type
1865 -- declaration is reanalyzed following a call to the optimizer)
1867 elsif Present
(Etype
(Def_Id
)) then
1870 -- Otherwise, the kind E_Void insures that premature uses of the entity
1871 -- will be detected. Any_Type insures that no cascaded errors will occur
1874 Set_Ekind
(Def_Id
, E_Void
);
1875 Set_Etype
(Def_Id
, Any_Type
);
1878 -- Inherited discriminants and components in derived record types are
1879 -- immediately visible. Itypes are not.
1881 if Ekind
(Def_Id
) = E_Discriminant
1882 or else Ekind
(Def_Id
) = E_Component
1883 or else (No
(Corresponding_Remote_Type
(Def_Id
))
1884 and then not Is_Itype
(Def_Id
))
1886 Set_Is_Immediately_Visible
(Def_Id
);
1887 Set_Current_Entity
(Def_Id
);
1890 Set_Homonym
(Def_Id
, C
);
1891 Append_Entity
(Def_Id
, S
);
1892 Set_Public_Status
(Def_Id
);
1894 -- Warn if new entity hides an old one
1897 and then Present
(C
)
1898 and then Length_Of_Name
(Chars
(C
)) /= 1
1899 and then Comes_From_Source
(C
)
1900 and then Comes_From_Source
(Def_Id
)
1901 and then In_Extended_Main_Source_Unit
(Def_Id
)
1903 Error_Msg_Sloc
:= Sloc
(C
);
1904 Error_Msg_N
("declaration hides &#?", Def_Id
);
1908 --------------------------
1909 -- Explain_Limited_Type --
1910 --------------------------
1912 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
1916 -- For array, component type must be limited
1918 if Is_Array_Type
(T
) then
1919 Error_Msg_Node_2
:= T
;
1921 ("component type& of type& is limited", N
, Component_Type
(T
));
1922 Explain_Limited_Type
(Component_Type
(T
), N
);
1924 elsif Is_Record_Type
(T
) then
1926 -- No need for extra messages if explicit limited record
1928 if Is_Limited_Record
(Base_Type
(T
)) then
1932 -- Otherwise find a limited component
1934 C
:= First_Component
(T
);
1935 while Present
(C
) loop
1936 if Is_Limited_Type
(Etype
(C
)) then
1937 Error_Msg_Node_2
:= T
;
1938 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
1939 Explain_Limited_Type
(Etype
(C
), N
);
1946 -- It's odd if the loop falls through, but this is only an extra
1947 -- error message, so we just let it go and ignore the situation.
1951 end Explain_Limited_Type
;
1953 -------------------------------------
1954 -- Find_Corresponding_Discriminant --
1955 -------------------------------------
1957 function Find_Corresponding_Discriminant
1959 Typ
: Entity_Id
) return Entity_Id
1961 Par_Disc
: Entity_Id
;
1962 Old_Disc
: Entity_Id
;
1963 New_Disc
: Entity_Id
;
1966 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
1968 -- The original type may currently be private, and the discriminant
1969 -- only appear on its full view.
1971 if Is_Private_Type
(Scope
(Par_Disc
))
1972 and then not Has_Discriminants
(Scope
(Par_Disc
))
1973 and then Present
(Full_View
(Scope
(Par_Disc
)))
1975 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
1977 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
1980 if Is_Class_Wide_Type
(Typ
) then
1981 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
1983 New_Disc
:= First_Discriminant
(Typ
);
1986 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
1987 if Old_Disc
= Par_Disc
then
1990 Next_Discriminant
(Old_Disc
);
1991 Next_Discriminant
(New_Disc
);
1995 -- Should always find it
1997 raise Program_Error
;
1998 end Find_Corresponding_Discriminant
;
2000 -----------------------------
2001 -- Find_Static_Alternative --
2002 -----------------------------
2004 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
2005 Expr
: constant Node_Id
:= Expression
(N
);
2006 Val
: constant Uint
:= Expr_Value
(Expr
);
2011 Alt
:= First
(Alternatives
(N
));
2014 if Nkind
(Alt
) /= N_Pragma
then
2015 Choice
:= First
(Discrete_Choices
(Alt
));
2017 while Present
(Choice
) loop
2019 -- Others choice, always matches
2021 if Nkind
(Choice
) = N_Others_Choice
then
2024 -- Range, check if value is in the range
2026 elsif Nkind
(Choice
) = N_Range
then
2028 Val
>= Expr_Value
(Low_Bound
(Choice
))
2030 Val
<= Expr_Value
(High_Bound
(Choice
));
2032 -- Choice is a subtype name. Note that we know it must
2033 -- be a static subtype, since otherwise it would have
2034 -- been diagnosed as illegal.
2036 elsif Is_Entity_Name
(Choice
)
2037 and then Is_Type
(Entity
(Choice
))
2039 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
));
2041 -- Choice is a subtype indication
2043 elsif Nkind
(Choice
) = N_Subtype_Indication
then
2045 C
: constant Node_Id
:= Constraint
(Choice
);
2046 R
: constant Node_Id
:= Range_Expression
(C
);
2050 Val
>= Expr_Value
(Low_Bound
(R
))
2052 Val
<= Expr_Value
(High_Bound
(R
));
2055 -- Choice is a simple expression
2058 exit Search
when Val
= Expr_Value
(Choice
);
2066 pragma Assert
(Present
(Alt
));
2069 -- The above loop *must* terminate by finding a match, since
2070 -- we know the case statement is valid, and the value of the
2071 -- expression is known at compile time. When we fall out of
2072 -- the loop, Alt points to the alternative that we know will
2073 -- be selected at run time.
2076 end Find_Static_Alternative
;
2082 function First_Actual
(Node
: Node_Id
) return Node_Id
is
2086 if No
(Parameter_Associations
(Node
)) then
2090 N
:= First
(Parameter_Associations
(Node
));
2092 if Nkind
(N
) = N_Parameter_Association
then
2093 return First_Named_Actual
(Node
);
2099 -------------------------
2100 -- Full_Qualified_Name --
2101 -------------------------
2103 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2105 pragma Warnings
(Off
, Res
);
2107 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
2108 -- Compute recursively the qualified name without NUL at the end.
2110 ----------------------------------
2111 -- Internal_Full_Qualified_Name --
2112 ----------------------------------
2114 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2115 Ent
: Entity_Id
:= E
;
2116 Parent_Name
: String_Id
:= No_String
;
2119 -- Deals properly with child units
2121 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
2122 Ent
:= Defining_Identifier
(Ent
);
2125 -- Compute recursively the qualification. Only "Standard" has no
2128 if Present
(Scope
(Scope
(Ent
))) then
2129 Parent_Name
:= Internal_Full_Qualified_Name
(Scope
(Ent
));
2132 -- Every entity should have a name except some expanded blocks
2133 -- don't bother about those.
2135 if Chars
(Ent
) = No_Name
then
2139 -- Add a period between Name and qualification
2141 if Parent_Name
/= No_String
then
2142 Start_String
(Parent_Name
);
2143 Store_String_Char
(Get_Char_Code
('.'));
2149 -- Generates the entity name in upper case
2151 Get_Name_String
(Chars
(Ent
));
2153 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2155 end Internal_Full_Qualified_Name
;
2157 -- Start of processing for Full_Qualified_Name
2160 Res
:= Internal_Full_Qualified_Name
(E
);
2161 Store_String_Char
(Get_Char_Code
(ASCII
.nul
));
2163 end Full_Qualified_Name
;
2165 -----------------------
2166 -- Gather_Components --
2167 -----------------------
2169 procedure Gather_Components
2171 Comp_List
: Node_Id
;
2172 Governed_By
: List_Id
;
2174 Report_Errors
: out Boolean)
2178 Discrete_Choice
: Node_Id
;
2179 Comp_Item
: Node_Id
;
2181 Discrim
: Entity_Id
;
2182 Discrim_Name
: Node_Id
;
2183 Discrim_Value
: Node_Id
;
2186 Report_Errors
:= False;
2188 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
2191 elsif Present
(Component_Items
(Comp_List
)) then
2192 Comp_Item
:= First
(Component_Items
(Comp_List
));
2198 while Present
(Comp_Item
) loop
2200 -- Skip the tag of a tagged record, as well as all items
2201 -- that are not user components (anonymous types, rep clauses,
2202 -- Parent field, controller field).
2204 if Nkind
(Comp_Item
) = N_Component_Declaration
2205 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uTag
2206 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uParent
2207 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uController
2209 Append_Elmt
(Defining_Identifier
(Comp_Item
), Into
);
2215 if No
(Variant_Part
(Comp_List
)) then
2218 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
2219 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
2222 -- Look for the discriminant that governs this variant part.
2223 -- The discriminant *must* be in the Governed_By List
2225 Assoc
:= First
(Governed_By
);
2226 Find_Constraint
: loop
2227 Discrim
:= First
(Choices
(Assoc
));
2228 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
2229 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
2231 Chars
(Corresponding_Discriminant
(Entity
(Discrim
)))
2232 = Chars
(Discrim_Name
))
2233 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
2234 = Chars
(Discrim_Name
);
2236 if No
(Next
(Assoc
)) then
2237 if not Is_Constrained
(Typ
)
2238 and then Is_Derived_Type
(Typ
)
2239 and then Present
(Stored_Constraint
(Typ
))
2242 -- If the type is a tagged type with inherited discriminants,
2243 -- use the stored constraint on the parent in order to find
2244 -- the values of discriminants that are otherwise hidden by an
2245 -- explicit constraint. Renamed discriminants are handled in
2248 -- If several parent discriminants are renamed by a single
2249 -- discriminant of the derived type, the call to obtain the
2250 -- Corresponding_Discriminant field only retrieves the last
2251 -- of them. We recover the constraint on the others from the
2252 -- Stored_Constraint as well.
2259 D
:= First_Discriminant
(Etype
(Typ
));
2260 C
:= First_Elmt
(Stored_Constraint
(Typ
));
2263 and then Present
(C
)
2265 if Chars
(Discrim_Name
) = Chars
(D
) then
2266 if Is_Entity_Name
(Node
(C
))
2267 and then Entity
(Node
(C
)) = Entity
(Discrim
)
2269 -- D is renamed by Discrim, whose value is
2276 Make_Component_Association
(Sloc
(Typ
),
2278 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
2279 Duplicate_Subexpr_No_Checks
(Node
(C
)));
2281 exit Find_Constraint
;
2284 D
:= Next_Discriminant
(D
);
2291 if No
(Next
(Assoc
)) then
2292 Error_Msg_NE
(" missing value for discriminant&",
2293 First
(Governed_By
), Discrim_Name
);
2294 Report_Errors
:= True;
2299 end loop Find_Constraint
;
2301 Discrim_Value
:= Expression
(Assoc
);
2303 if not Is_OK_Static_Expression
(Discrim_Value
) then
2305 ("value for discriminant & must be static!",
2306 Discrim_Value
, Discrim
);
2307 Why_Not_Static
(Discrim_Value
);
2308 Report_Errors
:= True;
2312 Search_For_Discriminant_Value
: declare
2318 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
2321 Find_Discrete_Value
: while Present
(Variant
) loop
2322 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
2323 while Present
(Discrete_Choice
) loop
2325 exit Find_Discrete_Value
when
2326 Nkind
(Discrete_Choice
) = N_Others_Choice
;
2328 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
2330 UI_Low
:= Expr_Value
(Low
);
2331 UI_High
:= Expr_Value
(High
);
2333 exit Find_Discrete_Value
when
2334 UI_Low
<= UI_Discrim_Value
2336 UI_High
>= UI_Discrim_Value
;
2338 Next
(Discrete_Choice
);
2341 Next_Non_Pragma
(Variant
);
2342 end loop Find_Discrete_Value
;
2343 end Search_For_Discriminant_Value
;
2345 if No
(Variant
) then
2347 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
2348 Report_Errors
:= True;
2352 -- If we have found the corresponding choice, recursively add its
2353 -- components to the Into list.
2355 Gather_Components
(Empty
,
2356 Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
2357 end Gather_Components
;
2359 ------------------------
2360 -- Get_Actual_Subtype --
2361 ------------------------
2363 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
2364 Typ
: constant Entity_Id
:= Etype
(N
);
2365 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
2370 if not Present
(Utyp
) then
2374 -- If what we have is an identifier that references a subprogram
2375 -- formal, or a variable or constant object, then we get the actual
2376 -- subtype from the referenced entity if one has been built.
2378 if Nkind
(N
) = N_Identifier
2380 (Is_Formal
(Entity
(N
))
2381 or else Ekind
(Entity
(N
)) = E_Constant
2382 or else Ekind
(Entity
(N
)) = E_Variable
)
2383 and then Present
(Actual_Subtype
(Entity
(N
)))
2385 return Actual_Subtype
(Entity
(N
));
2387 -- Actual subtype of unchecked union is always itself. We never need
2388 -- the "real" actual subtype. If we did, we couldn't get it anyway
2389 -- because the discriminant is not available. The restrictions on
2390 -- Unchecked_Union are designed to make sure that this is OK.
2392 elsif Is_Unchecked_Union
(Base_Type
(Utyp
)) then
2395 -- Here for the unconstrained case, we must find actual subtype
2396 -- No actual subtype is available, so we must build it on the fly.
2398 -- Checking the type, not the underlying type, for constrainedness
2399 -- seems to be necessary. Maybe all the tests should be on the type???
2401 elsif (not Is_Constrained
(Typ
))
2402 and then (Is_Array_Type
(Utyp
)
2403 or else (Is_Record_Type
(Utyp
)
2404 and then Has_Discriminants
(Utyp
)))
2405 and then not Has_Unknown_Discriminants
(Utyp
)
2406 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
2408 -- Nothing to do if in default expression
2410 if In_Default_Expression
then
2413 elsif Is_Private_Type
(Typ
)
2414 and then not Has_Discriminants
(Typ
)
2416 -- If the type has no discriminants, there is no subtype to
2417 -- build, even if the underlying type is discriminated.
2421 -- Else build the actual subtype
2424 Decl
:= Build_Actual_Subtype
(Typ
, N
);
2425 Atyp
:= Defining_Identifier
(Decl
);
2427 -- If Build_Actual_Subtype generated a new declaration then use it
2431 -- The actual subtype is an Itype, so analyze the declaration,
2432 -- but do not attach it to the tree, to get the type defined.
2434 Set_Parent
(Decl
, N
);
2435 Set_Is_Itype
(Atyp
);
2436 Analyze
(Decl
, Suppress
=> All_Checks
);
2437 Set_Associated_Node_For_Itype
(Atyp
, N
);
2438 Set_Has_Delayed_Freeze
(Atyp
, False);
2440 -- We need to freeze the actual subtype immediately. This is
2441 -- needed, because otherwise this Itype will not get frozen
2442 -- at all, and it is always safe to freeze on creation because
2443 -- any associated types must be frozen at this point.
2445 Freeze_Itype
(Atyp
, N
);
2448 -- Otherwise we did not build a declaration, so return original
2455 -- For all remaining cases, the actual subtype is the same as
2456 -- the nominal type.
2461 end Get_Actual_Subtype
;
2463 -------------------------------------
2464 -- Get_Actual_Subtype_If_Available --
2465 -------------------------------------
2467 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
2468 Typ
: constant Entity_Id
:= Etype
(N
);
2471 -- If what we have is an identifier that references a subprogram
2472 -- formal, or a variable or constant object, then we get the actual
2473 -- subtype from the referenced entity if one has been built.
2475 if Nkind
(N
) = N_Identifier
2477 (Is_Formal
(Entity
(N
))
2478 or else Ekind
(Entity
(N
)) = E_Constant
2479 or else Ekind
(Entity
(N
)) = E_Variable
)
2480 and then Present
(Actual_Subtype
(Entity
(N
)))
2482 return Actual_Subtype
(Entity
(N
));
2484 -- Otherwise the Etype of N is returned unchanged
2489 end Get_Actual_Subtype_If_Available
;
2491 -------------------------------
2492 -- Get_Default_External_Name --
2493 -------------------------------
2495 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
2497 Get_Decoded_Name_String
(Chars
(E
));
2499 if Opt
.External_Name_Imp_Casing
= Uppercase
then
2500 Set_Casing
(All_Upper_Case
);
2502 Set_Casing
(All_Lower_Case
);
2506 Make_String_Literal
(Sloc
(E
),
2507 Strval
=> String_From_Name_Buffer
);
2508 end Get_Default_External_Name
;
2510 ---------------------------
2511 -- Get_Enum_Lit_From_Pos --
2512 ---------------------------
2514 function Get_Enum_Lit_From_Pos
2517 Loc
: Source_Ptr
) return Node_Id
2520 P
: constant Nat
:= UI_To_Int
(Pos
);
2523 -- In the case where the literal is either of type Wide_Character
2524 -- or Character or of a type derived from them, there needs to be
2525 -- some special handling since there is no explicit chain of
2526 -- literals to search. Instead, an N_Character_Literal node is
2527 -- created with the appropriate Char_Code and Chars fields.
2529 if Root_Type
(T
) = Standard_Character
2530 or else Root_Type
(T
) = Standard_Wide_Character
2532 Set_Character_Literal_Name
(Char_Code
(P
));
2534 Make_Character_Literal
(Loc
,
2536 Char_Literal_Value
=> Char_Code
(P
));
2538 -- For all other cases, we have a complete table of literals, and
2539 -- we simply iterate through the chain of literal until the one
2540 -- with the desired position value is found.
2544 Lit
:= First_Literal
(Base_Type
(T
));
2545 for J
in 1 .. P
loop
2549 return New_Occurrence_Of
(Lit
, Loc
);
2551 end Get_Enum_Lit_From_Pos
;
2553 ------------------------
2554 -- Get_Generic_Entity --
2555 ------------------------
2557 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
2558 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2561 if Present
(Renamed_Object
(Ent
)) then
2562 return Renamed_Object
(Ent
);
2566 end Get_Generic_Entity
;
2568 ----------------------
2569 -- Get_Index_Bounds --
2570 ----------------------
2572 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
2573 Kind
: constant Node_Kind
:= Nkind
(N
);
2577 if Kind
= N_Range
then
2579 H
:= High_Bound
(N
);
2581 elsif Kind
= N_Subtype_Indication
then
2582 R
:= Range_Expression
(Constraint
(N
));
2590 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
2591 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
2594 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
2595 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
2599 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
2600 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
2603 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
2604 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
2608 -- N is an expression, indicating a range with one value.
2613 end Get_Index_Bounds
;
2615 ------------------------
2616 -- Get_Name_Entity_Id --
2617 ------------------------
2619 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
2621 return Entity_Id
(Get_Name_Table_Info
(Id
));
2622 end Get_Name_Entity_Id
;
2624 ---------------------------
2625 -- Get_Referenced_Object --
2626 ---------------------------
2628 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
2632 while Is_Entity_Name
(R
)
2633 and then Present
(Renamed_Object
(Entity
(R
)))
2635 R
:= Renamed_Object
(Entity
(R
));
2639 end Get_Referenced_Object
;
2641 -------------------------
2642 -- Get_Subprogram_Body --
2643 -------------------------
2645 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
2649 Decl
:= Unit_Declaration_Node
(E
);
2651 if Nkind
(Decl
) = N_Subprogram_Body
then
2654 -- The below comment is bad, because it is possible for
2655 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
2657 else -- Nkind (Decl) = N_Subprogram_Declaration
2659 if Present
(Corresponding_Body
(Decl
)) then
2660 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2662 -- Imported subprogram case
2668 end Get_Subprogram_Body
;
2670 -----------------------------
2671 -- Get_Task_Body_Procedure --
2672 -----------------------------
2674 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
2676 return Task_Body_Procedure
(Declaration_Node
(Root_Type
(E
)));
2677 end Get_Task_Body_Procedure
;
2679 -----------------------
2680 -- Has_Access_Values --
2681 -----------------------
2683 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
2684 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
2687 -- Case of a private type which is not completed yet. This can only
2688 -- happen in the case of a generic format type appearing directly, or
2689 -- as a component of the type to which this function is being applied
2690 -- at the top level. Return False in this case, since we certainly do
2691 -- not know that the type contains access types.
2696 elsif Is_Access_Type
(Typ
) then
2699 elsif Is_Array_Type
(Typ
) then
2700 return Has_Access_Values
(Component_Type
(Typ
));
2702 elsif Is_Record_Type
(Typ
) then
2707 Comp
:= First_Entity
(Typ
);
2708 while Present
(Comp
) loop
2709 if (Ekind
(Comp
) = E_Component
2711 Ekind
(Comp
) = E_Discriminant
)
2712 and then Has_Access_Values
(Etype
(Comp
))
2726 end Has_Access_Values
;
2728 ----------------------
2729 -- Has_Declarations --
2730 ----------------------
2732 function Has_Declarations
(N
: Node_Id
) return Boolean is
2733 K
: constant Node_Kind
:= Nkind
(N
);
2735 return K
= N_Accept_Statement
2736 or else K
= N_Block_Statement
2737 or else K
= N_Compilation_Unit_Aux
2738 or else K
= N_Entry_Body
2739 or else K
= N_Package_Body
2740 or else K
= N_Protected_Body
2741 or else K
= N_Subprogram_Body
2742 or else K
= N_Task_Body
2743 or else K
= N_Package_Specification
;
2744 end Has_Declarations
;
2746 --------------------
2747 -- Has_Infinities --
2748 --------------------
2750 function Has_Infinities
(E
: Entity_Id
) return Boolean is
2753 Is_Floating_Point_Type
(E
)
2754 and then Nkind
(Scalar_Range
(E
)) = N_Range
2755 and then Includes_Infinities
(Scalar_Range
(E
));
2758 ------------------------
2759 -- Has_Null_Extension --
2760 ------------------------
2762 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
2763 B
: constant Entity_Id
:= Base_Type
(T
);
2768 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
2769 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
2771 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
2773 if Present
(Ext
) then
2774 if Null_Present
(Ext
) then
2777 Comps
:= Component_List
(Ext
);
2779 -- The null component list is rewritten during analysis to
2780 -- include the parent component. Any other component indicates
2781 -- that the extension was not originally null.
2783 return Null_Present
(Comps
)
2784 or else No
(Next
(First
(Component_Items
(Comps
))));
2793 end Has_Null_Extension
;
2795 ---------------------------
2796 -- Has_Private_Component --
2797 ---------------------------
2799 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
2800 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
2801 Component
: Entity_Id
;
2804 if Error_Posted
(Type_Id
)
2805 or else Error_Posted
(Btype
)
2810 if Is_Class_Wide_Type
(Btype
) then
2811 Btype
:= Root_Type
(Btype
);
2814 if Is_Private_Type
(Btype
) then
2816 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
2820 if No
(Full_View
(Btype
)) then
2821 return not Is_Generic_Type
(Btype
)
2822 and then not Is_Generic_Type
(Root_Type
(Btype
));
2825 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
2829 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
2832 elsif Is_Array_Type
(Btype
) then
2833 return Has_Private_Component
(Component_Type
(Btype
));
2835 elsif Is_Record_Type
(Btype
) then
2837 Component
:= First_Component
(Btype
);
2838 while Present
(Component
) loop
2840 if Has_Private_Component
(Etype
(Component
)) then
2844 Next_Component
(Component
);
2849 elsif Is_Protected_Type
(Btype
)
2850 and then Present
(Corresponding_Record_Type
(Btype
))
2852 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
2857 end Has_Private_Component
;
2859 --------------------------
2860 -- Has_Tagged_Component --
2861 --------------------------
2863 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
2867 if Is_Private_Type
(Typ
)
2868 and then Present
(Underlying_Type
(Typ
))
2870 return Has_Tagged_Component
(Underlying_Type
(Typ
));
2872 elsif Is_Array_Type
(Typ
) then
2873 return Has_Tagged_Component
(Component_Type
(Typ
));
2875 elsif Is_Tagged_Type
(Typ
) then
2878 elsif Is_Record_Type
(Typ
) then
2879 Comp
:= First_Component
(Typ
);
2881 while Present
(Comp
) loop
2882 if Has_Tagged_Component
(Etype
(Comp
)) then
2886 Comp
:= Next_Component
(Typ
);
2894 end Has_Tagged_Component
;
2900 function In_Instance
return Boolean is
2901 S
: Entity_Id
:= Current_Scope
;
2905 and then S
/= Standard_Standard
2907 if (Ekind
(S
) = E_Function
2908 or else Ekind
(S
) = E_Package
2909 or else Ekind
(S
) = E_Procedure
)
2910 and then Is_Generic_Instance
(S
)
2921 ----------------------
2922 -- In_Instance_Body --
2923 ----------------------
2925 function In_Instance_Body
return Boolean is
2926 S
: Entity_Id
:= Current_Scope
;
2930 and then S
/= Standard_Standard
2932 if (Ekind
(S
) = E_Function
2933 or else Ekind
(S
) = E_Procedure
)
2934 and then Is_Generic_Instance
(S
)
2938 elsif Ekind
(S
) = E_Package
2939 and then In_Package_Body
(S
)
2940 and then Is_Generic_Instance
(S
)
2949 end In_Instance_Body
;
2951 -----------------------------
2952 -- In_Instance_Not_Visible --
2953 -----------------------------
2955 function In_Instance_Not_Visible
return Boolean is
2956 S
: Entity_Id
:= Current_Scope
;
2960 and then S
/= Standard_Standard
2962 if (Ekind
(S
) = E_Function
2963 or else Ekind
(S
) = E_Procedure
)
2964 and then Is_Generic_Instance
(S
)
2968 elsif Ekind
(S
) = E_Package
2969 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
2970 and then Is_Generic_Instance
(S
)
2979 end In_Instance_Not_Visible
;
2981 ------------------------------
2982 -- In_Instance_Visible_Part --
2983 ------------------------------
2985 function In_Instance_Visible_Part
return Boolean is
2986 S
: Entity_Id
:= Current_Scope
;
2990 and then S
/= Standard_Standard
2992 if Ekind
(S
) = E_Package
2993 and then Is_Generic_Instance
(S
)
2994 and then not In_Package_Body
(S
)
2995 and then not In_Private_Part
(S
)
3004 end In_Instance_Visible_Part
;
3006 ----------------------
3007 -- In_Packiage_Body --
3008 ----------------------
3010 function In_Package_Body
return Boolean is
3011 S
: Entity_Id
:= Current_Scope
;
3015 and then S
/= Standard_Standard
3017 if Ekind
(S
) = E_Package
3018 and then In_Package_Body
(S
)
3027 end In_Package_Body
;
3029 --------------------------------------
3030 -- In_Subprogram_Or_Concurrent_Unit --
3031 --------------------------------------
3033 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
3038 -- Use scope chain to check successively outer scopes
3044 if K
in Subprogram_Kind
3045 or else K
in Concurrent_Kind
3046 or else K
in Generic_Subprogram_Kind
3050 elsif E
= Standard_Standard
then
3056 end In_Subprogram_Or_Concurrent_Unit
;
3058 ---------------------
3059 -- In_Visible_Part --
3060 ---------------------
3062 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
3065 Is_Package
(Scope_Id
)
3066 and then In_Open_Scopes
(Scope_Id
)
3067 and then not In_Package_Body
(Scope_Id
)
3068 and then not In_Private_Part
(Scope_Id
);
3069 end In_Visible_Part
;
3071 ---------------------------------
3072 -- Insert_Explicit_Dereference --
3073 ---------------------------------
3075 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
3076 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
3082 Save_Interps
(N
, New_Prefix
);
3084 Make_Explicit_Dereference
(Sloc
(N
), Prefix
=> New_Prefix
));
3086 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
3088 if Is_Overloaded
(New_Prefix
) then
3090 -- The deference is also overloaded, and its interpretations are the
3091 -- designated types of the interpretations of the original node.
3093 Set_Etype
(N
, Any_Type
);
3094 Get_First_Interp
(New_Prefix
, I
, It
);
3096 while Present
(It
.Nam
) loop
3099 if Is_Access_Type
(T
) then
3100 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
3103 Get_Next_Interp
(I
, It
);
3108 end Insert_Explicit_Dereference
;
3114 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
3116 pragma Assert
(Is_Type
(E
));
3118 return AAMP_On_Target
3119 and then Is_Floating_Point_Type
(E
)
3120 and then E
= Base_Type
(E
);
3123 -------------------------
3124 -- Is_Actual_Parameter --
3125 -------------------------
3127 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
3128 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3132 when N_Parameter_Association
=>
3133 return N
= Explicit_Actual_Parameter
(Parent
(N
));
3135 when N_Function_Call | N_Procedure_Call_Statement
=>
3136 return Is_List_Member
(N
)
3138 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
3143 end Is_Actual_Parameter
;
3145 ---------------------
3146 -- Is_Aliased_View --
3147 ---------------------
3149 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
3153 if Is_Entity_Name
(Obj
) then
3155 -- Shouldn't we check that we really have an object here?
3156 -- If we do, then a-caldel.adb blows up mysteriously ???
3160 return Is_Aliased
(E
)
3161 or else (Present
(Renamed_Object
(E
))
3162 and then Is_Aliased_View
(Renamed_Object
(E
)))
3164 or else ((Is_Formal
(E
)
3165 or else Ekind
(E
) = E_Generic_In_Out_Parameter
3166 or else Ekind
(E
) = E_Generic_In_Parameter
)
3167 and then Is_Tagged_Type
(Etype
(E
)))
3169 or else ((Ekind
(E
) = E_Task_Type
or else
3170 Ekind
(E
) = E_Protected_Type
)
3171 and then In_Open_Scopes
(E
))
3173 -- Current instance of type
3175 or else (Is_Type
(E
) and then E
= Current_Scope
)
3176 or else (Is_Incomplete_Or_Private_Type
(E
)
3177 and then Full_View
(E
) = Current_Scope
);
3179 elsif Nkind
(Obj
) = N_Selected_Component
then
3180 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
3182 elsif Nkind
(Obj
) = N_Indexed_Component
then
3183 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
3185 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
3187 Has_Aliased_Components
3188 (Designated_Type
(Etype
(Prefix
(Obj
)))));
3190 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
3191 or else Nkind
(Obj
) = N_Type_Conversion
3193 return Is_Tagged_Type
(Etype
(Obj
))
3194 and then Is_Aliased_View
(Expression
(Obj
));
3196 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
3197 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
3202 end Is_Aliased_View
;
3204 -------------------------
3205 -- Is_Ancestor_Package --
3206 -------------------------
3208 function Is_Ancestor_Package
3210 E2
: Entity_Id
) return Boolean
3217 and then Par
/= Standard_Standard
3227 end Is_Ancestor_Package
;
3229 ----------------------
3230 -- Is_Atomic_Object --
3231 ----------------------
3233 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
3235 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
3236 -- Determines if given object has atomic components
3238 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
3239 -- If prefix is an implicit dereference, examine designated type.
3241 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
3243 if Is_Access_Type
(Etype
(N
)) then
3245 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
3247 return Object_Has_Atomic_Components
(N
);
3249 end Is_Atomic_Prefix
;
3251 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
3253 if Has_Atomic_Components
(Etype
(N
))
3254 or else Is_Atomic
(Etype
(N
))
3258 elsif Is_Entity_Name
(N
)
3259 and then (Has_Atomic_Components
(Entity
(N
))
3260 or else Is_Atomic
(Entity
(N
)))
3264 elsif Nkind
(N
) = N_Indexed_Component
3265 or else Nkind
(N
) = N_Selected_Component
3267 return Is_Atomic_Prefix
(Prefix
(N
));
3272 end Object_Has_Atomic_Components
;
3274 -- Start of processing for Is_Atomic_Object
3277 if Is_Atomic
(Etype
(N
))
3278 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
3282 elsif Nkind
(N
) = N_Indexed_Component
3283 or else Nkind
(N
) = N_Selected_Component
3285 return Is_Atomic_Prefix
(Prefix
(N
));
3290 end Is_Atomic_Object
;
3292 ----------------------------------------------
3293 -- Is_Dependent_Component_Of_Mutable_Object --
3294 ----------------------------------------------
3296 function Is_Dependent_Component_Of_Mutable_Object
3297 (Object
: Node_Id
) return Boolean
3300 Prefix_Type
: Entity_Id
;
3301 P_Aliased
: Boolean := False;
3304 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean;
3305 -- Returns True if and only if Comp has a constrained subtype
3306 -- that depends on a discriminant.
3308 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
3309 -- Returns True if and only if Comp is declared within a variant part.
3311 ------------------------------
3312 -- Has_Dependent_Constraint --
3313 ------------------------------
3315 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean is
3316 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3317 Subt_Indic
: constant Node_Id
:=
3318 Subtype_Indication
(Component_Definition
(Comp_Decl
));
3323 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
3324 Constr
:= Constraint
(Subt_Indic
);
3326 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
3327 Assn
:= First
(Constraints
(Constr
));
3328 while Present
(Assn
) loop
3329 case Nkind
(Assn
) is
3330 when N_Subtype_Indication |
3334 if Depends_On_Discriminant
(Assn
) then
3338 when N_Discriminant_Association
=>
3339 if Depends_On_Discriminant
(Expression
(Assn
)) then
3354 end Has_Dependent_Constraint
;
3356 --------------------------------
3357 -- Is_Declared_Within_Variant --
3358 --------------------------------
3360 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
3361 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3362 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
3365 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
3366 end Is_Declared_Within_Variant
;
3368 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
3371 if Is_Variable
(Object
) then
3373 if Nkind
(Object
) = N_Selected_Component
then
3374 P
:= Prefix
(Object
);
3375 Prefix_Type
:= Etype
(P
);
3377 if Is_Entity_Name
(P
) then
3379 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
3380 Prefix_Type
:= Base_Type
(Prefix_Type
);
3383 if Is_Aliased
(Entity
(P
)) then
3387 -- A discriminant check on a selected component may be
3388 -- expanded into a dereference when removing side-effects.
3389 -- Recover the original node and its type, which may be
3392 elsif Nkind
(P
) = N_Explicit_Dereference
3393 and then not (Comes_From_Source
(P
))
3395 P
:= Original_Node
(P
);
3396 Prefix_Type
:= Etype
(P
);
3399 -- Check for prefix being an aliased component ???
3404 if Is_Access_Type
(Prefix_Type
)
3405 or else Nkind
(P
) = N_Explicit_Dereference
3411 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
3413 -- As per AI-0017, the renaming is illegal in a generic body,
3414 -- even if the subtype is indefinite.
3416 if not Is_Constrained
(Prefix_Type
)
3417 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
3419 (Is_Generic_Type
(Prefix_Type
)
3420 and then Ekind
(Current_Scope
) = E_Generic_Package
3421 and then In_Package_Body
(Current_Scope
)))
3423 and then (Is_Declared_Within_Variant
(Comp
)
3424 or else Has_Dependent_Constraint
(Comp
))
3425 and then not P_Aliased
3431 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3435 elsif Nkind
(Object
) = N_Indexed_Component
3436 or else Nkind
(Object
) = N_Slice
3438 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3440 -- A type conversion that Is_Variable is a view conversion:
3441 -- go back to the denoted object.
3443 elsif Nkind
(Object
) = N_Type_Conversion
then
3445 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
3450 end Is_Dependent_Component_Of_Mutable_Object
;
3452 ---------------------
3453 -- Is_Dereferenced --
3454 ---------------------
3456 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
3457 P
: constant Node_Id
:= Parent
(N
);
3461 (Nkind
(P
) = N_Selected_Component
3463 Nkind
(P
) = N_Explicit_Dereference
3465 Nkind
(P
) = N_Indexed_Component
3467 Nkind
(P
) = N_Slice
)
3468 and then Prefix
(P
) = N
;
3469 end Is_Dereferenced
;
3471 ----------------------
3472 -- Is_Descendent_Of --
3473 ----------------------
3475 function Is_Descendent_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
3480 pragma Assert
(Nkind
(T1
) in N_Entity
);
3481 pragma Assert
(Nkind
(T2
) in N_Entity
);
3483 T
:= Base_Type
(T1
);
3485 -- Immediate return if the types match
3490 -- Comment needed here ???
3492 elsif Ekind
(T
) = E_Class_Wide_Type
then
3493 return Etype
(T
) = T2
;
3501 -- Done if we found the type we are looking for
3506 -- Done if no more derivations to check
3513 -- Following test catches error cases resulting from prev errors
3515 elsif No
(Etyp
) then
3518 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
3521 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
3525 T
:= Base_Type
(Etyp
);
3529 raise Program_Error
;
3530 end Is_Descendent_Of
;
3532 ------------------------------
3533 -- Is_Descendent_Of_Address --
3534 ------------------------------
3536 function Is_Descendent_Of_Address
(T1
: Entity_Id
) return Boolean is
3538 -- If Address has not been loaded, answer must be False
3540 if not RTU_Loaded
(System
) then
3543 -- Otherwise we can get the entity we are interested in without
3544 -- causing an unwanted dependency on System, and do the test.
3547 return Is_Descendent_Of
(T1
, Base_Type
(RTE
(RE_Address
)));
3549 end Is_Descendent_Of_Address
;
3555 function Is_False
(U
: Uint
) return Boolean is
3560 ---------------------------
3561 -- Is_Fixed_Model_Number --
3562 ---------------------------
3564 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
3565 S
: constant Ureal
:= Small_Value
(T
);
3566 M
: Urealp
.Save_Mark
;
3571 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
3574 end Is_Fixed_Model_Number
;
3576 -------------------------------
3577 -- Is_Fully_Initialized_Type --
3578 -------------------------------
3580 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
3582 if Is_Scalar_Type
(Typ
) then
3585 elsif Is_Access_Type
(Typ
) then
3588 elsif Is_Array_Type
(Typ
) then
3589 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
3593 -- An interesting case, if we have a constrained type one of whose
3594 -- bounds is known to be null, then there are no elements to be
3595 -- initialized, so all the elements are initialized!
3597 if Is_Constrained
(Typ
) then
3600 Indx_Typ
: Entity_Id
;
3604 Indx
:= First_Index
(Typ
);
3605 while Present
(Indx
) loop
3607 if Etype
(Indx
) = Any_Type
then
3610 -- If index is a range, use directly.
3612 elsif Nkind
(Indx
) = N_Range
then
3613 Lbd
:= Low_Bound
(Indx
);
3614 Hbd
:= High_Bound
(Indx
);
3617 Indx_Typ
:= Etype
(Indx
);
3619 if Is_Private_Type
(Indx_Typ
) then
3620 Indx_Typ
:= Full_View
(Indx_Typ
);
3623 if No
(Indx_Typ
) then
3626 Lbd
:= Type_Low_Bound
(Indx_Typ
);
3627 Hbd
:= Type_High_Bound
(Indx_Typ
);
3631 if Compile_Time_Known_Value
(Lbd
)
3632 and then Compile_Time_Known_Value
(Hbd
)
3634 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
3644 -- If no null indexes, then type is not fully initialized
3650 elsif Is_Record_Type
(Typ
) then
3651 if Has_Discriminants
(Typ
)
3653 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
3654 and then Is_Fully_Initialized_Variant
(Typ
)
3659 -- Controlled records are considered to be fully initialized if
3660 -- there is a user defined Initialize routine. This may not be
3661 -- entirely correct, but as the spec notes, we are guessing here
3662 -- what is best from the point of view of issuing warnings.
3664 if Is_Controlled
(Typ
) then
3666 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3669 if Present
(Utyp
) then
3671 Init
: constant Entity_Id
:=
3673 (Underlying_Type
(Typ
), Name_Initialize
));
3677 and then Comes_From_Source
(Init
)
3679 Is_Predefined_File_Name
3680 (File_Name
(Get_Source_File_Index
(Sloc
(Init
))))
3684 elsif Has_Null_Extension
(Typ
)
3686 Is_Fully_Initialized_Type
3687 (Etype
(Base_Type
(Typ
)))
3696 -- Otherwise see if all record components are initialized
3702 Ent
:= First_Entity
(Typ
);
3704 while Present
(Ent
) loop
3705 if Chars
(Ent
) = Name_uController
then
3708 elsif Ekind
(Ent
) = E_Component
3709 and then (No
(Parent
(Ent
))
3710 or else No
(Expression
(Parent
(Ent
))))
3711 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
3720 -- No uninitialized components, so type is fully initialized.
3721 -- Note that this catches the case of no components as well.
3725 elsif Is_Concurrent_Type
(Typ
) then
3728 elsif Is_Private_Type
(Typ
) then
3730 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3736 return Is_Fully_Initialized_Type
(U
);
3743 end Is_Fully_Initialized_Type
;
3745 ----------------------------------
3746 -- Is_Fully_Initialized_Variant --
3747 ----------------------------------
3749 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
3750 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3751 Constraints
: constant List_Id
:= New_List
;
3752 Components
: constant Elist_Id
:= New_Elmt_List
;
3753 Comp_Elmt
: Elmt_Id
;
3755 Comp_List
: Node_Id
;
3757 Discr_Val
: Node_Id
;
3758 Report_Errors
: Boolean;
3761 if Serious_Errors_Detected
> 0 then
3765 if Is_Record_Type
(Typ
)
3766 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
3767 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
3769 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
3770 Discr
:= First_Discriminant
(Typ
);
3772 while Present
(Discr
) loop
3773 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
3774 Discr_Val
:= Expression
(Parent
(Discr
));
3775 if not Is_OK_Static_Expression
(Discr_Val
) then
3778 Append_To
(Constraints
,
3779 Make_Component_Association
(Loc
,
3780 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
3781 Expression
=> New_Copy
(Discr_Val
)));
3788 Next_Discriminant
(Discr
);
3793 Comp_List
=> Comp_List
,
3794 Governed_By
=> Constraints
,
3796 Report_Errors
=> Report_Errors
);
3798 -- Check that each component present is fully initialized.
3800 Comp_Elmt
:= First_Elmt
(Components
);
3802 while Present
(Comp_Elmt
) loop
3803 Comp_Id
:= Node
(Comp_Elmt
);
3805 if Ekind
(Comp_Id
) = E_Component
3806 and then (No
(Parent
(Comp_Id
))
3807 or else No
(Expression
(Parent
(Comp_Id
))))
3808 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
3813 Next_Elmt
(Comp_Elmt
);
3818 elsif Is_Private_Type
(Typ
) then
3820 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3826 return Is_Fully_Initialized_Variant
(U
);
3832 end Is_Fully_Initialized_Variant
;
3834 ----------------------------
3835 -- Is_Inherited_Operation --
3836 ----------------------------
3838 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
3839 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
3842 pragma Assert
(Is_Overloadable
(E
));
3843 return Kind
= N_Full_Type_Declaration
3844 or else Kind
= N_Private_Extension_Declaration
3845 or else Kind
= N_Subtype_Declaration
3846 or else (Ekind
(E
) = E_Enumeration_Literal
3847 and then Is_Derived_Type
(Etype
(E
)));
3848 end Is_Inherited_Operation
;
3850 -----------------------------
3851 -- Is_Library_Level_Entity --
3852 -----------------------------
3854 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
3856 -- The following is a small optimization, and it also handles
3857 -- properly discriminals, which in task bodies might appear in
3858 -- expressions before the corresponding procedure has been
3859 -- created, and which therefore do not have an assigned scope.
3861 if Ekind
(E
) in Formal_Kind
then
3865 -- Normal test is simply that the enclosing dynamic scope is Standard
3867 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
3868 end Is_Library_Level_Entity
;
3870 ---------------------------------
3871 -- Is_Local_Variable_Reference --
3872 ---------------------------------
3874 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
3876 if not Is_Entity_Name
(Expr
) then
3881 Ent
: constant Entity_Id
:= Entity
(Expr
);
3882 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
3885 if Ekind
(Ent
) /= E_Variable
3887 Ekind
(Ent
) /= E_In_Out_Parameter
3892 return Present
(Sub
) and then Sub
= Current_Subprogram
;
3896 end Is_Local_Variable_Reference
;
3902 function Is_Lvalue
(N
: Node_Id
) return Boolean is
3903 P
: constant Node_Id
:= Parent
(N
);
3908 -- Test left side of assignment
3910 when N_Assignment_Statement
=>
3911 return N
= Name
(P
);
3913 -- Test prefix of component or attribute
3915 when N_Attribute_Reference |
3917 N_Explicit_Dereference |
3918 N_Indexed_Component |
3920 N_Selected_Component |
3922 return N
= Prefix
(P
);
3924 -- Test subprogram parameter (we really should check the
3925 -- parameter mode, but it is not worth the trouble)
3927 when N_Function_Call |
3928 N_Procedure_Call_Statement |
3929 N_Accept_Statement |
3930 N_Parameter_Association
=>
3933 -- Test for appearing in a conversion that itself appears
3934 -- in an lvalue context, since this should be an lvalue.
3936 when N_Type_Conversion
=>
3937 return Is_Lvalue
(P
);
3939 -- Test for appearence in object renaming declaration
3941 when N_Object_Renaming_Declaration
=>
3944 -- All other references are definitely not Lvalues
3952 -------------------------
3953 -- Is_Object_Reference --
3954 -------------------------
3956 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
3958 if Is_Entity_Name
(N
) then
3959 return Is_Object
(Entity
(N
));
3963 when N_Indexed_Component | N_Slice
=>
3964 return Is_Object_Reference
(Prefix
(N
));
3966 -- In Ada95, a function call is a constant object
3968 when N_Function_Call
=>
3971 -- A reference to the stream attribute Input is a function call
3973 when N_Attribute_Reference
=>
3974 return Attribute_Name
(N
) = Name_Input
;
3976 when N_Selected_Component
=>
3978 Is_Object_Reference
(Selector_Name
(N
))
3979 and then Is_Object_Reference
(Prefix
(N
));
3981 when N_Explicit_Dereference
=>
3984 -- A view conversion of a tagged object is an object reference.
3986 when N_Type_Conversion
=>
3987 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
3988 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
3989 and then Is_Object_Reference
(Expression
(N
));
3991 -- An unchecked type conversion is considered to be an object if
3992 -- the operand is an object (this construction arises only as a
3993 -- result of expansion activities).
3995 when N_Unchecked_Type_Conversion
=>
4002 end Is_Object_Reference
;
4004 -----------------------------------
4005 -- Is_OK_Variable_For_Out_Formal --
4006 -----------------------------------
4008 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
4010 Note_Possible_Modification
(AV
);
4012 -- We must reject parenthesized variable names. The check for
4013 -- Comes_From_Source is present because there are currently
4014 -- cases where the compiler violates this rule (e.g. passing
4015 -- a task object to its controlled Initialize routine).
4017 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
4020 -- A variable is always allowed
4022 elsif Is_Variable
(AV
) then
4025 -- Unchecked conversions are allowed only if they come from the
4026 -- generated code, which sometimes uses unchecked conversions for
4027 -- out parameters in cases where code generation is unaffected.
4028 -- We tell source unchecked conversions by seeing if they are
4029 -- rewrites of an original UC function call, or of an explicit
4030 -- conversion of a function call.
4032 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
4033 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
4036 elsif Comes_From_Source
(AV
)
4037 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
4041 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
4042 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
4048 -- Normal type conversions are allowed if argument is a variable
4050 elsif Nkind
(AV
) = N_Type_Conversion
then
4051 if Is_Variable
(Expression
(AV
))
4052 and then Paren_Count
(Expression
(AV
)) = 0
4054 Note_Possible_Modification
(Expression
(AV
));
4057 -- We also allow a non-parenthesized expression that raises
4058 -- constraint error if it rewrites what used to be a variable
4060 elsif Raises_Constraint_Error
(Expression
(AV
))
4061 and then Paren_Count
(Expression
(AV
)) = 0
4062 and then Is_Variable
(Original_Node
(Expression
(AV
)))
4066 -- Type conversion of something other than a variable
4072 -- If this node is rewritten, then test the original form, if that is
4073 -- OK, then we consider the rewritten node OK (for example, if the
4074 -- original node is a conversion, then Is_Variable will not be true
4075 -- but we still want to allow the conversion if it converts a variable).
4077 elsif Original_Node
(AV
) /= AV
then
4078 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
4080 -- All other non-variables are rejected
4085 end Is_OK_Variable_For_Out_Formal
;
4087 -----------------------------------
4088 -- Is_Partially_Initialized_Type --
4089 -----------------------------------
4091 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
4093 if Is_Scalar_Type
(Typ
) then
4096 elsif Is_Access_Type
(Typ
) then
4099 elsif Is_Array_Type
(Typ
) then
4101 -- If component type is partially initialized, so is array type
4103 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
4106 -- Otherwise we are only partially initialized if we are fully
4107 -- initialized (this is the empty array case, no point in us
4108 -- duplicating that code here).
4111 return Is_Fully_Initialized_Type
(Typ
);
4114 elsif Is_Record_Type
(Typ
) then
4116 -- A discriminated type is always partially initialized
4118 if Has_Discriminants
(Typ
) then
4121 -- A tagged type is always partially initialized
4123 elsif Is_Tagged_Type
(Typ
) then
4126 -- Case of non-discriminated record
4132 Component_Present
: Boolean := False;
4133 -- Set True if at least one component is present. If no
4134 -- components are present, then record type is fully
4135 -- initialized (another odd case, like the null array).
4138 -- Loop through components
4140 Ent
:= First_Entity
(Typ
);
4141 while Present
(Ent
) loop
4142 if Ekind
(Ent
) = E_Component
then
4143 Component_Present
:= True;
4145 -- If a component has an initialization expression then
4146 -- the enclosing record type is partially initialized
4148 if Present
(Parent
(Ent
))
4149 and then Present
(Expression
(Parent
(Ent
)))
4153 -- If a component is of a type which is itself partially
4154 -- initialized, then the enclosing record type is also.
4156 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
4164 -- No initialized components found. If we found any components
4165 -- they were all uninitialized so the result is false.
4167 if Component_Present
then
4170 -- But if we found no components, then all the components are
4171 -- initialized so we consider the type to be initialized.
4179 -- Concurrent types are always fully initialized
4181 elsif Is_Concurrent_Type
(Typ
) then
4184 -- For a private type, go to underlying type. If there is no underlying
4185 -- type then just assume this partially initialized. Not clear if this
4186 -- can happen in a non-error case, but no harm in testing for this.
4188 elsif Is_Private_Type
(Typ
) then
4190 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4196 return Is_Partially_Initialized_Type
(U
);
4200 -- For any other type (are there any?) assume partially initialized
4205 end Is_Partially_Initialized_Type
;
4207 -----------------------------
4208 -- Is_RCI_Pkg_Spec_Or_Body --
4209 -----------------------------
4211 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
4213 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
4214 -- Return True if the unit of Cunit is an RCI package declaration
4216 ---------------------------
4217 -- Is_RCI_Pkg_Decl_Cunit --
4218 ---------------------------
4220 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
4221 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
4224 if Nkind
(The_Unit
) /= N_Package_Declaration
then
4227 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
4228 end Is_RCI_Pkg_Decl_Cunit
;
4230 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
4233 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
4235 (Nkind
(Unit
(Cunit
)) = N_Package_Body
4236 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
4237 end Is_RCI_Pkg_Spec_Or_Body
;
4239 -----------------------------------------
4240 -- Is_Remote_Access_To_Class_Wide_Type --
4241 -----------------------------------------
4243 function Is_Remote_Access_To_Class_Wide_Type
4244 (E
: Entity_Id
) return Boolean
4248 function Comes_From_Limited_Private_Type_Declaration
4251 -- Check that the type is declared by a limited type declaration,
4252 -- or else is derived from a Remote_Type ancestor through private
4255 -------------------------------------------------
4256 -- Comes_From_Limited_Private_Type_Declaration --
4257 -------------------------------------------------
4259 function Comes_From_Limited_Private_Type_Declaration
(E
: in Entity_Id
)
4262 N
: constant Node_Id
:= Declaration_Node
(E
);
4264 if Nkind
(N
) = N_Private_Type_Declaration
4265 and then Limited_Present
(N
)
4270 if Nkind
(N
) = N_Private_Extension_Declaration
then
4272 Comes_From_Limited_Private_Type_Declaration
(Etype
(E
))
4274 (Is_Remote_Types
(Etype
(E
))
4275 and then Is_Limited_Record
(Etype
(E
))
4276 and then Has_Private_Declaration
(Etype
(E
)));
4280 end Comes_From_Limited_Private_Type_Declaration
;
4282 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
4285 if not (Is_Remote_Call_Interface
(E
)
4286 or else Is_Remote_Types
(E
))
4287 or else Ekind
(E
) /= E_General_Access_Type
4292 D
:= Designated_Type
(E
);
4294 if Ekind
(D
) /= E_Class_Wide_Type
then
4298 return Comes_From_Limited_Private_Type_Declaration
4299 (Defining_Identifier
(Parent
(D
)));
4300 end Is_Remote_Access_To_Class_Wide_Type
;
4302 -----------------------------------------
4303 -- Is_Remote_Access_To_Subprogram_Type --
4304 -----------------------------------------
4306 function Is_Remote_Access_To_Subprogram_Type
4307 (E
: Entity_Id
) return Boolean
4310 return (Ekind
(E
) = E_Access_Subprogram_Type
4311 or else (Ekind
(E
) = E_Record_Type
4312 and then Present
(Corresponding_Remote_Type
(E
))))
4313 and then (Is_Remote_Call_Interface
(E
)
4314 or else Is_Remote_Types
(E
));
4315 end Is_Remote_Access_To_Subprogram_Type
;
4317 --------------------
4318 -- Is_Remote_Call --
4319 --------------------
4321 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
4323 if Nkind
(N
) /= N_Procedure_Call_Statement
4324 and then Nkind
(N
) /= N_Function_Call
4326 -- An entry call cannot be remote
4330 elsif Nkind
(Name
(N
)) in N_Has_Entity
4331 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
4333 -- A subprogram declared in the spec of a RCI package is remote
4337 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
4338 and then Is_Remote_Access_To_Subprogram_Type
4339 (Etype
(Prefix
(Name
(N
))))
4341 -- The dereference of a RAS is a remote call
4345 elsif Present
(Controlling_Argument
(N
))
4346 and then Is_Remote_Access_To_Class_Wide_Type
4347 (Etype
(Controlling_Argument
(N
)))
4349 -- Any primitive operation call with a controlling argument of
4350 -- a RACW type is a remote call.
4355 -- All other calls are local calls
4360 ----------------------
4361 -- Is_Selector_Name --
4362 ----------------------
4364 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
4367 if not Is_List_Member
(N
) then
4369 P
: constant Node_Id
:= Parent
(N
);
4370 K
: constant Node_Kind
:= Nkind
(P
);
4374 (K
= N_Expanded_Name
or else
4375 K
= N_Generic_Association
or else
4376 K
= N_Parameter_Association
or else
4377 K
= N_Selected_Component
)
4378 and then Selector_Name
(P
) = N
;
4383 L
: constant List_Id
:= List_Containing
(N
);
4384 P
: constant Node_Id
:= Parent
(L
);
4387 return (Nkind
(P
) = N_Discriminant_Association
4388 and then Selector_Names
(P
) = L
)
4390 (Nkind
(P
) = N_Component_Association
4391 and then Choices
(P
) = L
);
4394 end Is_Selector_Name
;
4400 function Is_Statement
(N
: Node_Id
) return Boolean is
4403 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
4404 or else Nkind
(N
) = N_Procedure_Call_Statement
;
4411 function Is_Transfer
(N
: Node_Id
) return Boolean is
4412 Kind
: constant Node_Kind
:= Nkind
(N
);
4415 if Kind
= N_Return_Statement
4417 Kind
= N_Goto_Statement
4419 Kind
= N_Raise_Statement
4421 Kind
= N_Requeue_Statement
4425 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
4426 and then No
(Condition
(N
))
4430 elsif Kind
= N_Procedure_Call_Statement
4431 and then Is_Entity_Name
(Name
(N
))
4432 and then Present
(Entity
(Name
(N
)))
4433 and then No_Return
(Entity
(Name
(N
)))
4437 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
4449 function Is_True
(U
: Uint
) return Boolean is
4458 function Is_Variable
(N
: Node_Id
) return Boolean is
4460 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
4461 -- We do the test on the original node, since this is basically a
4462 -- test of syntactic categories, so it must not be disturbed by
4463 -- whatever rewriting might have occurred. For example, an aggregate,
4464 -- which is certainly NOT a variable, could be turned into a variable
4467 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
4468 -- Within a protected function, the private components of the
4469 -- enclosing protected type are constants. A function nested within
4470 -- a (protected) procedure is not itself protected.
4472 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
4473 -- Prefixes can involve implicit dereferences, in which case we
4474 -- must test for the case of a reference of a constant access
4475 -- type, which can never be a variable.
4477 ---------------------------
4478 -- In_Protected_Function --
4479 ---------------------------
4481 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
4482 Prot
: constant Entity_Id
:= Scope
(E
);
4486 if not Is_Protected_Type
(Prot
) then
4491 while Present
(S
) and then S
/= Prot
loop
4493 if Ekind
(S
) = E_Function
4494 and then Scope
(S
) = Prot
4504 end In_Protected_Function
;
4506 ------------------------
4507 -- Is_Variable_Prefix --
4508 ------------------------
4510 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
4512 if Is_Access_Type
(Etype
(P
)) then
4513 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
4515 return Is_Variable
(P
);
4517 end Is_Variable_Prefix
;
4519 -- Start of processing for Is_Variable
4522 -- Definitely OK if Assignment_OK is set. Since this is something that
4523 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
4525 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
4528 -- Normally we go to the original node, but there is one exception
4529 -- where we use the rewritten node, namely when it is an explicit
4530 -- dereference. The generated code may rewrite a prefix which is an
4531 -- access type with an explicit dereference. The dereference is a
4532 -- variable, even though the original node may not be (since it could
4533 -- be a constant of the access type).
4535 elsif Nkind
(N
) = N_Explicit_Dereference
4536 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
4537 and then Is_Access_Type
(Etype
(Orig_Node
))
4539 return Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
4541 -- All remaining checks use the original node
4543 elsif Is_Entity_Name
(Orig_Node
) then
4545 E
: constant Entity_Id
:= Entity
(Orig_Node
);
4546 K
: constant Entity_Kind
:= Ekind
(E
);
4549 return (K
= E_Variable
4550 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
4551 or else (K
= E_Component
4552 and then not In_Protected_Function
(E
))
4553 or else K
= E_Out_Parameter
4554 or else K
= E_In_Out_Parameter
4555 or else K
= E_Generic_In_Out_Parameter
4557 -- Current instance of type:
4559 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
4560 or else (Is_Incomplete_Or_Private_Type
(E
)
4561 and then In_Open_Scopes
(Full_View
(E
)));
4565 case Nkind
(Orig_Node
) is
4566 when N_Indexed_Component | N_Slice
=>
4567 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
4569 when N_Selected_Component
=>
4570 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
4571 and then Is_Variable
(Selector_Name
(Orig_Node
));
4573 -- For an explicit dereference, the type of the prefix cannot
4574 -- be an access to constant or an access to subprogram.
4576 when N_Explicit_Dereference
=>
4578 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
4581 return Is_Access_Type
(Typ
)
4582 and then not Is_Access_Constant
(Root_Type
(Typ
))
4583 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
4586 -- The type conversion is the case where we do not deal with the
4587 -- context dependent special case of an actual parameter. Thus
4588 -- the type conversion is only considered a variable for the
4589 -- purposes of this routine if the target type is tagged. However,
4590 -- a type conversion is considered to be a variable if it does not
4591 -- come from source (this deals for example with the conversions
4592 -- of expressions to their actual subtypes).
4594 when N_Type_Conversion
=>
4595 return Is_Variable
(Expression
(Orig_Node
))
4597 (not Comes_From_Source
(Orig_Node
)
4599 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
4601 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
4603 -- GNAT allows an unchecked type conversion as a variable. This
4604 -- only affects the generation of internal expanded code, since
4605 -- calls to instantiations of Unchecked_Conversion are never
4606 -- considered variables (since they are function calls).
4607 -- This is also true for expression actions.
4609 when N_Unchecked_Type_Conversion
=>
4610 return Is_Variable
(Expression
(Orig_Node
));
4618 ------------------------
4619 -- Is_Volatile_Object --
4620 ------------------------
4622 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
4624 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
4625 -- Determines if given object has volatile components
4627 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
4628 -- If prefix is an implicit dereference, examine designated type.
4630 ------------------------
4631 -- Is_Volatile_Prefix --
4632 ------------------------
4634 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
4635 Typ
: constant Entity_Id
:= Etype
(N
);
4638 if Is_Access_Type
(Typ
) then
4640 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
4643 return Is_Volatile
(Dtyp
)
4644 or else Has_Volatile_Components
(Dtyp
);
4648 return Object_Has_Volatile_Components
(N
);
4650 end Is_Volatile_Prefix
;
4652 ------------------------------------
4653 -- Object_Has_Volatile_Components --
4654 ------------------------------------
4656 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
4657 Typ
: constant Entity_Id
:= Etype
(N
);
4660 if Is_Volatile
(Typ
)
4661 or else Has_Volatile_Components
(Typ
)
4665 elsif Is_Entity_Name
(N
)
4666 and then (Has_Volatile_Components
(Entity
(N
))
4667 or else Is_Volatile
(Entity
(N
)))
4671 elsif Nkind
(N
) = N_Indexed_Component
4672 or else Nkind
(N
) = N_Selected_Component
4674 return Is_Volatile_Prefix
(Prefix
(N
));
4679 end Object_Has_Volatile_Components
;
4681 -- Start of processing for Is_Volatile_Object
4684 if Is_Volatile
(Etype
(N
))
4685 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
4689 elsif Nkind
(N
) = N_Indexed_Component
4690 or else Nkind
(N
) = N_Selected_Component
4692 return Is_Volatile_Prefix
(Prefix
(N
));
4697 end Is_Volatile_Object
;
4699 -------------------------
4700 -- Kill_Current_Values --
4701 -------------------------
4703 procedure Kill_Current_Values
is
4706 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
4707 -- Clear current value for entity E and all entities chained to E
4709 ------------------------------------------
4710 -- Kill_Current_Values_For_Entity_Chain --
4711 ------------------------------------------
4713 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
4718 while Present
(Ent
) loop
4719 if Is_Object
(Ent
) then
4720 Set_Current_Value
(Ent
, Empty
);
4722 if not Can_Never_Be_Null
(Ent
) then
4723 Set_Is_Known_Non_Null
(Ent
, False);
4729 end Kill_Current_Values_For_Entity_Chain
;
4731 -- Start of processing for Kill_Current_Values
4734 -- Kill all saved checks, a special case of killing saved values
4738 -- Loop through relevant scopes, which includes the current scope and
4739 -- any parent scopes if the current scope is a block or a package.
4744 -- Clear current values of all entities in current scope
4746 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
4748 -- If scope is a package, also clear current values of all
4749 -- private entities in the scope.
4751 if Ekind
(S
) = E_Package
4753 Ekind
(S
) = E_Generic_Package
4755 Is_Concurrent_Type
(S
)
4757 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
4760 -- If this is a block or nested package, deal with parent
4762 if Ekind
(S
) = E_Block
4763 or else (Ekind
(S
) = E_Package
4764 and then not Is_Library_Level_Entity
(S
))
4770 end loop Scope_Loop
;
4771 end Kill_Current_Values
;
4773 --------------------------
4774 -- Kill_Size_Check_Code --
4775 --------------------------
4777 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
4779 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
4780 and then Present
(Size_Check_Code
(E
))
4782 Remove
(Size_Check_Code
(E
));
4783 Set_Size_Check_Code
(E
, Empty
);
4785 end Kill_Size_Check_Code
;
4787 -------------------------
4788 -- New_External_Entity --
4789 -------------------------
4791 function New_External_Entity
4792 (Kind
: Entity_Kind
;
4793 Scope_Id
: Entity_Id
;
4794 Sloc_Value
: Source_Ptr
;
4795 Related_Id
: Entity_Id
;
4797 Suffix_Index
: Nat
:= 0;
4798 Prefix
: Character := ' ') return Entity_Id
4800 N
: constant Entity_Id
:=
4801 Make_Defining_Identifier
(Sloc_Value
,
4803 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
4806 Set_Ekind
(N
, Kind
);
4807 Set_Is_Internal
(N
, True);
4808 Append_Entity
(N
, Scope_Id
);
4809 Set_Public_Status
(N
);
4811 if Kind
in Type_Kind
then
4812 Init_Size_Align
(N
);
4816 end New_External_Entity
;
4818 -------------------------
4819 -- New_Internal_Entity --
4820 -------------------------
4822 function New_Internal_Entity
4823 (Kind
: Entity_Kind
;
4824 Scope_Id
: Entity_Id
;
4825 Sloc_Value
: Source_Ptr
;
4826 Id_Char
: Character) return Entity_Id
4828 N
: constant Entity_Id
:=
4829 Make_Defining_Identifier
(Sloc_Value
, New_Internal_Name
(Id_Char
));
4832 Set_Ekind
(N
, Kind
);
4833 Set_Is_Internal
(N
, True);
4834 Append_Entity
(N
, Scope_Id
);
4836 if Kind
in Type_Kind
then
4837 Init_Size_Align
(N
);
4841 end New_Internal_Entity
;
4847 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
4851 -- If we are pointing at a positional parameter, it is a member of
4852 -- a node list (the list of parameters), and the next parameter
4853 -- is the next node on the list, unless we hit a parameter
4854 -- association, in which case we shift to using the chain whose
4855 -- head is the First_Named_Actual in the parent, and then is
4856 -- threaded using the Next_Named_Actual of the Parameter_Association.
4857 -- All this fiddling is because the original node list is in the
4858 -- textual call order, and what we need is the declaration order.
4860 if Is_List_Member
(Actual_Id
) then
4861 N
:= Next
(Actual_Id
);
4863 if Nkind
(N
) = N_Parameter_Association
then
4864 return First_Named_Actual
(Parent
(Actual_Id
));
4870 return Next_Named_Actual
(Parent
(Actual_Id
));
4874 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
4876 Actual_Id
:= Next_Actual
(Actual_Id
);
4879 -----------------------
4880 -- Normalize_Actuals --
4881 -----------------------
4883 -- Chain actuals according to formals of subprogram. If there are
4884 -- no named associations, the chain is simply the list of Parameter
4885 -- Associations, since the order is the same as the declaration order.
4886 -- If there are named associations, then the First_Named_Actual field
4887 -- in the N_Procedure_Call_Statement node or N_Function_Call node
4888 -- points to the Parameter_Association node for the parameter that
4889 -- comes first in declaration order. The remaining named parameters
4890 -- are then chained in declaration order using Next_Named_Actual.
4892 -- This routine also verifies that the number of actuals is compatible
4893 -- with the number and default values of formals, but performs no type
4894 -- checking (type checking is done by the caller).
4896 -- If the matching succeeds, Success is set to True, and the caller
4897 -- proceeds with type-checking. If the match is unsuccessful, then
4898 -- Success is set to False, and the caller attempts a different
4899 -- interpretation, if there is one.
4901 -- If the flag Report is on, the call is not overloaded, and a failure
4902 -- to match can be reported here, rather than in the caller.
4904 procedure Normalize_Actuals
4908 Success
: out Boolean)
4910 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
4911 Actual
: Node_Id
:= Empty
;
4913 Last
: Node_Id
:= Empty
;
4914 First_Named
: Node_Id
:= Empty
;
4917 Formals_To_Match
: Integer := 0;
4918 Actuals_To_Match
: Integer := 0;
4920 procedure Chain
(A
: Node_Id
);
4921 -- Add named actual at the proper place in the list, using the
4922 -- Next_Named_Actual link.
4924 function Reporting
return Boolean;
4925 -- Determines if an error is to be reported. To report an error, we
4926 -- need Report to be True, and also we do not report errors caused
4927 -- by calls to init procs that occur within other init procs. Such
4928 -- errors must always be cascaded errors, since if all the types are
4929 -- declared correctly, the compiler will certainly build decent calls!
4935 procedure Chain
(A
: Node_Id
) is
4939 -- Call node points to first actual in list.
4941 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
4944 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
4948 Set_Next_Named_Actual
(Last
, Empty
);
4955 function Reporting
return Boolean is
4960 elsif not Within_Init_Proc
then
4963 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
4971 -- Start of processing for Normalize_Actuals
4974 if Is_Access_Type
(S
) then
4976 -- The name in the call is a function call that returns an access
4977 -- to subprogram. The designated type has the list of formals.
4979 Formal
:= First_Formal
(Designated_Type
(S
));
4981 Formal
:= First_Formal
(S
);
4984 while Present
(Formal
) loop
4985 Formals_To_Match
:= Formals_To_Match
+ 1;
4986 Next_Formal
(Formal
);
4989 -- Find if there is a named association, and verify that no positional
4990 -- associations appear after named ones.
4992 if Present
(Actuals
) then
4993 Actual
:= First
(Actuals
);
4996 while Present
(Actual
)
4997 and then Nkind
(Actual
) /= N_Parameter_Association
4999 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5003 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
5005 -- Most common case: positional notation, no defaults
5010 elsif Actuals_To_Match
> Formals_To_Match
then
5012 -- Too many actuals: will not work.
5015 if Is_Entity_Name
(Name
(N
)) then
5016 Error_Msg_N
("too many arguments in call to&", Name
(N
));
5018 Error_Msg_N
("too many arguments in call", N
);
5026 First_Named
:= Actual
;
5028 while Present
(Actual
) loop
5029 if Nkind
(Actual
) /= N_Parameter_Association
then
5031 ("positional parameters not allowed after named ones", Actual
);
5036 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5042 if Present
(Actuals
) then
5043 Actual
:= First
(Actuals
);
5046 Formal
:= First_Formal
(S
);
5047 while Present
(Formal
) loop
5049 -- Match the formals in order. If the corresponding actual
5050 -- is positional, nothing to do. Else scan the list of named
5051 -- actuals to find the one with the right name.
5054 and then Nkind
(Actual
) /= N_Parameter_Association
5057 Actuals_To_Match
:= Actuals_To_Match
- 1;
5058 Formals_To_Match
:= Formals_To_Match
- 1;
5061 -- For named parameters, search the list of actuals to find
5062 -- one that matches the next formal name.
5064 Actual
:= First_Named
;
5067 while Present
(Actual
) loop
5068 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
5071 Actuals_To_Match
:= Actuals_To_Match
- 1;
5072 Formals_To_Match
:= Formals_To_Match
- 1;
5080 if Ekind
(Formal
) /= E_In_Parameter
5081 or else No
(Default_Value
(Formal
))
5084 if (Comes_From_Source
(S
)
5085 or else Sloc
(S
) = Standard_Location
)
5086 and then Is_Overloadable
(S
)
5090 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
5092 (Nkind
(Parent
(N
)) = N_Function_Call
5094 Nkind
(Parent
(N
)) = N_Parameter_Association
))
5095 and then Ekind
(S
) /= E_Function
5097 Set_Etype
(N
, Etype
(S
));
5099 Error_Msg_Name_1
:= Chars
(S
);
5100 Error_Msg_Sloc
:= Sloc
(S
);
5102 ("missing argument for parameter & " &
5103 "in call to % declared #", N
, Formal
);
5106 elsif Is_Overloadable
(S
) then
5107 Error_Msg_Name_1
:= Chars
(S
);
5109 -- Point to type derivation that generated the
5112 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
5115 ("missing argument for parameter & " &
5116 "in call to % (inherited) #", N
, Formal
);
5120 ("missing argument for parameter &", N
, Formal
);
5128 Formals_To_Match
:= Formals_To_Match
- 1;
5133 Next_Formal
(Formal
);
5136 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
5143 -- Find some superfluous named actual that did not get
5144 -- attached to the list of associations.
5146 Actual
:= First
(Actuals
);
5148 while Present
(Actual
) loop
5149 if Nkind
(Actual
) = N_Parameter_Association
5150 and then Actual
/= Last
5151 and then No
(Next_Named_Actual
(Actual
))
5153 Error_Msg_N
("unmatched actual & in call",
5154 Selector_Name
(Actual
));
5165 end Normalize_Actuals
;
5167 --------------------------------
5168 -- Note_Possible_Modification --
5169 --------------------------------
5171 procedure Note_Possible_Modification
(N
: Node_Id
) is
5172 Modification_Comes_From_Source
: constant Boolean :=
5173 Comes_From_Source
(Parent
(N
));
5179 -- Loop to find referenced entity, if there is one
5186 if Is_Entity_Name
(Exp
) then
5187 Ent
:= Entity
(Exp
);
5189 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
5191 P
: constant Node_Id
:= Prefix
(Exp
);
5194 if Nkind
(P
) = N_Selected_Component
5196 Entry_Formal
(Entity
(Selector_Name
(P
))))
5198 -- Case of a reference to an entry formal
5200 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
5202 elsif Nkind
(P
) = N_Identifier
5203 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
5204 and then Present
(Expression
(Parent
(Entity
(P
))))
5205 and then Nkind
(Expression
(Parent
(Entity
(P
))))
5208 -- Case of a reference to a value on which
5209 -- side effects have been removed.
5211 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
5219 elsif Nkind
(Exp
) = N_Type_Conversion
5220 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
5222 Exp
:= Expression
(Exp
);
5224 elsif Nkind
(Exp
) = N_Slice
5225 or else Nkind
(Exp
) = N_Indexed_Component
5226 or else Nkind
(Exp
) = N_Selected_Component
5228 Exp
:= Prefix
(Exp
);
5235 -- Now look for entity being referenced
5237 if Present
(Ent
) then
5239 if Is_Object
(Ent
) then
5240 if Comes_From_Source
(Exp
)
5241 or else Modification_Comes_From_Source
5243 Set_Never_Set_In_Source
(Ent
, False);
5246 Set_Is_True_Constant
(Ent
, False);
5247 Set_Current_Value
(Ent
, Empty
);
5249 if not Can_Never_Be_Null
(Ent
) then
5250 Set_Is_Known_Non_Null
(Ent
, False);
5253 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
5254 and then Present
(Renamed_Object
(Ent
))
5256 Exp
:= Renamed_Object
(Ent
);
5260 Generate_Reference
(Ent
, Exp
, 'm');
5267 end Note_Possible_Modification
;
5269 -------------------------
5270 -- Object_Access_Level --
5271 -------------------------
5273 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
5276 -- Returns the static accessibility level of the view denoted
5277 -- by Obj. Note that the value returned is the result of a
5278 -- call to Scope_Depth. Only scope depths associated with
5279 -- dynamic scopes can actually be returned. Since only
5280 -- relative levels matter for accessibility checking, the fact
5281 -- that the distance between successive levels of accessibility
5282 -- is not always one is immaterial (invariant: if level(E2) is
5283 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
5286 if Is_Entity_Name
(Obj
) then
5289 -- If E is a type then it denotes a current instance.
5290 -- For this case we add one to the normal accessibility
5291 -- level of the type to ensure that current instances
5292 -- are treated as always being deeper than than the level
5293 -- of any visible named access type (see 3.10.2(21)).
5296 return Type_Access_Level
(E
) + 1;
5298 elsif Present
(Renamed_Object
(E
)) then
5299 return Object_Access_Level
(Renamed_Object
(E
));
5301 -- Similarly, if E is a component of the current instance of a
5302 -- protected type, any instance of it is assumed to be at a deeper
5303 -- level than the type. For a protected object (whose type is an
5304 -- anonymous protected type) its components are at the same level
5305 -- as the type itself.
5307 elsif not Is_Overloadable
(E
)
5308 and then Ekind
(Scope
(E
)) = E_Protected_Type
5309 and then Comes_From_Source
(Scope
(E
))
5311 return Type_Access_Level
(Scope
(E
)) + 1;
5314 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
5317 elsif Nkind
(Obj
) = N_Selected_Component
then
5318 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5319 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5321 return Object_Access_Level
(Prefix
(Obj
));
5324 elsif Nkind
(Obj
) = N_Indexed_Component
then
5325 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5326 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5328 return Object_Access_Level
(Prefix
(Obj
));
5331 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
5333 -- If the prefix is a selected access discriminant then
5334 -- we make a recursive call on the prefix, which will
5335 -- in turn check the level of the prefix object of
5336 -- the selected discriminant.
5338 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
5339 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
5341 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
5343 return Object_Access_Level
(Prefix
(Obj
));
5345 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5348 elsif Nkind
(Obj
) = N_Type_Conversion
5349 or else Nkind
(Obj
) = N_Unchecked_Type_Conversion
5351 return Object_Access_Level
(Expression
(Obj
));
5353 -- Function results are objects, so we get either the access level
5354 -- of the function or, in the case of an indirect call, the level of
5355 -- of the access-to-subprogram type.
5357 elsif Nkind
(Obj
) = N_Function_Call
then
5358 if Is_Entity_Name
(Name
(Obj
)) then
5359 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
5361 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
5364 -- For convenience we handle qualified expressions, even though
5365 -- they aren't technically object names.
5367 elsif Nkind
(Obj
) = N_Qualified_Expression
then
5368 return Object_Access_Level
(Expression
(Obj
));
5370 -- Otherwise return the scope level of Standard.
5371 -- (If there are cases that fall through
5372 -- to this point they will be treated as
5373 -- having global accessibility for now. ???)
5376 return Scope_Depth
(Standard_Standard
);
5378 end Object_Access_Level
;
5380 -----------------------
5381 -- Private_Component --
5382 -----------------------
5384 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
5385 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
5387 function Trace_Components
5389 Check
: Boolean) return Entity_Id
;
5390 -- Recursive function that does the work, and checks against circular
5391 -- definition for each subcomponent type.
5393 ----------------------
5394 -- Trace_Components --
5395 ----------------------
5397 function Trace_Components
5399 Check
: Boolean) return Entity_Id
5401 Btype
: constant Entity_Id
:= Base_Type
(T
);
5402 Component
: Entity_Id
;
5404 Candidate
: Entity_Id
:= Empty
;
5407 if Check
and then Btype
= Ancestor
then
5408 Error_Msg_N
("circular type definition", Type_Id
);
5412 if Is_Private_Type
(Btype
)
5413 and then not Is_Generic_Type
(Btype
)
5415 if Present
(Full_View
(Btype
))
5416 and then Is_Record_Type
(Full_View
(Btype
))
5417 and then not Is_Frozen
(Btype
)
5419 -- To indicate that the ancestor depends on a private type,
5420 -- the current Btype is sufficient. However, to check for
5421 -- circular definition we must recurse on the full view.
5423 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
5425 if Candidate
= Any_Type
then
5435 elsif Is_Array_Type
(Btype
) then
5436 return Trace_Components
(Component_Type
(Btype
), True);
5438 elsif Is_Record_Type
(Btype
) then
5439 Component
:= First_Entity
(Btype
);
5440 while Present
(Component
) loop
5442 -- skip anonymous types generated by constrained components.
5444 if not Is_Type
(Component
) then
5445 P
:= Trace_Components
(Etype
(Component
), True);
5448 if P
= Any_Type
then
5456 Next_Entity
(Component
);
5464 end Trace_Components
;
5466 -- Start of processing for Private_Component
5469 return Trace_Components
(Type_Id
, False);
5470 end Private_Component
;
5472 -----------------------
5473 -- Process_End_Label --
5474 -----------------------
5476 procedure Process_End_Label
5484 Label_Ref
: Boolean;
5485 -- Set True if reference to end label itself is required
5488 -- Gets set to the operator symbol or identifier that references
5489 -- the entity Ent. For the child unit case, this is the identifier
5490 -- from the designator. For other cases, this is simply Endl.
5492 procedure Generate_Parent_Ref
(N
: Node_Id
);
5493 -- N is an identifier node that appears as a parent unit reference
5494 -- in the case where Ent is a child unit. This procedure generates
5495 -- an appropriate cross-reference entry.
5497 -------------------------
5498 -- Generate_Parent_Ref --
5499 -------------------------
5501 procedure Generate_Parent_Ref
(N
: Node_Id
) is
5502 Parent_Ent
: Entity_Id
;
5505 -- Search up scope stack. The reason we do this is that normal
5506 -- visibility analysis would not work for two reasons. First in
5507 -- some subunit cases, the entry for the parent unit may not be
5508 -- visible, and in any case there can be a local entity that
5509 -- hides the scope entity.
5511 Parent_Ent
:= Current_Scope
;
5512 while Present
(Parent_Ent
) loop
5513 if Chars
(Parent_Ent
) = Chars
(N
) then
5515 -- Generate the reference. We do NOT consider this as a
5516 -- reference for unreferenced symbol purposes, but we do
5517 -- force a cross-reference even if the end line does not
5518 -- come from source (the caller already generated the
5519 -- appropriate Typ for this situation).
5522 (Parent_Ent
, N
, 'r', Set_Ref
=> False, Force
=> True);
5523 Style
.Check_Identifier
(N
, Parent_Ent
);
5527 Parent_Ent
:= Scope
(Parent_Ent
);
5530 -- Fall through means entity was not found -- that's odd, but
5531 -- the appropriate thing is simply to ignore and not generate
5532 -- any cross-reference for this entry.
5535 end Generate_Parent_Ref
;
5537 -- Start of processing for Process_End_Label
5540 -- If no node, ignore. This happens in some error situations,
5541 -- and also for some internally generated structures where no
5542 -- end label references are required in any case.
5548 -- Nothing to do if no End_Label, happens for internally generated
5549 -- constructs where we don't want an end label reference anyway.
5550 -- Also nothing to do if Endl is a string literal, which means
5551 -- there was some prior error (bad operator symbol)
5553 Endl
:= End_Label
(N
);
5555 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
5559 -- Reference node is not in extended main source unit
5561 if not In_Extended_Main_Source_Unit
(N
) then
5563 -- Generally we do not collect references except for the
5564 -- extended main source unit. The one exception is the 'e'
5565 -- entry for a package spec, where it is useful for a client
5566 -- to have the ending information to define scopes.
5574 -- For this case, we can ignore any parent references,
5575 -- but we need the package name itself for the 'e' entry.
5577 if Nkind
(Endl
) = N_Designator
then
5578 Endl
:= Identifier
(Endl
);
5582 -- Reference is in extended main source unit
5587 -- For designator, generate references for the parent entries
5589 if Nkind
(Endl
) = N_Designator
then
5591 -- Generate references for the prefix if the END line comes
5592 -- from source (otherwise we do not need these references)
5594 if Comes_From_Source
(Endl
) then
5596 while Nkind
(Nam
) = N_Selected_Component
loop
5597 Generate_Parent_Ref
(Selector_Name
(Nam
));
5598 Nam
:= Prefix
(Nam
);
5601 Generate_Parent_Ref
(Nam
);
5604 Endl
:= Identifier
(Endl
);
5608 -- If the end label is not for the given entity, then either we have
5609 -- some previous error, or this is a generic instantiation for which
5610 -- we do not need to make a cross-reference in this case anyway. In
5611 -- either case we simply ignore the call.
5613 if Chars
(Ent
) /= Chars
(Endl
) then
5617 -- If label was really there, then generate a normal reference
5618 -- and then adjust the location in the end label to point past
5619 -- the name (which should almost always be the semicolon).
5623 if Comes_From_Source
(Endl
) then
5625 -- If a label reference is required, then do the style check
5626 -- and generate an l-type cross-reference entry for the label
5630 Style
.Check_Identifier
(Endl
, Ent
);
5632 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
5635 -- Set the location to point past the label (normally this will
5636 -- mean the semicolon immediately following the label). This is
5637 -- done for the sake of the 'e' or 't' entry generated below.
5639 Get_Decoded_Name_String
(Chars
(Endl
));
5640 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
5643 -- Now generate the e/t reference
5645 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
5647 -- Restore Sloc, in case modified above, since we have an identifier
5648 -- and the normal Sloc should be left set in the tree.
5650 Set_Sloc
(Endl
, Loc
);
5651 end Process_End_Label
;
5657 -- We do the conversion to get the value of the real string by using
5658 -- the scanner, see Sinput for details on use of the internal source
5659 -- buffer for scanning internal strings.
5661 function Real_Convert
(S
: String) return Node_Id
is
5662 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
5666 Source
:= Internal_Source_Ptr
;
5669 for J
in S
'Range loop
5670 Source
(Source_Ptr
(J
)) := S
(J
);
5673 Source
(S
'Length + 1) := EOF
;
5675 if Source
(Scan_Ptr
) = '-' then
5677 Scan_Ptr
:= Scan_Ptr
+ 1;
5685 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
5692 ---------------------
5693 -- Rep_To_Pos_Flag --
5694 ---------------------
5696 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
5698 return New_Occurrence_Of
5699 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
5700 end Rep_To_Pos_Flag
;
5702 --------------------
5703 -- Require_Entity --
5704 --------------------
5706 procedure Require_Entity
(N
: Node_Id
) is
5708 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
5709 if Total_Errors_Detected
/= 0 then
5710 Set_Entity
(N
, Any_Id
);
5712 raise Program_Error
;
5717 ------------------------------
5718 -- Requires_Transient_Scope --
5719 ------------------------------
5721 -- A transient scope is required when variable-sized temporaries are
5722 -- allocated in the primary or secondary stack, or when finalization
5723 -- actions must be generated before the next instruction.
5725 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
5726 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
5728 -- Start of processing for Requires_Transient_Scope
5731 -- This is a private type which is not completed yet. This can only
5732 -- happen in a default expression (of a formal parameter or of a
5733 -- record component). Do not expand transient scope in this case
5738 -- Do not expand transient scope for non-existent procedure return
5740 elsif Typ
= Standard_Void_Type
then
5743 -- Elementary types do not require a transient scope
5745 elsif Is_Elementary_Type
(Typ
) then
5748 -- Generally, indefinite subtypes require a transient scope, since the
5749 -- back end cannot generate temporaries, since this is not a valid type
5750 -- for declaring an object. It might be possible to relax this in the
5751 -- future, e.g. by declaring the maximum possible space for the type.
5753 elsif Is_Indefinite_Subtype
(Typ
) then
5756 -- Functions returning tagged types may dispatch on result so their
5757 -- returned value is allocated on the secondary stack. Controlled
5758 -- type temporaries need finalization.
5760 elsif Is_Tagged_Type
(Typ
)
5761 or else Has_Controlled_Component
(Typ
)
5767 elsif Is_Record_Type
(Typ
) then
5769 -- In GCC 2, discriminated records always require a transient
5770 -- scope because the back end otherwise tries to allocate a
5771 -- variable length temporary for the particular variant.
5773 if Opt
.GCC_Version
= 2
5774 and then Has_Discriminants
(Typ
)
5778 -- For GCC 3, or for a non-discriminated record in GCC 2, we are
5779 -- OK if none of the component types requires a transient scope.
5780 -- Note that we already know that this is a definite type (i.e.
5781 -- has discriminant defaults if it is a discriminated record).
5787 Comp
:= First_Entity
(Typ
);
5788 while Present
(Comp
) loop
5789 if Requires_Transient_Scope
(Etype
(Comp
)) then
5800 -- String literal types never require transient scope
5802 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
5805 -- Array type. Note that we already know that this is a constrained
5806 -- array, since unconstrained arrays will fail the indefinite test.
5808 elsif Is_Array_Type
(Typ
) then
5810 -- If component type requires a transient scope, the array does too
5812 if Requires_Transient_Scope
(Component_Type
(Typ
)) then
5815 -- Otherwise, we only need a transient scope if the size is not
5816 -- known at compile time.
5819 return not Size_Known_At_Compile_Time
(Typ
);
5822 -- All other cases do not require a transient scope
5827 end Requires_Transient_Scope
;
5829 --------------------------
5830 -- Reset_Analyzed_Flags --
5831 --------------------------
5833 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
5835 function Clear_Analyzed
5836 (N
: Node_Id
) return Traverse_Result
;
5837 -- Function used to reset Analyzed flags in tree. Note that we do
5838 -- not reset Analyzed flags in entities, since there is no need to
5839 -- renalalyze entities, and indeed, it is wrong to do so, since it
5840 -- can result in generating auxiliary stuff more than once.
5842 --------------------
5843 -- Clear_Analyzed --
5844 --------------------
5846 function Clear_Analyzed
5847 (N
: Node_Id
) return Traverse_Result
5850 if not Has_Extension
(N
) then
5851 Set_Analyzed
(N
, False);
5857 function Reset_Analyzed
is
5858 new Traverse_Func
(Clear_Analyzed
);
5860 Discard
: Traverse_Result
;
5861 pragma Warnings
(Off
, Discard
);
5863 -- Start of processing for Reset_Analyzed_Flags
5866 Discard
:= Reset_Analyzed
(N
);
5867 end Reset_Analyzed_Flags
;
5869 ---------------------------
5870 -- Safe_To_Capture_Value --
5871 ---------------------------
5873 function Safe_To_Capture_Value
5875 Ent
: Entity_Id
) return Boolean
5878 -- The only entities for which we track constant values are variables,
5879 -- out parameters and in out parameters, so check if we have this case.
5881 if Ekind
(Ent
) /= E_Variable
5883 Ekind
(Ent
) /= E_Out_Parameter
5885 Ekind
(Ent
) /= E_In_Out_Parameter
5890 -- Skip volatile and aliased variables, since funny things might
5891 -- be going on in these cases which we cannot necessarily track.
5893 if Treat_As_Volatile
(Ent
) or else Is_Aliased
(Ent
) then
5897 -- OK, all above conditions are met. We also require that the scope
5898 -- of the reference be the same as the scope of the entity, not
5899 -- counting packages and blocks.
5902 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
5903 R_Scope
: Entity_Id
;
5906 R_Scope
:= Current_Scope
;
5907 while R_Scope
/= Standard_Standard
loop
5908 exit when R_Scope
= E_Scope
;
5910 if Ekind
(R_Scope
) /= E_Package
5912 Ekind
(R_Scope
) /= E_Block
5916 R_Scope
:= Scope
(R_Scope
);
5921 -- We also require that the reference does not appear in a context
5922 -- where it is not sure to be executed (i.e. a conditional context
5923 -- or an exception handler).
5930 while Present
(P
) loop
5931 if Nkind
(P
) = N_If_Statement
5933 Nkind
(P
) = N_Case_Statement
5935 Nkind
(P
) = N_Exception_Handler
5937 Nkind
(P
) = N_Selective_Accept
5939 Nkind
(P
) = N_Conditional_Entry_Call
5941 Nkind
(P
) = N_Timed_Entry_Call
5943 Nkind
(P
) = N_Asynchronous_Select
5952 -- OK, looks safe to set value
5955 end Safe_To_Capture_Value
;
5961 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
5962 K1
: constant Node_Kind
:= Nkind
(N1
);
5963 K2
: constant Node_Kind
:= Nkind
(N2
);
5966 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
5967 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
5969 return Chars
(N1
) = Chars
(N2
);
5971 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
5972 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
5974 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
5975 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
5986 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
5991 elsif not Is_Constrained
(T1
)
5992 and then not Is_Constrained
(T2
)
5993 and then Base_Type
(T1
) = Base_Type
(T2
)
5997 -- For now don't bother with case of identical constraints, to be
5998 -- fiddled with later on perhaps (this is only used for optimization
5999 -- purposes, so it is not critical to do a best possible job)
6006 ------------------------
6007 -- Scope_Is_Transient --
6008 ------------------------
6010 function Scope_Is_Transient
return Boolean is
6012 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
6013 end Scope_Is_Transient
;
6019 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6024 while Scop
/= Standard_Standard
loop
6025 Scop
:= Scope
(Scop
);
6027 if Scop
= Scope2
then
6035 --------------------------
6036 -- Scope_Within_Or_Same --
6037 --------------------------
6039 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6044 while Scop
/= Standard_Standard
loop
6045 if Scop
= Scope2
then
6048 Scop
:= Scope
(Scop
);
6053 end Scope_Within_Or_Same
;
6055 ------------------------
6056 -- Set_Current_Entity --
6057 ------------------------
6059 -- The given entity is to be set as the currently visible definition
6060 -- of its associated name (i.e. the Node_Id associated with its name).
6061 -- All we have to do is to get the name from the identifier, and
6062 -- then set the associated Node_Id to point to the given entity.
6064 procedure Set_Current_Entity
(E
: Entity_Id
) is
6066 Set_Name_Entity_Id
(Chars
(E
), E
);
6067 end Set_Current_Entity
;
6069 ---------------------------------
6070 -- Set_Entity_With_Style_Check --
6071 ---------------------------------
6073 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
6074 Val_Actual
: Entity_Id
;
6078 Set_Entity
(N
, Val
);
6081 and then not Suppress_Style_Checks
(Val
)
6082 and then not In_Instance
6084 if Nkind
(N
) = N_Identifier
then
6087 elsif Nkind
(N
) = N_Expanded_Name
then
6088 Nod
:= Selector_Name
(N
);
6096 -- A special situation arises for derived operations, where we want
6097 -- to do the check against the parent (since the Sloc of the derived
6098 -- operation points to the derived type declaration itself).
6100 while not Comes_From_Source
(Val_Actual
)
6101 and then Nkind
(Val_Actual
) in N_Entity
6102 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
6103 or else Is_Subprogram
(Val_Actual
)
6104 or else Is_Generic_Subprogram
(Val_Actual
))
6105 and then Present
(Alias
(Val_Actual
))
6107 Val_Actual
:= Alias
(Val_Actual
);
6110 -- Renaming declarations for generic actuals do not come from source,
6111 -- and have a different name from that of the entity they rename, so
6112 -- there is no style check to perform here.
6114 if Chars
(Nod
) = Chars
(Val_Actual
) then
6115 Style
.Check_Identifier
(Nod
, Val_Actual
);
6119 Set_Entity
(N
, Val
);
6120 end Set_Entity_With_Style_Check
;
6122 ------------------------
6123 -- Set_Name_Entity_Id --
6124 ------------------------
6126 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
6128 Set_Name_Table_Info
(Id
, Int
(Val
));
6129 end Set_Name_Entity_Id
;
6131 ---------------------
6132 -- Set_Next_Actual --
6133 ---------------------
6135 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
6137 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
6138 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
6140 end Set_Next_Actual
;
6142 -----------------------
6143 -- Set_Public_Status --
6144 -----------------------
6146 procedure Set_Public_Status
(Id
: Entity_Id
) is
6147 S
: constant Entity_Id
:= Current_Scope
;
6150 if S
= Standard_Standard
6151 or else (Is_Public
(S
)
6152 and then (Ekind
(S
) = E_Package
6153 or else Is_Record_Type
(S
)
6154 or else Ekind
(S
) = E_Void
))
6158 -- The bounds of an entry family declaration can generate object
6159 -- declarations that are visible to the back-end, e.g. in the
6160 -- the declaration of a composite type that contains tasks.
6163 and then Is_Concurrent_Type
(S
)
6164 and then not Has_Completion
(S
)
6165 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
6169 end Set_Public_Status
;
6171 ----------------------------
6172 -- Set_Scope_Is_Transient --
6173 ----------------------------
6175 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
6177 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
6178 end Set_Scope_Is_Transient
;
6184 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
6186 -- We copy Esize, but not RM_Size, since in general RM_Size is
6187 -- subtype specific and does not get inherited by all subtypes.
6189 Set_Esize
(T1
, Esize
(T2
));
6190 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
6192 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
6194 Is_Discrete_Or_Fixed_Point_Type
(T2
)
6196 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
6198 Set_Alignment
(T1
, Alignment
(T2
));
6201 --------------------
6202 -- Static_Integer --
6203 --------------------
6205 function Static_Integer
(N
: Node_Id
) return Uint
is
6207 Analyze_And_Resolve
(N
, Any_Integer
);
6210 or else Error_Posted
(N
)
6211 or else Etype
(N
) = Any_Type
6216 if Is_Static_Expression
(N
) then
6217 if not Raises_Constraint_Error
(N
) then
6218 return Expr_Value
(N
);
6223 elsif Etype
(N
) = Any_Type
then
6227 Flag_Non_Static_Expr
6228 ("static integer expression required here", N
);
6233 --------------------------
6234 -- Statically_Different --
6235 --------------------------
6237 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
6238 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
6239 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
6242 return Is_Entity_Name
(R1
)
6243 and then Is_Entity_Name
(R2
)
6244 and then Entity
(R1
) /= Entity
(R2
)
6245 and then not Is_Formal
(Entity
(R1
))
6246 and then not Is_Formal
(Entity
(R2
));
6247 end Statically_Different
;
6249 -----------------------------
6250 -- Subprogram_Access_Level --
6251 -----------------------------
6253 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
6255 if Present
(Alias
(Subp
)) then
6256 return Subprogram_Access_Level
(Alias
(Subp
));
6258 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
6260 end Subprogram_Access_Level
;
6266 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
6268 if Debug_Flag_W
then
6269 for J
in 0 .. Scope_Stack
.Last
loop
6274 Write_Name
(Chars
(E
));
6275 Write_Str
(" line ");
6276 Write_Int
(Int
(Get_Logical_Line_Number
(Sloc
(N
))));
6281 -----------------------
6282 -- Transfer_Entities --
6283 -----------------------
6285 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
6286 Ent
: Entity_Id
:= First_Entity
(From
);
6293 if (Last_Entity
(To
)) = Empty
then
6294 Set_First_Entity
(To
, Ent
);
6296 Set_Next_Entity
(Last_Entity
(To
), Ent
);
6299 Set_Last_Entity
(To
, Last_Entity
(From
));
6301 while Present
(Ent
) loop
6302 Set_Scope
(Ent
, To
);
6304 if not Is_Public
(Ent
) then
6305 Set_Public_Status
(Ent
);
6308 and then Ekind
(Ent
) = E_Record_Subtype
6311 -- The components of the propagated Itype must be public
6318 Comp
:= First_Entity
(Ent
);
6320 while Present
(Comp
) loop
6321 Set_Is_Public
(Comp
);
6331 Set_First_Entity
(From
, Empty
);
6332 Set_Last_Entity
(From
, Empty
);
6333 end Transfer_Entities
;
6335 -----------------------
6336 -- Type_Access_Level --
6337 -----------------------
6339 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
6343 -- If the type is an anonymous access type we treat it as being
6344 -- declared at the library level to ensure that names such as
6345 -- X.all'access don't fail static accessibility checks.
6347 -- Ada 2005 (AI-230): In case of anonymous access types that are
6348 -- component_definition or discriminants of a nonlimited type,
6349 -- the level is the same as that of the enclosing component type.
6351 Btyp
:= Base_Type
(Typ
);
6352 if Ekind
(Btyp
) in Access_Kind
then
6353 if Ekind
(Btyp
) = E_Anonymous_Access_Type
6354 and then not Is_Array_Type
(Scope
(Btyp
)) -- Ada 2005 (AI-230)
6355 and then Ekind
(Scope
(Btyp
)) /= E_Record_Type
-- Ada 2005 (AI-230)
6357 return Scope_Depth
(Standard_Standard
);
6360 Btyp
:= Root_Type
(Btyp
);
6363 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
6364 end Type_Access_Level
;
6366 --------------------------
6367 -- Unit_Declaration_Node --
6368 --------------------------
6370 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
6371 N
: Node_Id
:= Parent
(Unit_Id
);
6374 -- Predefined operators do not have a full function declaration.
6376 if Ekind
(Unit_Id
) = E_Operator
then
6380 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
6381 and then Nkind
(N
) /= N_Formal_Package_Declaration
6382 and then Nkind
(N
) /= N_Formal_Subprogram_Declaration
6383 and then Nkind
(N
) /= N_Function_Instantiation
6384 and then Nkind
(N
) /= N_Generic_Package_Declaration
6385 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
6386 and then Nkind
(N
) /= N_Package_Declaration
6387 and then Nkind
(N
) /= N_Package_Body
6388 and then Nkind
(N
) /= N_Package_Instantiation
6389 and then Nkind
(N
) /= N_Package_Renaming_Declaration
6390 and then Nkind
(N
) /= N_Procedure_Instantiation
6391 and then Nkind
(N
) /= N_Protected_Body
6392 and then Nkind
(N
) /= N_Subprogram_Declaration
6393 and then Nkind
(N
) /= N_Subprogram_Body
6394 and then Nkind
(N
) /= N_Subprogram_Body_Stub
6395 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
6396 and then Nkind
(N
) /= N_Task_Body
6397 and then Nkind
(N
) /= N_Task_Type_Declaration
6398 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
6401 pragma Assert
(Present
(N
));
6405 end Unit_Declaration_Node
;
6407 ------------------------------
6408 -- Universal_Interpretation --
6409 ------------------------------
6411 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
6412 Index
: Interp_Index
;
6416 -- The argument may be a formal parameter of an operator or subprogram
6417 -- with multiple interpretations, or else an expression for an actual.
6419 if Nkind
(Opnd
) = N_Defining_Identifier
6420 or else not Is_Overloaded
(Opnd
)
6422 if Etype
(Opnd
) = Universal_Integer
6423 or else Etype
(Opnd
) = Universal_Real
6425 return Etype
(Opnd
);
6431 Get_First_Interp
(Opnd
, Index
, It
);
6433 while Present
(It
.Typ
) loop
6435 if It
.Typ
= Universal_Integer
6436 or else It
.Typ
= Universal_Real
6441 Get_Next_Interp
(Index
, It
);
6446 end Universal_Interpretation
;
6448 ----------------------
6449 -- Within_Init_Proc --
6450 ----------------------
6452 function Within_Init_Proc
return Boolean is
6457 while not Is_Overloadable
(S
) loop
6458 if S
= Standard_Standard
then
6465 return Is_Init_Proc
(S
);
6466 end Within_Init_Proc
;
6472 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
6473 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
6474 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
6476 function Has_One_Matching_Field
return Boolean;
6477 -- Determines whether Expec_Type is a record type with a single
6478 -- component or discriminant whose type matches the found type or
6479 -- is a one dimensional array whose component type matches the
6482 function Has_One_Matching_Field
return Boolean is
6486 if Is_Array_Type
(Expec_Type
)
6487 and then Number_Dimensions
(Expec_Type
) = 1
6489 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
6493 elsif not Is_Record_Type
(Expec_Type
) then
6497 E
:= First_Entity
(Expec_Type
);
6503 elsif (Ekind
(E
) /= E_Discriminant
6504 and then Ekind
(E
) /= E_Component
)
6505 or else (Chars
(E
) = Name_uTag
6506 or else Chars
(E
) = Name_uParent
)
6515 if not Covers
(Etype
(E
), Found_Type
) then
6518 elsif Present
(Next_Entity
(E
)) then
6525 end Has_One_Matching_Field
;
6527 -- Start of processing for Wrong_Type
6530 -- Don't output message if either type is Any_Type, or if a message
6531 -- has already been posted for this node. We need to do the latter
6532 -- check explicitly (it is ordinarily done in Errout), because we
6533 -- are using ! to force the output of the error messages.
6535 if Expec_Type
= Any_Type
6536 or else Found_Type
= Any_Type
6537 or else Error_Posted
(Expr
)
6541 -- In an instance, there is an ongoing problem with completion of
6542 -- type derived from private types. Their structure is what Gigi
6543 -- expects, but the Etype is the parent type rather than the
6544 -- derived private type itself. Do not flag error in this case. The
6545 -- private completion is an entity without a parent, like an Itype.
6546 -- Similarly, full and partial views may be incorrect in the instance.
6547 -- There is no simple way to insure that it is consistent ???
6549 elsif In_Instance
then
6551 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
6553 (Has_Private_Declaration
(Expected_Type
)
6554 or else Has_Private_Declaration
(Etype
(Expr
)))
6555 and then No
(Parent
(Expected_Type
))
6561 -- An interesting special check. If the expression is parenthesized
6562 -- and its type corresponds to the type of the sole component of the
6563 -- expected record type, or to the component type of the expected one
6564 -- dimensional array type, then assume we have a bad aggregate attempt.
6566 if Nkind
(Expr
) in N_Subexpr
6567 and then Paren_Count
(Expr
) /= 0
6568 and then Has_One_Matching_Field
6570 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
6572 -- Another special check, if we are looking for a pool-specific access
6573 -- type and we found an E_Access_Attribute_Type, then we have the case
6574 -- of an Access attribute being used in a context which needs a pool-
6575 -- specific type, which is never allowed. The one extra check we make
6576 -- is that the expected designated type covers the Found_Type.
6578 elsif Is_Access_Type
(Expec_Type
)
6579 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
6580 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
6581 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
6583 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
6585 Error_Msg_N
("result must be general access type!", Expr
);
6586 Error_Msg_NE
("add ALL to }!", Expr
, Expec_Type
);
6588 -- If the expected type is an anonymous access type, as for access
6589 -- parameters and discriminants, the error is on the designated types.
6591 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
6592 if Comes_From_Source
(Expec_Type
) then
6593 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
6596 ("expected an access type with designated}",
6597 Expr
, Designated_Type
(Expec_Type
));
6600 if Is_Access_Type
(Found_Type
)
6601 and then not Comes_From_Source
(Found_Type
)
6604 ("found an access type with designated}!",
6605 Expr
, Designated_Type
(Found_Type
));
6607 if From_With_Type
(Found_Type
) then
6608 Error_Msg_NE
("found incomplete}!", Expr
, Found_Type
);
6610 ("\possibly missing with_clause on&", Expr
,
6611 Scope
(Found_Type
));
6613 Error_Msg_NE
("found}!", Expr
, Found_Type
);
6617 -- Normal case of one type found, some other type expected
6620 -- If the names of the two types are the same, see if some
6621 -- number of levels of qualification will help. Don't try
6622 -- more than three levels, and if we get to standard, it's
6623 -- no use (and probably represents an error in the compiler)
6624 -- Also do not bother with internal scope names.
6627 Expec_Scope
: Entity_Id
;
6628 Found_Scope
: Entity_Id
;
6631 Expec_Scope
:= Expec_Type
;
6632 Found_Scope
:= Found_Type
;
6634 for Levels
in Int
range 0 .. 3 loop
6635 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
6636 Error_Msg_Qual_Level
:= Levels
;
6640 Expec_Scope
:= Scope
(Expec_Scope
);
6641 Found_Scope
:= Scope
(Found_Scope
);
6643 exit when Expec_Scope
= Standard_Standard
6645 Found_Scope
= Standard_Standard
6647 not Comes_From_Source
(Expec_Scope
)
6649 not Comes_From_Source
(Found_Scope
);
6653 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
6655 if Is_Entity_Name
(Expr
)
6656 and then Is_Package
(Entity
(Expr
))
6658 Error_Msg_N
("found package name!", Expr
);
6660 elsif Is_Entity_Name
(Expr
)
6662 (Ekind
(Entity
(Expr
)) = E_Procedure
6664 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
6666 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
6668 ("found procedure name, possibly missing Access attribute!",
6671 Error_Msg_N
("found procedure name instead of function!", Expr
);
6674 elsif Nkind
(Expr
) = N_Function_Call
6675 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
6676 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
6677 and then No
(Parameter_Associations
(Expr
))
6680 ("found function name, possibly missing Access attribute!",
6683 -- Catch common error: a prefix or infix operator which is not
6684 -- directly visible because the type isn't.
6686 elsif Nkind
(Expr
) in N_Op
6687 and then Is_Overloaded
(Expr
)
6688 and then not Is_Immediately_Visible
(Expec_Type
)
6689 and then not Is_Potentially_Use_Visible
(Expec_Type
)
6690 and then not In_Use
(Expec_Type
)
6691 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
6694 "operator of the type is not directly visible!", Expr
);
6696 elsif Ekind
(Found_Type
) = E_Void
6697 and then Present
(Parent
(Found_Type
))
6698 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
6700 Error_Msg_NE
("found premature usage of}!", Expr
, Found_Type
);
6703 Error_Msg_NE
("found}!", Expr
, Found_Type
);
6706 Error_Msg_Qual_Level
:= 0;