1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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
;
61 with Uname
; use Uname
;
63 package body Sem_Util
is
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 function Build_Component_Subtype
72 T
: Entity_Id
) return Node_Id
;
73 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
74 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
75 -- Loc is the source location, T is the original subtype.
77 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
78 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
79 -- with discriminants whose default values are static, examine only the
80 -- components in the selected variant to determine whether all of them
83 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
84 -- T is a derived tagged type. Check whether the type extension is null.
85 -- If the parent type is fully initialized, T can be treated as such.
87 --------------------------------
88 -- Add_Access_Type_To_Process --
89 --------------------------------
91 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
95 Ensure_Freeze_Node
(E
);
96 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
100 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
104 end Add_Access_Type_To_Process
;
106 -----------------------
107 -- Alignment_In_Bits --
108 -----------------------
110 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
112 return Alignment
(E
) * System_Storage_Unit
;
113 end Alignment_In_Bits
;
115 -----------------------------------------
116 -- Apply_Compile_Time_Constraint_Error --
117 -----------------------------------------
119 procedure Apply_Compile_Time_Constraint_Error
122 Reason
: RT_Exception_Code
;
123 Ent
: Entity_Id
:= Empty
;
124 Typ
: Entity_Id
:= Empty
;
125 Loc
: Source_Ptr
:= No_Location
;
126 Rep
: Boolean := True;
127 Warn
: Boolean := False)
129 Stat
: constant Boolean := Is_Static_Expression
(N
);
140 Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
146 -- Now we replace the node by an N_Raise_Constraint_Error node
147 -- This does not need reanalyzing, so set it as analyzed now.
150 Make_Raise_Constraint_Error
(Sloc
(N
),
152 Set_Analyzed
(N
, True);
154 Set_Raises_Constraint_Error
(N
);
156 -- If the original expression was marked as static, the result is
157 -- still marked as static, but the Raises_Constraint_Error flag is
158 -- always set so that further static evaluation is not attempted.
161 Set_Is_Static_Expression
(N
);
163 end Apply_Compile_Time_Constraint_Error
;
165 --------------------------
166 -- Build_Actual_Subtype --
167 --------------------------
169 function Build_Actual_Subtype
171 N
: Node_Or_Entity_Id
) return Node_Id
175 Loc
: constant Source_Ptr
:= Sloc
(N
);
176 Constraints
: List_Id
;
182 Disc_Type
: Entity_Id
;
185 if Nkind
(N
) = N_Defining_Identifier
then
186 Obj
:= New_Reference_To
(N
, Loc
);
191 if Is_Array_Type
(T
) then
192 Constraints
:= New_List
;
194 for J
in 1 .. Number_Dimensions
(T
) loop
196 -- Build an array subtype declaration with the nominal
197 -- subtype and the bounds of the actual. Add the declaration
198 -- in front of the local declarations for the subprogram, for
199 -- analysis before any reference to the formal in the body.
202 Make_Attribute_Reference
(Loc
,
204 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
205 Attribute_Name
=> Name_First
,
206 Expressions
=> New_List
(
207 Make_Integer_Literal
(Loc
, J
)));
210 Make_Attribute_Reference
(Loc
,
212 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
213 Attribute_Name
=> Name_Last
,
214 Expressions
=> New_List
(
215 Make_Integer_Literal
(Loc
, J
)));
217 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
220 -- If the type has unknown discriminants there is no constrained
221 -- subtype to build. This is never called for a formal or for a
222 -- lhs, so returning the type is ok ???
224 elsif Has_Unknown_Discriminants
(T
) then
228 Constraints
:= New_List
;
230 if Is_Private_Type
(T
) and then No
(Full_View
(T
)) then
232 -- Type is a generic derived type. Inherit discriminants from
235 Disc_Type
:= Etype
(Base_Type
(T
));
240 Discr
:= First_Discriminant
(Disc_Type
);
242 while Present
(Discr
) loop
243 Append_To
(Constraints
,
244 Make_Selected_Component
(Loc
,
246 Duplicate_Subexpr_No_Checks
(Obj
),
247 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
248 Next_Discriminant
(Discr
);
253 Make_Defining_Identifier
(Loc
,
254 Chars
=> New_Internal_Name
('S'));
255 Set_Is_Internal
(Subt
);
258 Make_Subtype_Declaration
(Loc
,
259 Defining_Identifier
=> Subt
,
260 Subtype_Indication
=>
261 Make_Subtype_Indication
(Loc
,
262 Subtype_Mark
=> New_Reference_To
(T
, Loc
),
264 Make_Index_Or_Discriminant_Constraint
(Loc
,
265 Constraints
=> Constraints
)));
267 Mark_Rewrite_Insertion
(Decl
);
269 end Build_Actual_Subtype
;
271 ---------------------------------------
272 -- Build_Actual_Subtype_Of_Component --
273 ---------------------------------------
275 function Build_Actual_Subtype_Of_Component
277 N
: Node_Id
) return Node_Id
279 Loc
: constant Source_Ptr
:= Sloc
(N
);
280 P
: constant Node_Id
:= Prefix
(N
);
283 Indx_Type
: Entity_Id
;
285 Deaccessed_T
: Entity_Id
;
286 -- This is either a copy of T, or if T is an access type, then it is
287 -- the directly designated type of this access type.
289 function Build_Actual_Array_Constraint
return List_Id
;
290 -- If one or more of the bounds of the component depends on
291 -- discriminants, build actual constraint using the discriminants
294 function Build_Actual_Record_Constraint
return List_Id
;
295 -- Similar to previous one, for discriminated components constrained
296 -- by the discriminant of the enclosing object.
298 -----------------------------------
299 -- Build_Actual_Array_Constraint --
300 -----------------------------------
302 function Build_Actual_Array_Constraint
return List_Id
is
303 Constraints
: constant List_Id
:= New_List
;
311 Indx
:= First_Index
(Deaccessed_T
);
312 while Present
(Indx
) loop
313 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
314 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
316 if Denotes_Discriminant
(Old_Lo
) then
318 Make_Selected_Component
(Loc
,
319 Prefix
=> New_Copy_Tree
(P
),
320 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
323 Lo
:= New_Copy_Tree
(Old_Lo
);
325 -- The new bound will be reanalyzed in the enclosing
326 -- declaration. For literal bounds that come from a type
327 -- declaration, the type of the context must be imposed, so
328 -- insure that analysis will take place. For non-universal
329 -- types this is not strictly necessary.
331 Set_Analyzed
(Lo
, False);
334 if Denotes_Discriminant
(Old_Hi
) then
336 Make_Selected_Component
(Loc
,
337 Prefix
=> New_Copy_Tree
(P
),
338 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
341 Hi
:= New_Copy_Tree
(Old_Hi
);
342 Set_Analyzed
(Hi
, False);
345 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
350 end Build_Actual_Array_Constraint
;
352 ------------------------------------
353 -- Build_Actual_Record_Constraint --
354 ------------------------------------
356 function Build_Actual_Record_Constraint
return List_Id
is
357 Constraints
: constant List_Id
:= New_List
;
362 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
363 while Present
(D
) loop
365 if Denotes_Discriminant
(Node
(D
)) then
366 D_Val
:= Make_Selected_Component
(Loc
,
367 Prefix
=> New_Copy_Tree
(P
),
368 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
371 D_Val
:= New_Copy_Tree
(Node
(D
));
374 Append
(D_Val
, Constraints
);
379 end Build_Actual_Record_Constraint
;
381 -- Start of processing for Build_Actual_Subtype_Of_Component
384 if In_Default_Expression
then
387 elsif Nkind
(N
) = N_Explicit_Dereference
then
388 if Is_Composite_Type
(T
)
389 and then not Is_Constrained
(T
)
390 and then not (Is_Class_Wide_Type
(T
)
391 and then Is_Constrained
(Root_Type
(T
)))
392 and then not Has_Unknown_Discriminants
(T
)
394 -- If the type of the dereference is already constrained, it
395 -- is an actual subtype.
397 if Is_Array_Type
(Etype
(N
))
398 and then Is_Constrained
(Etype
(N
))
402 Remove_Side_Effects
(P
);
403 return Build_Actual_Subtype
(T
, N
);
410 if Ekind
(T
) = E_Access_Subtype
then
411 Deaccessed_T
:= Designated_Type
(T
);
416 if Ekind
(Deaccessed_T
) = E_Array_Subtype
then
417 Id
:= First_Index
(Deaccessed_T
);
418 Indx_Type
:= Underlying_Type
(Etype
(Id
));
420 while Present
(Id
) loop
422 if Denotes_Discriminant
(Type_Low_Bound
(Indx_Type
)) or else
423 Denotes_Discriminant
(Type_High_Bound
(Indx_Type
))
425 Remove_Side_Effects
(P
);
427 Build_Component_Subtype
(
428 Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
434 elsif Is_Composite_Type
(Deaccessed_T
)
435 and then Has_Discriminants
(Deaccessed_T
)
436 and then not Has_Unknown_Discriminants
(Deaccessed_T
)
438 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
439 while Present
(D
) loop
441 if Denotes_Discriminant
(Node
(D
)) then
442 Remove_Side_Effects
(P
);
444 Build_Component_Subtype
(
445 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
452 -- If none of the above, the actual and nominal subtypes are the same
455 end Build_Actual_Subtype_Of_Component
;
457 -----------------------------
458 -- Build_Component_Subtype --
459 -----------------------------
461 function Build_Component_Subtype
464 T
: Entity_Id
) return Node_Id
470 -- Unchecked_Union components do not require component subtypes
472 if Is_Unchecked_Union
(T
) then
477 Make_Defining_Identifier
(Loc
,
478 Chars
=> New_Internal_Name
('S'));
479 Set_Is_Internal
(Subt
);
482 Make_Subtype_Declaration
(Loc
,
483 Defining_Identifier
=> Subt
,
484 Subtype_Indication
=>
485 Make_Subtype_Indication
(Loc
,
486 Subtype_Mark
=> New_Reference_To
(Base_Type
(T
), Loc
),
488 Make_Index_Or_Discriminant_Constraint
(Loc
,
491 Mark_Rewrite_Insertion
(Decl
);
493 end Build_Component_Subtype
;
495 --------------------------------------------
496 -- Build_Discriminal_Subtype_Of_Component --
497 --------------------------------------------
499 function Build_Discriminal_Subtype_Of_Component
500 (T
: Entity_Id
) return Node_Id
502 Loc
: constant Source_Ptr
:= Sloc
(T
);
506 function Build_Discriminal_Array_Constraint
return List_Id
;
507 -- If one or more of the bounds of the component depends on
508 -- discriminants, build actual constraint using the discriminants
511 function Build_Discriminal_Record_Constraint
return List_Id
;
512 -- Similar to previous one, for discriminated components constrained
513 -- by the discriminant of the enclosing object.
515 ----------------------------------------
516 -- Build_Discriminal_Array_Constraint --
517 ----------------------------------------
519 function Build_Discriminal_Array_Constraint
return List_Id
is
520 Constraints
: constant List_Id
:= New_List
;
528 Indx
:= First_Index
(T
);
529 while Present
(Indx
) loop
530 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
531 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
533 if Denotes_Discriminant
(Old_Lo
) then
534 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
537 Lo
:= New_Copy_Tree
(Old_Lo
);
540 if Denotes_Discriminant
(Old_Hi
) then
541 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
544 Hi
:= New_Copy_Tree
(Old_Hi
);
547 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
552 end Build_Discriminal_Array_Constraint
;
554 -----------------------------------------
555 -- Build_Discriminal_Record_Constraint --
556 -----------------------------------------
558 function Build_Discriminal_Record_Constraint
return List_Id
is
559 Constraints
: constant List_Id
:= New_List
;
564 D
:= First_Elmt
(Discriminant_Constraint
(T
));
565 while Present
(D
) loop
566 if Denotes_Discriminant
(Node
(D
)) then
568 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
571 D_Val
:= New_Copy_Tree
(Node
(D
));
574 Append
(D_Val
, Constraints
);
579 end Build_Discriminal_Record_Constraint
;
581 -- Start of processing for Build_Discriminal_Subtype_Of_Component
584 if Ekind
(T
) = E_Array_Subtype
then
585 Id
:= First_Index
(T
);
587 while Present
(Id
) loop
588 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
))) or else
589 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
591 return Build_Component_Subtype
592 (Build_Discriminal_Array_Constraint
, Loc
, T
);
598 elsif Ekind
(T
) = E_Record_Subtype
599 and then Has_Discriminants
(T
)
600 and then not Has_Unknown_Discriminants
(T
)
602 D
:= First_Elmt
(Discriminant_Constraint
(T
));
603 while Present
(D
) loop
604 if Denotes_Discriminant
(Node
(D
)) then
605 return Build_Component_Subtype
606 (Build_Discriminal_Record_Constraint
, Loc
, T
);
613 -- If none of the above, the actual and nominal subtypes are the same
616 end Build_Discriminal_Subtype_Of_Component
;
618 ------------------------------
619 -- Build_Elaboration_Entity --
620 ------------------------------
622 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
623 Loc
: constant Source_Ptr
:= Sloc
(N
);
624 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
627 Elab_Ent
: Entity_Id
;
630 -- Ignore if already constructed
632 if Present
(Elaboration_Entity
(Spec_Id
)) then
636 -- Construct name of elaboration entity as xxx_E, where xxx
637 -- is the unit name with dots replaced by double underscore.
638 -- We have to manually construct this name, since it will
639 -- be elaborated in the outer scope, and thus will not have
640 -- the unit name automatically prepended.
642 Get_Name_String
(Unit_Name
(Unum
));
644 -- Replace the %s by _E
646 Name_Buffer
(Name_Len
- 1 .. Name_Len
) := "_E";
648 -- Replace dots by double underscore
651 while P
< Name_Len
- 2 loop
652 if Name_Buffer
(P
) = '.' then
653 Name_Buffer
(P
+ 2 .. Name_Len
+ 1) :=
654 Name_Buffer
(P
+ 1 .. Name_Len
);
655 Name_Len
:= Name_Len
+ 1;
656 Name_Buffer
(P
) := '_';
657 Name_Buffer
(P
+ 1) := '_';
664 -- Create elaboration flag
667 Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
668 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
670 if No
(Declarations
(Aux_Decls_Node
(N
))) then
671 Set_Declarations
(Aux_Decls_Node
(N
), New_List
);
675 Make_Object_Declaration
(Loc
,
676 Defining_Identifier
=> Elab_Ent
,
678 New_Occurrence_Of
(Standard_Boolean
, Loc
),
680 New_Occurrence_Of
(Standard_False
, Loc
));
682 Append_To
(Declarations
(Aux_Decls_Node
(N
)), Decl
);
685 -- Reset True_Constant indication, since we will indeed
686 -- assign a value to the variable in the binder main.
688 Set_Is_True_Constant
(Elab_Ent
, False);
689 Set_Current_Value
(Elab_Ent
, Empty
);
691 -- We do not want any further qualification of the name (if we did
692 -- not do this, we would pick up the name of the generic package
693 -- in the case of a library level generic instantiation).
695 Set_Has_Qualified_Name
(Elab_Ent
);
696 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
697 end Build_Elaboration_Entity
;
699 -----------------------------------
700 -- Cannot_Raise_Constraint_Error --
701 -----------------------------------
703 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
705 if Compile_Time_Known_Value
(Expr
) then
708 elsif Do_Range_Check
(Expr
) then
711 elsif Raises_Constraint_Error
(Expr
) then
719 when N_Expanded_Name
=>
722 when N_Selected_Component
=>
723 return not Do_Discriminant_Check
(Expr
);
725 when N_Attribute_Reference
=>
726 if Do_Overflow_Check
(Expr
) then
729 elsif No
(Expressions
(Expr
)) then
734 N
: Node_Id
:= First
(Expressions
(Expr
));
737 while Present
(N
) loop
738 if Cannot_Raise_Constraint_Error
(N
) then
749 when N_Type_Conversion
=>
750 if Do_Overflow_Check
(Expr
)
751 or else Do_Length_Check
(Expr
)
752 or else Do_Tag_Check
(Expr
)
757 Cannot_Raise_Constraint_Error
(Expression
(Expr
));
760 when N_Unchecked_Type_Conversion
=>
761 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
764 if Do_Overflow_Check
(Expr
) then
768 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
775 if Do_Division_Check
(Expr
)
776 or else Do_Overflow_Check
(Expr
)
781 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
783 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
802 N_Op_Shift_Right_Arithmetic |
806 if Do_Overflow_Check
(Expr
) then
810 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
812 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
819 end Cannot_Raise_Constraint_Error
;
821 --------------------------
822 -- Check_Fully_Declared --
823 --------------------------
825 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
827 if Ekind
(T
) = E_Incomplete_Type
then
829 -- Ada 2005 (AI-50217): If the type is available through a limited
830 -- with_clause, verify that its full view has been analyzed.
832 if From_With_Type
(T
)
833 and then Present
(Non_Limited_View
(T
))
834 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
836 -- The non-limited view is fully declared
841 ("premature usage of incomplete}", N
, First_Subtype
(T
));
844 elsif Has_Private_Component
(T
)
845 and then not Is_Generic_Type
(Root_Type
(T
))
846 and then not In_Default_Expression
849 -- Special case: if T is the anonymous type created for a single
850 -- task or protected object, use the name of the source object.
852 if Is_Concurrent_Type
(T
)
853 and then not Comes_From_Source
(T
)
854 and then Nkind
(N
) = N_Object_Declaration
856 Error_Msg_NE
("type of& has incomplete component", N
,
857 Defining_Identifier
(N
));
861 ("premature usage of incomplete}", N
, First_Subtype
(T
));
864 end Check_Fully_Declared
;
866 ------------------------------------------
867 -- Check_Potentially_Blocking_Operation --
868 ------------------------------------------
870 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
874 -- N is one of the potentially blocking operations listed in 9.5.1(8).
875 -- When pragma Detect_Blocking is active, the run time will raise
876 -- Program_Error. Here we only issue a warning, since we generally
877 -- support the use of potentially blocking operations in the absence
880 -- Indirect blocking through a subprogram call cannot be diagnosed
881 -- statically without interprocedural analysis, so we do not attempt
884 S
:= Scope
(Current_Scope
);
885 while Present
(S
) and then S
/= Standard_Standard
loop
886 if Is_Protected_Type
(S
) then
888 ("potentially blocking operation in protected operation?", N
);
895 end Check_Potentially_Blocking_Operation
;
901 procedure Check_VMS
(Construct
: Node_Id
) is
903 if not OpenVMS_On_Target
then
905 ("this construct is allowed only in Open'V'M'S", Construct
);
909 ----------------------------------
910 -- Collect_Primitive_Operations --
911 ----------------------------------
913 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
914 B_Type
: constant Entity_Id
:= Base_Type
(T
);
915 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
916 B_Scope
: Entity_Id
:= Scope
(B_Type
);
920 Formal_Derived
: Boolean := False;
924 -- For tagged types, the primitive operations are collected as they
925 -- are declared, and held in an explicit list which is simply returned.
927 if Is_Tagged_Type
(B_Type
) then
928 return Primitive_Operations
(B_Type
);
930 -- An untagged generic type that is a derived type inherits the
931 -- primitive operations of its parent type. Other formal types only
932 -- have predefined operators, which are not explicitly represented.
934 elsif Is_Generic_Type
(B_Type
) then
935 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
936 and then Nkind
(Formal_Type_Definition
(B_Decl
))
937 = N_Formal_Derived_Type_Definition
939 Formal_Derived
:= True;
941 return New_Elmt_List
;
945 Op_List
:= New_Elmt_List
;
947 if B_Scope
= Standard_Standard
then
948 if B_Type
= Standard_String
then
949 Append_Elmt
(Standard_Op_Concat
, Op_List
);
951 elsif B_Type
= Standard_Wide_String
then
952 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
958 elsif (Is_Package
(B_Scope
)
960 Parent
(Declaration_Node
(First_Subtype
(T
))))
963 or else Is_Derived_Type
(B_Type
)
965 -- The primitive operations appear after the base type, except
966 -- if the derivation happens within the private part of B_Scope
967 -- and the type is a private type, in which case both the type
968 -- and some primitive operations may appear before the base
969 -- type, and the list of candidates starts after the type.
971 if In_Open_Scopes
(B_Scope
)
972 and then Scope
(T
) = B_Scope
973 and then In_Private_Part
(B_Scope
)
975 Id
:= Next_Entity
(T
);
977 Id
:= Next_Entity
(B_Type
);
980 while Present
(Id
) loop
982 -- Note that generic formal subprograms are not
983 -- considered to be primitive operations and thus
984 -- are never inherited.
986 if Is_Overloadable
(Id
)
987 and then Nkind
(Parent
(Parent
(Id
)))
988 not in N_Formal_Subprogram_Declaration
992 if Base_Type
(Etype
(Id
)) = B_Type
then
995 Formal
:= First_Formal
(Id
);
996 while Present
(Formal
) loop
997 if Base_Type
(Etype
(Formal
)) = B_Type
then
1001 elsif Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
1003 (Designated_Type
(Etype
(Formal
))) = B_Type
1009 Next_Formal
(Formal
);
1013 -- For a formal derived type, the only primitives are the
1014 -- ones inherited from the parent type. Operations appearing
1015 -- in the package declaration are not primitive for it.
1018 and then (not Formal_Derived
1019 or else Present
(Alias
(Id
)))
1021 Append_Elmt
(Id
, Op_List
);
1027 -- For a type declared in System, some of its operations
1028 -- may appear in the target-specific extension to System.
1031 and then Chars
(B_Scope
) = Name_System
1032 and then Scope
(B_Scope
) = Standard_Standard
1033 and then Present_System_Aux
1035 B_Scope
:= System_Aux_Id
;
1036 Id
:= First_Entity
(System_Aux_Id
);
1042 end Collect_Primitive_Operations
;
1044 -----------------------------------
1045 -- Compile_Time_Constraint_Error --
1046 -----------------------------------
1048 function Compile_Time_Constraint_Error
1051 Ent
: Entity_Id
:= Empty
;
1052 Loc
: Source_Ptr
:= No_Location
;
1053 Warn
: Boolean := False) return Node_Id
1055 Msgc
: String (1 .. Msg
'Length + 2);
1063 -- A static constraint error in an instance body is not a fatal error.
1064 -- we choose to inhibit the message altogether, because there is no
1065 -- obvious node (for now) on which to post it. On the other hand the
1066 -- offending node must be replaced with a constraint_error in any case.
1068 -- No messages are generated if we already posted an error on this node
1070 if not Error_Posted
(N
) then
1071 if Loc
/= No_Location
then
1077 -- Make all such messages unconditional
1079 Msgc
(1 .. Msg
'Length) := Msg
;
1080 Msgc
(Msg
'Length + 1) := '!';
1081 Msgl
:= Msg
'Length + 1;
1083 -- Message is a warning, even in Ada 95 case
1085 if Msg
(Msg
'Length) = '?' then
1088 -- In Ada 83, all messages are warnings. In the private part and
1089 -- the body of an instance, constraint_checks are only warnings.
1090 -- We also make this a warning if the Warn parameter is set.
1093 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
1099 elsif In_Instance_Not_Visible
then
1104 -- Otherwise we have a real error message (Ada 95 static case)
1110 -- Should we generate a warning? The answer is not quite yes. The
1111 -- very annoying exception occurs in the case of a short circuit
1112 -- operator where the left operand is static and decisive. Climb
1113 -- parents to see if that is the case we have here.
1121 if (Nkind
(P
) = N_And_Then
1122 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1123 and then Is_False
(Expr_Value
(Left_Opnd
(P
))))
1124 or else (Nkind
(P
) = N_Or_Else
1125 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1126 and then Is_True
(Expr_Value
(Left_Opnd
(P
))))
1131 elsif Nkind
(P
) = N_Component_Association
1132 and then Nkind
(Parent
(P
)) = N_Aggregate
1134 null; -- Keep going.
1137 exit when Nkind
(P
) not in N_Subexpr
;
1142 if Present
(Ent
) then
1143 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
1145 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
1149 if Inside_Init_Proc
then
1151 ("\& will be raised for objects of this type!?",
1152 N
, Standard_Constraint_Error
, Eloc
);
1155 ("\& will be raised at run time!?",
1156 N
, Standard_Constraint_Error
, Eloc
);
1160 ("\static expression raises&!",
1161 N
, Standard_Constraint_Error
, Eloc
);
1167 end Compile_Time_Constraint_Error
;
1169 -----------------------
1170 -- Conditional_Delay --
1171 -----------------------
1173 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
1175 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
1176 Set_Has_Delayed_Freeze
(New_Ent
);
1178 end Conditional_Delay
;
1180 --------------------
1181 -- Current_Entity --
1182 --------------------
1184 -- The currently visible definition for a given identifier is the
1185 -- one most chained at the start of the visibility chain, i.e. the
1186 -- one that is referenced by the Node_Id value of the name of the
1187 -- given identifier.
1189 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
1191 return Get_Name_Entity_Id
(Chars
(N
));
1194 -----------------------------
1195 -- Current_Entity_In_Scope --
1196 -----------------------------
1198 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
1200 CS
: constant Entity_Id
:= Current_Scope
;
1202 Transient_Case
: constant Boolean := Scope_Is_Transient
;
1205 E
:= Get_Name_Entity_Id
(Chars
(N
));
1208 and then Scope
(E
) /= CS
1209 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
1215 end Current_Entity_In_Scope
;
1221 function Current_Scope
return Entity_Id
is
1223 if Scope_Stack
.Last
= -1 then
1224 return Standard_Standard
;
1227 C
: constant Entity_Id
:=
1228 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
1233 return Standard_Standard
;
1239 ------------------------
1240 -- Current_Subprogram --
1241 ------------------------
1243 function Current_Subprogram
return Entity_Id
is
1244 Scop
: constant Entity_Id
:= Current_Scope
;
1247 if Is_Subprogram
(Scop
) or else Is_Generic_Subprogram
(Scop
) then
1250 return Enclosing_Subprogram
(Scop
);
1252 end Current_Subprogram
;
1254 ---------------------
1255 -- Defining_Entity --
1256 ---------------------
1258 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
1259 K
: constant Node_Kind
:= Nkind
(N
);
1260 Err
: Entity_Id
:= Empty
;
1265 N_Subprogram_Declaration |
1266 N_Abstract_Subprogram_Declaration |
1268 N_Package_Declaration |
1269 N_Subprogram_Renaming_Declaration |
1270 N_Subprogram_Body_Stub |
1271 N_Generic_Subprogram_Declaration |
1272 N_Generic_Package_Declaration |
1273 N_Formal_Subprogram_Declaration
1275 return Defining_Entity
(Specification
(N
));
1278 N_Component_Declaration |
1279 N_Defining_Program_Unit_Name |
1280 N_Discriminant_Specification |
1282 N_Entry_Declaration |
1283 N_Entry_Index_Specification |
1284 N_Exception_Declaration |
1285 N_Exception_Renaming_Declaration |
1286 N_Formal_Object_Declaration |
1287 N_Formal_Package_Declaration |
1288 N_Formal_Type_Declaration |
1289 N_Full_Type_Declaration |
1290 N_Implicit_Label_Declaration |
1291 N_Incomplete_Type_Declaration |
1292 N_Loop_Parameter_Specification |
1293 N_Number_Declaration |
1294 N_Object_Declaration |
1295 N_Object_Renaming_Declaration |
1296 N_Package_Body_Stub |
1297 N_Parameter_Specification |
1298 N_Private_Extension_Declaration |
1299 N_Private_Type_Declaration |
1301 N_Protected_Body_Stub |
1302 N_Protected_Type_Declaration |
1303 N_Single_Protected_Declaration |
1304 N_Single_Task_Declaration |
1305 N_Subtype_Declaration |
1308 N_Task_Type_Declaration
1310 return Defining_Identifier
(N
);
1313 return Defining_Entity
(Proper_Body
(N
));
1316 N_Function_Instantiation |
1317 N_Function_Specification |
1318 N_Generic_Function_Renaming_Declaration |
1319 N_Generic_Package_Renaming_Declaration |
1320 N_Generic_Procedure_Renaming_Declaration |
1322 N_Package_Instantiation |
1323 N_Package_Renaming_Declaration |
1324 N_Package_Specification |
1325 N_Procedure_Instantiation |
1326 N_Procedure_Specification
1329 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
1332 if Nkind
(Nam
) in N_Entity
then
1335 -- For Error, make up a name and attach to declaration
1336 -- so we can continue semantic analysis
1338 elsif Nam
= Error
then
1340 Make_Defining_Identifier
(Sloc
(N
),
1341 Chars
=> New_Internal_Name
('T'));
1342 Set_Defining_Unit_Name
(N
, Err
);
1345 -- If not an entity, get defining identifier
1348 return Defining_Identifier
(Nam
);
1352 when N_Block_Statement
=>
1353 return Entity
(Identifier
(N
));
1356 raise Program_Error
;
1359 end Defining_Entity
;
1361 --------------------------
1362 -- Denotes_Discriminant --
1363 --------------------------
1365 function Denotes_Discriminant
1367 Check_Protected
: Boolean := False) return Boolean
1371 if not Is_Entity_Name
(N
)
1372 or else No
(Entity
(N
))
1379 -- If we are checking for a protected type, the discriminant may have
1380 -- been rewritten as the corresponding discriminal of the original type
1381 -- or of the corresponding concurrent record, depending on whether we
1382 -- are in the spec or body of the protected type.
1384 return Ekind
(E
) = E_Discriminant
1387 and then Ekind
(E
) = E_In_Parameter
1388 and then Present
(Discriminal_Link
(E
))
1390 (Is_Protected_Type
(Scope
(Discriminal_Link
(E
)))
1392 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
1394 end Denotes_Discriminant
;
1396 -----------------------------
1397 -- Depends_On_Discriminant --
1398 -----------------------------
1400 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
1405 Get_Index_Bounds
(N
, L
, H
);
1406 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
1407 end Depends_On_Discriminant
;
1409 -------------------------
1410 -- Designate_Same_Unit --
1411 -------------------------
1413 function Designate_Same_Unit
1415 Name2
: Node_Id
) return Boolean
1417 K1
: constant Node_Kind
:= Nkind
(Name1
);
1418 K2
: constant Node_Kind
:= Nkind
(Name2
);
1420 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
1421 -- Returns the parent unit name node of a defining program unit name
1422 -- or the prefix if N is a selected component or an expanded name.
1424 function Select_Node
(N
: Node_Id
) return Node_Id
;
1425 -- Returns the defining identifier node of a defining program unit
1426 -- name or the selector node if N is a selected component or an
1433 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
1435 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1447 function Select_Node
(N
: Node_Id
) return Node_Id
is
1449 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1450 return Defining_Identifier
(N
);
1453 return Selector_Name
(N
);
1457 -- Start of processing for Designate_Next_Unit
1460 if (K1
= N_Identifier
or else
1461 K1
= N_Defining_Identifier
)
1463 (K2
= N_Identifier
or else
1464 K2
= N_Defining_Identifier
)
1466 return Chars
(Name1
) = Chars
(Name2
);
1469 (K1
= N_Expanded_Name
or else
1470 K1
= N_Selected_Component
or else
1471 K1
= N_Defining_Program_Unit_Name
)
1473 (K2
= N_Expanded_Name
or else
1474 K2
= N_Selected_Component
or else
1475 K2
= N_Defining_Program_Unit_Name
)
1478 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
1480 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
1485 end Designate_Same_Unit
;
1487 ----------------------------
1488 -- Enclosing_Generic_Body --
1489 ----------------------------
1491 function Enclosing_Generic_Body
1492 (E
: Entity_Id
) return Node_Id
1501 while Present
(P
) loop
1502 if Nkind
(P
) = N_Package_Body
1503 or else Nkind
(P
) = N_Subprogram_Body
1505 Spec
:= Corresponding_Spec
(P
);
1507 if Present
(Spec
) then
1508 Decl
:= Unit_Declaration_Node
(Spec
);
1510 if Nkind
(Decl
) = N_Generic_Package_Declaration
1511 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
1522 end Enclosing_Generic_Body
;
1524 -------------------------------
1525 -- Enclosing_Lib_Unit_Entity --
1526 -------------------------------
1528 function Enclosing_Lib_Unit_Entity
return Entity_Id
is
1529 Unit_Entity
: Entity_Id
:= Current_Scope
;
1532 -- Look for enclosing library unit entity by following scope links.
1533 -- Equivalent to, but faster than indexing through the scope stack.
1535 while (Present
(Scope
(Unit_Entity
))
1536 and then Scope
(Unit_Entity
) /= Standard_Standard
)
1537 and not Is_Child_Unit
(Unit_Entity
)
1539 Unit_Entity
:= Scope
(Unit_Entity
);
1543 end Enclosing_Lib_Unit_Entity
;
1545 -----------------------------
1546 -- Enclosing_Lib_Unit_Node --
1547 -----------------------------
1549 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
1550 Current_Node
: Node_Id
:= N
;
1553 while Present
(Current_Node
)
1554 and then Nkind
(Current_Node
) /= N_Compilation_Unit
1556 Current_Node
:= Parent
(Current_Node
);
1559 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
1563 return Current_Node
;
1564 end Enclosing_Lib_Unit_Node
;
1566 --------------------------
1567 -- Enclosing_Subprogram --
1568 --------------------------
1570 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
1571 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
1574 if Dynamic_Scope
= Standard_Standard
then
1577 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
1578 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
1580 elsif Ekind
(Dynamic_Scope
) = E_Block
then
1581 return Enclosing_Subprogram
(Dynamic_Scope
);
1583 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
1584 return Get_Task_Body_Procedure
(Dynamic_Scope
);
1586 elsif Convention
(Dynamic_Scope
) = Convention_Protected
then
1587 return Protected_Body_Subprogram
(Dynamic_Scope
);
1590 return Dynamic_Scope
;
1592 end Enclosing_Subprogram
;
1594 ------------------------
1595 -- Ensure_Freeze_Node --
1596 ------------------------
1598 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
1602 if No
(Freeze_Node
(E
)) then
1603 FN
:= Make_Freeze_Entity
(Sloc
(E
));
1604 Set_Has_Delayed_Freeze
(E
);
1605 Set_Freeze_Node
(E
, FN
);
1606 Set_Access_Types_To_Process
(FN
, No_Elist
);
1607 Set_TSS_Elist
(FN
, No_Elist
);
1610 end Ensure_Freeze_Node
;
1616 procedure Enter_Name
(Def_Id
: Node_Id
) is
1617 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
1618 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
1619 S
: constant Entity_Id
:= Current_Scope
;
1622 Generate_Definition
(Def_Id
);
1624 -- Add new name to current scope declarations. Check for duplicate
1625 -- declaration, which may or may not be a genuine error.
1629 -- Case of previous entity entered because of a missing declaration
1630 -- or else a bad subtype indication. Best is to use the new entity,
1631 -- and make the previous one invisible.
1633 if Etype
(E
) = Any_Type
then
1634 Set_Is_Immediately_Visible
(E
, False);
1636 -- Case of renaming declaration constructed for package instances.
1637 -- if there is an explicit declaration with the same identifier,
1638 -- the renaming is not immediately visible any longer, but remains
1639 -- visible through selected component notation.
1641 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
1642 and then not Comes_From_Source
(E
)
1644 Set_Is_Immediately_Visible
(E
, False);
1646 -- The new entity may be the package renaming, which has the same
1647 -- same name as a generic formal which has been seen already.
1649 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
1650 and then not Comes_From_Source
(Def_Id
)
1652 Set_Is_Immediately_Visible
(E
, False);
1654 -- For a fat pointer corresponding to a remote access to subprogram,
1655 -- we use the same identifier as the RAS type, so that the proper
1656 -- name appears in the stub. This type is only retrieved through
1657 -- the RAS type and never by visibility, and is not added to the
1658 -- visibility list (see below).
1660 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
1661 and then Present
(Corresponding_Remote_Type
(Def_Id
))
1665 -- A controller component for a type extension overrides the
1666 -- inherited component.
1668 elsif Chars
(E
) = Name_uController
then
1671 -- Case of an implicit operation or derived literal. The new entity
1672 -- hides the implicit one, which is removed from all visibility,
1673 -- i.e. the entity list of its scope, and homonym chain of its name.
1675 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
1676 or else Is_Internal
(E
)
1680 Prev_Vis
: Entity_Id
;
1681 Decl
: constant Node_Id
:= Parent
(E
);
1684 -- If E is an implicit declaration, it cannot be the first
1685 -- entity in the scope.
1687 Prev
:= First_Entity
(Current_Scope
);
1689 while Present
(Prev
)
1690 and then Next_Entity
(Prev
) /= E
1697 -- If E is not on the entity chain of the current scope,
1698 -- it is an implicit declaration in the generic formal
1699 -- part of a generic subprogram. When analyzing the body,
1700 -- the generic formals are visible but not on the entity
1701 -- chain of the subprogram. The new entity will become
1702 -- the visible one in the body.
1705 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
1709 Set_Next_Entity
(Prev
, Next_Entity
(E
));
1711 if No
(Next_Entity
(Prev
)) then
1712 Set_Last_Entity
(Current_Scope
, Prev
);
1715 if E
= Current_Entity
(E
) then
1719 Prev_Vis
:= Current_Entity
(E
);
1720 while Homonym
(Prev_Vis
) /= E
loop
1721 Prev_Vis
:= Homonym
(Prev_Vis
);
1725 if Present
(Prev_Vis
) then
1727 -- Skip E in the visibility chain
1729 Set_Homonym
(Prev_Vis
, Homonym
(E
));
1732 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
1737 -- This section of code could use a comment ???
1739 elsif Present
(Etype
(E
))
1740 and then Is_Concurrent_Type
(Etype
(E
))
1745 -- In the body or private part of an instance, a type extension
1746 -- may introduce a component with the same name as that of an
1747 -- actual. The legality rule is not enforced, but the semantics
1748 -- of the full type with two components of the same name are not
1749 -- clear at this point ???
1751 elsif In_Instance_Not_Visible
then
1754 -- When compiling a package body, some child units may have become
1755 -- visible. They cannot conflict with local entities that hide them.
1757 elsif Is_Child_Unit
(E
)
1758 and then In_Open_Scopes
(Scope
(E
))
1759 and then not Is_Immediately_Visible
(E
)
1763 -- Conversely, with front-end inlining we may compile the parent
1764 -- body first, and a child unit subsequently. The context is now
1765 -- the parent spec, and body entities are not visible.
1767 elsif Is_Child_Unit
(Def_Id
)
1768 and then Is_Package_Body_Entity
(E
)
1769 and then not In_Package_Body
(Current_Scope
)
1773 -- Case of genuine duplicate declaration
1776 Error_Msg_Sloc
:= Sloc
(E
);
1778 -- If the previous declaration is an incomplete type declaration
1779 -- this may be an attempt to complete it with a private type.
1780 -- The following avoids confusing cascaded errors.
1782 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
1783 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
1786 ("incomplete type cannot be completed" &
1787 " with a private declaration",
1789 Set_Is_Immediately_Visible
(E
, False);
1790 Set_Full_View
(E
, Def_Id
);
1792 elsif Ekind
(E
) = E_Discriminant
1793 and then Present
(Scope
(Def_Id
))
1794 and then Scope
(Def_Id
) /= Current_Scope
1796 -- An inherited component of a record conflicts with
1797 -- a new discriminant. The discriminant is inserted first
1798 -- in the scope, but the error should be posted on it, not
1799 -- on the component.
1801 Error_Msg_Sloc
:= Sloc
(Def_Id
);
1802 Error_Msg_N
("& conflicts with declaration#", E
);
1805 -- If the name of the unit appears in its own context clause,
1806 -- a dummy package with the name has already been created, and
1807 -- the error emitted. Try to continue quietly.
1809 elsif Error_Posted
(E
)
1810 and then Sloc
(E
) = No_Location
1811 and then Nkind
(Parent
(E
)) = N_Package_Specification
1812 and then Current_Scope
= Standard_Standard
1814 Set_Scope
(Def_Id
, Current_Scope
);
1818 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
1820 -- Avoid cascaded messages with duplicate components in
1823 if Ekind
(E
) = E_Component
1824 or else Ekind
(E
) = E_Discriminant
1830 if Nkind
(Parent
(Parent
(Def_Id
)))
1831 = N_Generic_Subprogram_Declaration
1833 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
1835 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
1838 -- If entity is in standard, then we are in trouble, because
1839 -- it means that we have a library package with a duplicated
1840 -- name. That's hard to recover from, so abort!
1842 if S
= Standard_Standard
then
1843 raise Unrecoverable_Error
;
1845 -- Otherwise we continue with the declaration. Having two
1846 -- identical declarations should not cause us too much trouble!
1854 -- If we fall through, declaration is OK , or OK enough to continue
1856 -- If Def_Id is a discriminant or a record component we are in the
1857 -- midst of inheriting components in a derived record definition.
1858 -- Preserve their Ekind and Etype.
1860 if Ekind
(Def_Id
) = E_Discriminant
1861 or else Ekind
(Def_Id
) = E_Component
1865 -- If a type is already set, leave it alone (happens whey a type
1866 -- declaration is reanalyzed following a call to the optimizer)
1868 elsif Present
(Etype
(Def_Id
)) then
1871 -- Otherwise, the kind E_Void insures that premature uses of the entity
1872 -- will be detected. Any_Type insures that no cascaded errors will occur
1875 Set_Ekind
(Def_Id
, E_Void
);
1876 Set_Etype
(Def_Id
, Any_Type
);
1879 -- Inherited discriminants and components in derived record types are
1880 -- immediately visible. Itypes are not.
1882 if Ekind
(Def_Id
) = E_Discriminant
1883 or else Ekind
(Def_Id
) = E_Component
1884 or else (No
(Corresponding_Remote_Type
(Def_Id
))
1885 and then not Is_Itype
(Def_Id
))
1887 Set_Is_Immediately_Visible
(Def_Id
);
1888 Set_Current_Entity
(Def_Id
);
1891 Set_Homonym
(Def_Id
, C
);
1892 Append_Entity
(Def_Id
, S
);
1893 Set_Public_Status
(Def_Id
);
1895 -- Warn if new entity hides an old one
1898 and then Present
(C
)
1899 and then Length_Of_Name
(Chars
(C
)) /= 1
1900 and then Comes_From_Source
(C
)
1901 and then Comes_From_Source
(Def_Id
)
1902 and then In_Extended_Main_Source_Unit
(Def_Id
)
1904 Error_Msg_Sloc
:= Sloc
(C
);
1905 Error_Msg_N
("declaration hides &#?", Def_Id
);
1909 --------------------------
1910 -- Explain_Limited_Type --
1911 --------------------------
1913 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
1917 -- For array, component type must be limited
1919 if Is_Array_Type
(T
) then
1920 Error_Msg_Node_2
:= T
;
1922 ("component type& of type& is limited", N
, Component_Type
(T
));
1923 Explain_Limited_Type
(Component_Type
(T
), N
);
1925 elsif Is_Record_Type
(T
) then
1927 -- No need for extra messages if explicit limited record
1929 if Is_Limited_Record
(Base_Type
(T
)) then
1933 -- Otherwise find a limited component. Check only components that
1934 -- come from source, or inherited components that appear in the
1935 -- source of the ancestor.
1937 C
:= First_Component
(T
);
1938 while Present
(C
) loop
1939 if Is_Limited_Type
(Etype
(C
))
1941 (Comes_From_Source
(C
)
1943 (Present
(Original_Record_Component
(C
))
1945 Comes_From_Source
(Original_Record_Component
(C
))))
1947 Error_Msg_Node_2
:= T
;
1948 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
1949 Explain_Limited_Type
(Etype
(C
), N
);
1956 -- The type may be declared explicitly limited, even if no component
1957 -- of it is limited, in which case we fall out of the loop.
1960 end Explain_Limited_Type
;
1962 -------------------------------------
1963 -- Find_Corresponding_Discriminant --
1964 -------------------------------------
1966 function Find_Corresponding_Discriminant
1968 Typ
: Entity_Id
) return Entity_Id
1970 Par_Disc
: Entity_Id
;
1971 Old_Disc
: Entity_Id
;
1972 New_Disc
: Entity_Id
;
1975 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
1977 -- The original type may currently be private, and the discriminant
1978 -- only appear on its full view.
1980 if Is_Private_Type
(Scope
(Par_Disc
))
1981 and then not Has_Discriminants
(Scope
(Par_Disc
))
1982 and then Present
(Full_View
(Scope
(Par_Disc
)))
1984 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
1986 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
1989 if Is_Class_Wide_Type
(Typ
) then
1990 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
1992 New_Disc
:= First_Discriminant
(Typ
);
1995 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
1996 if Old_Disc
= Par_Disc
then
1999 Next_Discriminant
(Old_Disc
);
2000 Next_Discriminant
(New_Disc
);
2004 -- Should always find it
2006 raise Program_Error
;
2007 end Find_Corresponding_Discriminant
;
2009 -----------------------------
2010 -- Find_Static_Alternative --
2011 -----------------------------
2013 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
2014 Expr
: constant Node_Id
:= Expression
(N
);
2015 Val
: constant Uint
:= Expr_Value
(Expr
);
2020 Alt
:= First
(Alternatives
(N
));
2023 if Nkind
(Alt
) /= N_Pragma
then
2024 Choice
:= First
(Discrete_Choices
(Alt
));
2026 while Present
(Choice
) loop
2028 -- Others choice, always matches
2030 if Nkind
(Choice
) = N_Others_Choice
then
2033 -- Range, check if value is in the range
2035 elsif Nkind
(Choice
) = N_Range
then
2037 Val
>= Expr_Value
(Low_Bound
(Choice
))
2039 Val
<= Expr_Value
(High_Bound
(Choice
));
2041 -- Choice is a subtype name. Note that we know it must
2042 -- be a static subtype, since otherwise it would have
2043 -- been diagnosed as illegal.
2045 elsif Is_Entity_Name
(Choice
)
2046 and then Is_Type
(Entity
(Choice
))
2048 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
));
2050 -- Choice is a subtype indication
2052 elsif Nkind
(Choice
) = N_Subtype_Indication
then
2054 C
: constant Node_Id
:= Constraint
(Choice
);
2055 R
: constant Node_Id
:= Range_Expression
(C
);
2059 Val
>= Expr_Value
(Low_Bound
(R
))
2061 Val
<= Expr_Value
(High_Bound
(R
));
2064 -- Choice is a simple expression
2067 exit Search
when Val
= Expr_Value
(Choice
);
2075 pragma Assert
(Present
(Alt
));
2078 -- The above loop *must* terminate by finding a match, since
2079 -- we know the case statement is valid, and the value of the
2080 -- expression is known at compile time. When we fall out of
2081 -- the loop, Alt points to the alternative that we know will
2082 -- be selected at run time.
2085 end Find_Static_Alternative
;
2091 function First_Actual
(Node
: Node_Id
) return Node_Id
is
2095 if No
(Parameter_Associations
(Node
)) then
2099 N
:= First
(Parameter_Associations
(Node
));
2101 if Nkind
(N
) = N_Parameter_Association
then
2102 return First_Named_Actual
(Node
);
2108 -------------------------
2109 -- Full_Qualified_Name --
2110 -------------------------
2112 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2114 pragma Warnings
(Off
, Res
);
2116 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
2117 -- Compute recursively the qualified name without NUL at the end
2119 ----------------------------------
2120 -- Internal_Full_Qualified_Name --
2121 ----------------------------------
2123 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2124 Ent
: Entity_Id
:= E
;
2125 Parent_Name
: String_Id
:= No_String
;
2128 -- Deals properly with child units
2130 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
2131 Ent
:= Defining_Identifier
(Ent
);
2134 -- Compute recursively the qualification. Only "Standard" has no
2137 if Present
(Scope
(Scope
(Ent
))) then
2138 Parent_Name
:= Internal_Full_Qualified_Name
(Scope
(Ent
));
2141 -- Every entity should have a name except some expanded blocks
2142 -- don't bother about those.
2144 if Chars
(Ent
) = No_Name
then
2148 -- Add a period between Name and qualification
2150 if Parent_Name
/= No_String
then
2151 Start_String
(Parent_Name
);
2152 Store_String_Char
(Get_Char_Code
('.'));
2158 -- Generates the entity name in upper case
2160 Get_Name_String
(Chars
(Ent
));
2162 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2164 end Internal_Full_Qualified_Name
;
2166 -- Start of processing for Full_Qualified_Name
2169 Res
:= Internal_Full_Qualified_Name
(E
);
2170 Store_String_Char
(Get_Char_Code
(ASCII
.nul
));
2172 end Full_Qualified_Name
;
2174 -----------------------
2175 -- Gather_Components --
2176 -----------------------
2178 procedure Gather_Components
2180 Comp_List
: Node_Id
;
2181 Governed_By
: List_Id
;
2183 Report_Errors
: out Boolean)
2187 Discrete_Choice
: Node_Id
;
2188 Comp_Item
: Node_Id
;
2190 Discrim
: Entity_Id
;
2191 Discrim_Name
: Node_Id
;
2192 Discrim_Value
: Node_Id
;
2195 Report_Errors
:= False;
2197 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
2200 elsif Present
(Component_Items
(Comp_List
)) then
2201 Comp_Item
:= First
(Component_Items
(Comp_List
));
2207 while Present
(Comp_Item
) loop
2209 -- Skip the tag of a tagged record, as well as all items
2210 -- that are not user components (anonymous types, rep clauses,
2211 -- Parent field, controller field).
2213 if Nkind
(Comp_Item
) = N_Component_Declaration
2214 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uTag
2215 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uParent
2216 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uController
2218 Append_Elmt
(Defining_Identifier
(Comp_Item
), Into
);
2224 if No
(Variant_Part
(Comp_List
)) then
2227 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
2228 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
2231 -- Look for the discriminant that governs this variant part.
2232 -- The discriminant *must* be in the Governed_By List
2234 Assoc
:= First
(Governed_By
);
2235 Find_Constraint
: loop
2236 Discrim
:= First
(Choices
(Assoc
));
2237 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
2238 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
2240 Chars
(Corresponding_Discriminant
(Entity
(Discrim
)))
2241 = Chars
(Discrim_Name
))
2242 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
2243 = Chars
(Discrim_Name
);
2245 if No
(Next
(Assoc
)) then
2246 if not Is_Constrained
(Typ
)
2247 and then Is_Derived_Type
(Typ
)
2248 and then Present
(Stored_Constraint
(Typ
))
2251 -- If the type is a tagged type with inherited discriminants,
2252 -- use the stored constraint on the parent in order to find
2253 -- the values of discriminants that are otherwise hidden by an
2254 -- explicit constraint. Renamed discriminants are handled in
2257 -- If several parent discriminants are renamed by a single
2258 -- discriminant of the derived type, the call to obtain the
2259 -- Corresponding_Discriminant field only retrieves the last
2260 -- of them. We recover the constraint on the others from the
2261 -- Stored_Constraint as well.
2268 D
:= First_Discriminant
(Etype
(Typ
));
2269 C
:= First_Elmt
(Stored_Constraint
(Typ
));
2272 and then Present
(C
)
2274 if Chars
(Discrim_Name
) = Chars
(D
) then
2275 if Is_Entity_Name
(Node
(C
))
2276 and then Entity
(Node
(C
)) = Entity
(Discrim
)
2278 -- D is renamed by Discrim, whose value is
2285 Make_Component_Association
(Sloc
(Typ
),
2287 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
2288 Duplicate_Subexpr_No_Checks
(Node
(C
)));
2290 exit Find_Constraint
;
2293 D
:= Next_Discriminant
(D
);
2300 if No
(Next
(Assoc
)) then
2301 Error_Msg_NE
(" missing value for discriminant&",
2302 First
(Governed_By
), Discrim_Name
);
2303 Report_Errors
:= True;
2308 end loop Find_Constraint
;
2310 Discrim_Value
:= Expression
(Assoc
);
2312 if not Is_OK_Static_Expression
(Discrim_Value
) then
2314 ("value for discriminant & must be static!",
2315 Discrim_Value
, Discrim
);
2316 Why_Not_Static
(Discrim_Value
);
2317 Report_Errors
:= True;
2321 Search_For_Discriminant_Value
: declare
2327 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
2330 Find_Discrete_Value
: while Present
(Variant
) loop
2331 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
2332 while Present
(Discrete_Choice
) loop
2334 exit Find_Discrete_Value
when
2335 Nkind
(Discrete_Choice
) = N_Others_Choice
;
2337 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
2339 UI_Low
:= Expr_Value
(Low
);
2340 UI_High
:= Expr_Value
(High
);
2342 exit Find_Discrete_Value
when
2343 UI_Low
<= UI_Discrim_Value
2345 UI_High
>= UI_Discrim_Value
;
2347 Next
(Discrete_Choice
);
2350 Next_Non_Pragma
(Variant
);
2351 end loop Find_Discrete_Value
;
2352 end Search_For_Discriminant_Value
;
2354 if No
(Variant
) then
2356 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
2357 Report_Errors
:= True;
2361 -- If we have found the corresponding choice, recursively add its
2362 -- components to the Into list.
2364 Gather_Components
(Empty
,
2365 Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
2366 end Gather_Components
;
2368 ------------------------
2369 -- Get_Actual_Subtype --
2370 ------------------------
2372 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
2373 Typ
: constant Entity_Id
:= Etype
(N
);
2374 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
2379 if not Present
(Utyp
) then
2383 -- If what we have is an identifier that references a subprogram
2384 -- formal, or a variable or constant object, then we get the actual
2385 -- subtype from the referenced entity if one has been built.
2387 if Nkind
(N
) = N_Identifier
2389 (Is_Formal
(Entity
(N
))
2390 or else Ekind
(Entity
(N
)) = E_Constant
2391 or else Ekind
(Entity
(N
)) = E_Variable
)
2392 and then Present
(Actual_Subtype
(Entity
(N
)))
2394 return Actual_Subtype
(Entity
(N
));
2396 -- Actual subtype of unchecked union is always itself. We never need
2397 -- the "real" actual subtype. If we did, we couldn't get it anyway
2398 -- because the discriminant is not available. The restrictions on
2399 -- Unchecked_Union are designed to make sure that this is OK.
2401 elsif Is_Unchecked_Union
(Base_Type
(Utyp
)) then
2404 -- Here for the unconstrained case, we must find actual subtype
2405 -- No actual subtype is available, so we must build it on the fly.
2407 -- Checking the type, not the underlying type, for constrainedness
2408 -- seems to be necessary. Maybe all the tests should be on the type???
2410 elsif (not Is_Constrained
(Typ
))
2411 and then (Is_Array_Type
(Utyp
)
2412 or else (Is_Record_Type
(Utyp
)
2413 and then Has_Discriminants
(Utyp
)))
2414 and then not Has_Unknown_Discriminants
(Utyp
)
2415 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
2417 -- Nothing to do if in default expression
2419 if In_Default_Expression
then
2422 elsif Is_Private_Type
(Typ
)
2423 and then not Has_Discriminants
(Typ
)
2425 -- If the type has no discriminants, there is no subtype to
2426 -- build, even if the underlying type is discriminated.
2430 -- Else build the actual subtype
2433 Decl
:= Build_Actual_Subtype
(Typ
, N
);
2434 Atyp
:= Defining_Identifier
(Decl
);
2436 -- If Build_Actual_Subtype generated a new declaration then use it
2440 -- The actual subtype is an Itype, so analyze the declaration,
2441 -- but do not attach it to the tree, to get the type defined.
2443 Set_Parent
(Decl
, N
);
2444 Set_Is_Itype
(Atyp
);
2445 Analyze
(Decl
, Suppress
=> All_Checks
);
2446 Set_Associated_Node_For_Itype
(Atyp
, N
);
2447 Set_Has_Delayed_Freeze
(Atyp
, False);
2449 -- We need to freeze the actual subtype immediately. This is
2450 -- needed, because otherwise this Itype will not get frozen
2451 -- at all, and it is always safe to freeze on creation because
2452 -- any associated types must be frozen at this point.
2454 Freeze_Itype
(Atyp
, N
);
2457 -- Otherwise we did not build a declaration, so return original
2464 -- For all remaining cases, the actual subtype is the same as
2465 -- the nominal type.
2470 end Get_Actual_Subtype
;
2472 -------------------------------------
2473 -- Get_Actual_Subtype_If_Available --
2474 -------------------------------------
2476 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
2477 Typ
: constant Entity_Id
:= Etype
(N
);
2480 -- If what we have is an identifier that references a subprogram
2481 -- formal, or a variable or constant object, then we get the actual
2482 -- subtype from the referenced entity if one has been built.
2484 if Nkind
(N
) = N_Identifier
2486 (Is_Formal
(Entity
(N
))
2487 or else Ekind
(Entity
(N
)) = E_Constant
2488 or else Ekind
(Entity
(N
)) = E_Variable
)
2489 and then Present
(Actual_Subtype
(Entity
(N
)))
2491 return Actual_Subtype
(Entity
(N
));
2493 -- Otherwise the Etype of N is returned unchanged
2498 end Get_Actual_Subtype_If_Available
;
2500 -------------------------------
2501 -- Get_Default_External_Name --
2502 -------------------------------
2504 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
2506 Get_Decoded_Name_String
(Chars
(E
));
2508 if Opt
.External_Name_Imp_Casing
= Uppercase
then
2509 Set_Casing
(All_Upper_Case
);
2511 Set_Casing
(All_Lower_Case
);
2515 Make_String_Literal
(Sloc
(E
),
2516 Strval
=> String_From_Name_Buffer
);
2517 end Get_Default_External_Name
;
2519 ---------------------------
2520 -- Get_Enum_Lit_From_Pos --
2521 ---------------------------
2523 function Get_Enum_Lit_From_Pos
2526 Loc
: Source_Ptr
) return Node_Id
2531 -- In the case where the literal is of type Character, Wide_Character
2532 -- or Wide_Wide_Character or of a type derived from them, there needs
2533 -- to be some special handling since there is no explicit chain of
2534 -- literals to search. Instead, an N_Character_Literal node is created
2535 -- with the appropriate Char_Code and Chars fields.
2537 if Root_Type
(T
) = Standard_Character
2538 or else Root_Type
(T
) = Standard_Wide_Character
2539 or else Root_Type
(T
) = Standard_Wide_Wide_Character
2541 Set_Character_Literal_Name
(UI_To_CC
(Pos
));
2543 Make_Character_Literal
(Loc
,
2545 Char_Literal_Value
=> Pos
);
2547 -- For all other cases, we have a complete table of literals, and
2548 -- we simply iterate through the chain of literal until the one
2549 -- with the desired position value is found.
2553 Lit
:= First_Literal
(Base_Type
(T
));
2554 for J
in 1 .. UI_To_Int
(Pos
) loop
2558 return New_Occurrence_Of
(Lit
, Loc
);
2560 end Get_Enum_Lit_From_Pos
;
2562 ------------------------
2563 -- Get_Generic_Entity --
2564 ------------------------
2566 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
2567 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2569 if Present
(Renamed_Object
(Ent
)) then
2570 return Renamed_Object
(Ent
);
2574 end Get_Generic_Entity
;
2576 ----------------------
2577 -- Get_Index_Bounds --
2578 ----------------------
2580 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
2581 Kind
: constant Node_Kind
:= Nkind
(N
);
2585 if Kind
= N_Range
then
2587 H
:= High_Bound
(N
);
2589 elsif Kind
= N_Subtype_Indication
then
2590 R
:= Range_Expression
(Constraint
(N
));
2598 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
2599 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
2602 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
2603 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
2607 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
2608 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
2611 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
2612 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
2616 -- N is an expression, indicating a range with one value
2621 end Get_Index_Bounds
;
2623 ----------------------------------
2624 -- Get_Library_Unit_Name_string --
2625 ----------------------------------
2627 procedure Get_Library_Unit_Name_String
(Decl_Node
: Node_Id
) is
2628 Unit_Name_Id
: constant Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
2631 Get_Unit_Name_String
(Unit_Name_Id
);
2633 -- Remove seven last character (" (spec)" or " (body)")
2635 Name_Len
:= Name_Len
- 7;
2636 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
2637 end Get_Library_Unit_Name_String
;
2639 ------------------------
2640 -- Get_Name_Entity_Id --
2641 ------------------------
2643 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
2645 return Entity_Id
(Get_Name_Table_Info
(Id
));
2646 end Get_Name_Entity_Id
;
2648 ---------------------------
2649 -- Get_Referenced_Object --
2650 ---------------------------
2652 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
2656 while Is_Entity_Name
(R
)
2657 and then Present
(Renamed_Object
(Entity
(R
)))
2659 R
:= Renamed_Object
(Entity
(R
));
2663 end Get_Referenced_Object
;
2665 -------------------------
2666 -- Get_Subprogram_Body --
2667 -------------------------
2669 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
2673 Decl
:= Unit_Declaration_Node
(E
);
2675 if Nkind
(Decl
) = N_Subprogram_Body
then
2678 -- The below comment is bad, because it is possible for
2679 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
2681 else -- Nkind (Decl) = N_Subprogram_Declaration
2683 if Present
(Corresponding_Body
(Decl
)) then
2684 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2686 -- Imported subprogram case
2692 end Get_Subprogram_Body
;
2694 -----------------------------
2695 -- Get_Task_Body_Procedure --
2696 -----------------------------
2698 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
2700 return Task_Body_Procedure
(Declaration_Node
(Root_Type
(E
)));
2701 end Get_Task_Body_Procedure
;
2703 -----------------------
2704 -- Has_Access_Values --
2705 -----------------------
2707 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
2708 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
2711 -- Case of a private type which is not completed yet. This can only
2712 -- happen in the case of a generic format type appearing directly, or
2713 -- as a component of the type to which this function is being applied
2714 -- at the top level. Return False in this case, since we certainly do
2715 -- not know that the type contains access types.
2720 elsif Is_Access_Type
(Typ
) then
2723 elsif Is_Array_Type
(Typ
) then
2724 return Has_Access_Values
(Component_Type
(Typ
));
2726 elsif Is_Record_Type
(Typ
) then
2731 Comp
:= First_Entity
(Typ
);
2732 while Present
(Comp
) loop
2733 if (Ekind
(Comp
) = E_Component
2735 Ekind
(Comp
) = E_Discriminant
)
2736 and then Has_Access_Values
(Etype
(Comp
))
2750 end Has_Access_Values
;
2752 ----------------------
2753 -- Has_Declarations --
2754 ----------------------
2756 function Has_Declarations
(N
: Node_Id
) return Boolean is
2757 K
: constant Node_Kind
:= Nkind
(N
);
2759 return K
= N_Accept_Statement
2760 or else K
= N_Block_Statement
2761 or else K
= N_Compilation_Unit_Aux
2762 or else K
= N_Entry_Body
2763 or else K
= N_Package_Body
2764 or else K
= N_Protected_Body
2765 or else K
= N_Subprogram_Body
2766 or else K
= N_Task_Body
2767 or else K
= N_Package_Specification
;
2768 end Has_Declarations
;
2770 --------------------
2771 -- Has_Infinities --
2772 --------------------
2774 function Has_Infinities
(E
: Entity_Id
) return Boolean is
2777 Is_Floating_Point_Type
(E
)
2778 and then Nkind
(Scalar_Range
(E
)) = N_Range
2779 and then Includes_Infinities
(Scalar_Range
(E
));
2782 ------------------------
2783 -- Has_Null_Extension --
2784 ------------------------
2786 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
2787 B
: constant Entity_Id
:= Base_Type
(T
);
2792 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
2793 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
2795 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
2797 if Present
(Ext
) then
2798 if Null_Present
(Ext
) then
2801 Comps
:= Component_List
(Ext
);
2803 -- The null component list is rewritten during analysis to
2804 -- include the parent component. Any other component indicates
2805 -- that the extension was not originally null.
2807 return Null_Present
(Comps
)
2808 or else No
(Next
(First
(Component_Items
(Comps
))));
2817 end Has_Null_Extension
;
2819 ---------------------------
2820 -- Has_Private_Component --
2821 ---------------------------
2823 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
2824 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
2825 Component
: Entity_Id
;
2828 if Error_Posted
(Type_Id
)
2829 or else Error_Posted
(Btype
)
2834 if Is_Class_Wide_Type
(Btype
) then
2835 Btype
:= Root_Type
(Btype
);
2838 if Is_Private_Type
(Btype
) then
2840 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
2844 if No
(Full_View
(Btype
)) then
2845 return not Is_Generic_Type
(Btype
)
2846 and then not Is_Generic_Type
(Root_Type
(Btype
));
2849 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
2853 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
2856 elsif Is_Array_Type
(Btype
) then
2857 return Has_Private_Component
(Component_Type
(Btype
));
2859 elsif Is_Record_Type
(Btype
) then
2861 Component
:= First_Component
(Btype
);
2862 while Present
(Component
) loop
2864 if Has_Private_Component
(Etype
(Component
)) then
2868 Next_Component
(Component
);
2873 elsif Is_Protected_Type
(Btype
)
2874 and then Present
(Corresponding_Record_Type
(Btype
))
2876 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
2881 end Has_Private_Component
;
2887 function Has_Stream
(T
: Entity_Id
) return Boolean is
2894 elsif Is_RTE
(Root_Type
(T
), RE_Root_Stream_Type
) then
2897 elsif Is_Array_Type
(T
) then
2898 return Has_Stream
(Component_Type
(T
));
2900 elsif Is_Record_Type
(T
) then
2901 E
:= First_Component
(T
);
2902 while Present
(E
) loop
2903 if Has_Stream
(Etype
(E
)) then
2912 elsif Is_Private_Type
(T
) then
2913 return Has_Stream
(Underlying_Type
(T
));
2920 --------------------------
2921 -- Has_Tagged_Component --
2922 --------------------------
2924 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
2928 if Is_Private_Type
(Typ
)
2929 and then Present
(Underlying_Type
(Typ
))
2931 return Has_Tagged_Component
(Underlying_Type
(Typ
));
2933 elsif Is_Array_Type
(Typ
) then
2934 return Has_Tagged_Component
(Component_Type
(Typ
));
2936 elsif Is_Tagged_Type
(Typ
) then
2939 elsif Is_Record_Type
(Typ
) then
2940 Comp
:= First_Component
(Typ
);
2942 while Present
(Comp
) loop
2943 if Has_Tagged_Component
(Etype
(Comp
)) then
2947 Comp
:= Next_Component
(Typ
);
2955 end Has_Tagged_Component
;
2961 function In_Instance
return Boolean is
2962 S
: Entity_Id
:= Current_Scope
;
2966 and then S
/= Standard_Standard
2968 if (Ekind
(S
) = E_Function
2969 or else Ekind
(S
) = E_Package
2970 or else Ekind
(S
) = E_Procedure
)
2971 and then Is_Generic_Instance
(S
)
2982 ----------------------
2983 -- In_Instance_Body --
2984 ----------------------
2986 function In_Instance_Body
return Boolean is
2987 S
: Entity_Id
:= Current_Scope
;
2991 and then S
/= Standard_Standard
2993 if (Ekind
(S
) = E_Function
2994 or else Ekind
(S
) = E_Procedure
)
2995 and then Is_Generic_Instance
(S
)
2999 elsif Ekind
(S
) = E_Package
3000 and then In_Package_Body
(S
)
3001 and then Is_Generic_Instance
(S
)
3010 end In_Instance_Body
;
3012 -----------------------------
3013 -- In_Instance_Not_Visible --
3014 -----------------------------
3016 function In_Instance_Not_Visible
return Boolean is
3017 S
: Entity_Id
:= Current_Scope
;
3021 and then S
/= Standard_Standard
3023 if (Ekind
(S
) = E_Function
3024 or else Ekind
(S
) = E_Procedure
)
3025 and then Is_Generic_Instance
(S
)
3029 elsif Ekind
(S
) = E_Package
3030 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
3031 and then Is_Generic_Instance
(S
)
3040 end In_Instance_Not_Visible
;
3042 ------------------------------
3043 -- In_Instance_Visible_Part --
3044 ------------------------------
3046 function In_Instance_Visible_Part
return Boolean is
3047 S
: Entity_Id
:= Current_Scope
;
3051 and then S
/= Standard_Standard
3053 if Ekind
(S
) = E_Package
3054 and then Is_Generic_Instance
(S
)
3055 and then not In_Package_Body
(S
)
3056 and then not In_Private_Part
(S
)
3065 end In_Instance_Visible_Part
;
3067 ----------------------
3068 -- In_Packiage_Body --
3069 ----------------------
3071 function In_Package_Body
return Boolean is
3072 S
: Entity_Id
:= Current_Scope
;
3076 and then S
/= Standard_Standard
3078 if Ekind
(S
) = E_Package
3079 and then In_Package_Body
(S
)
3088 end In_Package_Body
;
3090 --------------------------------------
3091 -- In_Subprogram_Or_Concurrent_Unit --
3092 --------------------------------------
3094 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
3099 -- Use scope chain to check successively outer scopes
3105 if K
in Subprogram_Kind
3106 or else K
in Concurrent_Kind
3107 or else K
in Generic_Subprogram_Kind
3111 elsif E
= Standard_Standard
then
3117 end In_Subprogram_Or_Concurrent_Unit
;
3119 ---------------------
3120 -- In_Visible_Part --
3121 ---------------------
3123 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
3126 Is_Package
(Scope_Id
)
3127 and then In_Open_Scopes
(Scope_Id
)
3128 and then not In_Package_Body
(Scope_Id
)
3129 and then not In_Private_Part
(Scope_Id
);
3130 end In_Visible_Part
;
3132 ---------------------------------
3133 -- Insert_Explicit_Dereference --
3134 ---------------------------------
3136 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
3137 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
3138 Ent
: Entity_Id
:= Empty
;
3144 Save_Interps
(N
, New_Prefix
);
3146 Make_Explicit_Dereference
(Sloc
(N
), Prefix
=> New_Prefix
));
3148 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
3150 if Is_Overloaded
(New_Prefix
) then
3152 -- The deference is also overloaded, and its interpretations are the
3153 -- designated types of the interpretations of the original node.
3155 Set_Etype
(N
, Any_Type
);
3156 Get_First_Interp
(New_Prefix
, I
, It
);
3158 while Present
(It
.Nam
) loop
3161 if Is_Access_Type
(T
) then
3162 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
3165 Get_Next_Interp
(I
, It
);
3171 -- Prefix is unambiguous: mark the original prefix (which might
3172 -- Come_From_Source) as a reference, since the new (relocated) one
3173 -- won't be taken into account.
3175 if Is_Entity_Name
(New_Prefix
) then
3176 Ent
:= Entity
(New_Prefix
);
3177 elsif Nkind
(New_Prefix
) = N_Selected_Component
then
3178 Ent
:= Entity
(Selector_Name
(New_Prefix
));
3181 if Present
(Ent
) then
3182 Generate_Reference
(Ent
, New_Prefix
);
3185 end Insert_Explicit_Dereference
;
3191 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
3193 pragma Assert
(Is_Type
(E
));
3195 return AAMP_On_Target
3196 and then Is_Floating_Point_Type
(E
)
3197 and then E
= Base_Type
(E
);
3200 -------------------------
3201 -- Is_Actual_Parameter --
3202 -------------------------
3204 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
3205 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3209 when N_Parameter_Association
=>
3210 return N
= Explicit_Actual_Parameter
(Parent
(N
));
3212 when N_Function_Call | N_Procedure_Call_Statement
=>
3213 return Is_List_Member
(N
)
3215 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
3220 end Is_Actual_Parameter
;
3222 ---------------------
3223 -- Is_Aliased_View --
3224 ---------------------
3226 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
3230 if Is_Entity_Name
(Obj
) then
3238 or else (Present
(Renamed_Object
(E
))
3239 and then Is_Aliased_View
(Renamed_Object
(E
)))))
3241 or else ((Is_Formal
(E
)
3242 or else Ekind
(E
) = E_Generic_In_Out_Parameter
3243 or else Ekind
(E
) = E_Generic_In_Parameter
)
3244 and then Is_Tagged_Type
(Etype
(E
)))
3246 or else ((Ekind
(E
) = E_Task_Type
3247 or else Ekind
(E
) = E_Protected_Type
)
3248 and then In_Open_Scopes
(E
))
3250 -- Current instance of type
3252 or else (Is_Type
(E
) and then E
= Current_Scope
)
3253 or else (Is_Incomplete_Or_Private_Type
(E
)
3254 and then Full_View
(E
) = Current_Scope
);
3256 elsif Nkind
(Obj
) = N_Selected_Component
then
3257 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
3259 elsif Nkind
(Obj
) = N_Indexed_Component
then
3260 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
3262 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
3264 Has_Aliased_Components
3265 (Designated_Type
(Etype
(Prefix
(Obj
)))));
3267 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
3268 or else Nkind
(Obj
) = N_Type_Conversion
3270 return Is_Tagged_Type
(Etype
(Obj
))
3271 and then Is_Aliased_View
(Expression
(Obj
));
3273 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
3274 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
3279 end Is_Aliased_View
;
3281 -------------------------
3282 -- Is_Ancestor_Package --
3283 -------------------------
3285 function Is_Ancestor_Package
3287 E2
: Entity_Id
) return Boolean
3294 and then Par
/= Standard_Standard
3304 end Is_Ancestor_Package
;
3306 ----------------------
3307 -- Is_Atomic_Object --
3308 ----------------------
3310 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
3312 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
3313 -- Determines if given object has atomic components
3315 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
3316 -- If prefix is an implicit dereference, examine designated type
3318 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
3320 if Is_Access_Type
(Etype
(N
)) then
3322 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
3324 return Object_Has_Atomic_Components
(N
);
3326 end Is_Atomic_Prefix
;
3328 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
3330 if Has_Atomic_Components
(Etype
(N
))
3331 or else Is_Atomic
(Etype
(N
))
3335 elsif Is_Entity_Name
(N
)
3336 and then (Has_Atomic_Components
(Entity
(N
))
3337 or else Is_Atomic
(Entity
(N
)))
3341 elsif Nkind
(N
) = N_Indexed_Component
3342 or else Nkind
(N
) = N_Selected_Component
3344 return Is_Atomic_Prefix
(Prefix
(N
));
3349 end Object_Has_Atomic_Components
;
3351 -- Start of processing for Is_Atomic_Object
3354 if Is_Atomic
(Etype
(N
))
3355 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
3359 elsif Nkind
(N
) = N_Indexed_Component
3360 or else Nkind
(N
) = N_Selected_Component
3362 return Is_Atomic_Prefix
(Prefix
(N
));
3367 end Is_Atomic_Object
;
3369 ----------------------------------------------
3370 -- Is_Dependent_Component_Of_Mutable_Object --
3371 ----------------------------------------------
3373 function Is_Dependent_Component_Of_Mutable_Object
3374 (Object
: Node_Id
) return Boolean
3377 Prefix_Type
: Entity_Id
;
3378 P_Aliased
: Boolean := False;
3381 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean;
3382 -- Returns True if and only if Comp has a constrained subtype
3383 -- that depends on a discriminant.
3385 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
3386 -- Returns True if and only if Comp is declared within a variant part
3388 ------------------------------
3389 -- Has_Dependent_Constraint --
3390 ------------------------------
3392 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean is
3393 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3394 Subt_Indic
: constant Node_Id
:=
3395 Subtype_Indication
(Component_Definition
(Comp_Decl
));
3400 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
3401 Constr
:= Constraint
(Subt_Indic
);
3403 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
3404 Assn
:= First
(Constraints
(Constr
));
3405 while Present
(Assn
) loop
3406 case Nkind
(Assn
) is
3407 when N_Subtype_Indication |
3411 if Depends_On_Discriminant
(Assn
) then
3415 when N_Discriminant_Association
=>
3416 if Depends_On_Discriminant
(Expression
(Assn
)) then
3431 end Has_Dependent_Constraint
;
3433 --------------------------------
3434 -- Is_Declared_Within_Variant --
3435 --------------------------------
3437 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
3438 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3439 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
3442 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
3443 end Is_Declared_Within_Variant
;
3445 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
3448 if Is_Variable
(Object
) then
3450 if Nkind
(Object
) = N_Selected_Component
then
3451 P
:= Prefix
(Object
);
3452 Prefix_Type
:= Etype
(P
);
3454 if Is_Entity_Name
(P
) then
3456 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
3457 Prefix_Type
:= Base_Type
(Prefix_Type
);
3460 if Is_Aliased
(Entity
(P
)) then
3464 -- A discriminant check on a selected component may be
3465 -- expanded into a dereference when removing side-effects.
3466 -- Recover the original node and its type, which may be
3469 elsif Nkind
(P
) = N_Explicit_Dereference
3470 and then not (Comes_From_Source
(P
))
3472 P
:= Original_Node
(P
);
3473 Prefix_Type
:= Etype
(P
);
3476 -- Check for prefix being an aliased component ???
3481 if Is_Access_Type
(Prefix_Type
)
3482 or else Nkind
(P
) = N_Explicit_Dereference
3488 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
3490 -- As per AI-0017, the renaming is illegal in a generic body,
3491 -- even if the subtype is indefinite.
3493 if not Is_Constrained
(Prefix_Type
)
3494 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
3496 (Is_Generic_Type
(Prefix_Type
)
3497 and then Ekind
(Current_Scope
) = E_Generic_Package
3498 and then In_Package_Body
(Current_Scope
)))
3500 and then (Is_Declared_Within_Variant
(Comp
)
3501 or else Has_Dependent_Constraint
(Comp
))
3502 and then not P_Aliased
3508 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3512 elsif Nkind
(Object
) = N_Indexed_Component
3513 or else Nkind
(Object
) = N_Slice
3515 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3517 -- A type conversion that Is_Variable is a view conversion:
3518 -- go back to the denoted object.
3520 elsif Nkind
(Object
) = N_Type_Conversion
then
3522 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
3527 end Is_Dependent_Component_Of_Mutable_Object
;
3529 ---------------------
3530 -- Is_Dereferenced --
3531 ---------------------
3533 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
3534 P
: constant Node_Id
:= Parent
(N
);
3538 (Nkind
(P
) = N_Selected_Component
3540 Nkind
(P
) = N_Explicit_Dereference
3542 Nkind
(P
) = N_Indexed_Component
3544 Nkind
(P
) = N_Slice
)
3545 and then Prefix
(P
) = N
;
3546 end Is_Dereferenced
;
3548 ----------------------
3549 -- Is_Descendent_Of --
3550 ----------------------
3552 function Is_Descendent_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
3557 pragma Assert
(Nkind
(T1
) in N_Entity
);
3558 pragma Assert
(Nkind
(T2
) in N_Entity
);
3560 T
:= Base_Type
(T1
);
3562 -- Immediate return if the types match
3567 -- Comment needed here ???
3569 elsif Ekind
(T
) = E_Class_Wide_Type
then
3570 return Etype
(T
) = T2
;
3578 -- Done if we found the type we are looking for
3583 -- Done if no more derivations to check
3590 -- Following test catches error cases resulting from prev errors
3592 elsif No
(Etyp
) then
3595 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
3598 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
3602 T
:= Base_Type
(Etyp
);
3606 raise Program_Error
;
3607 end Is_Descendent_Of
;
3609 ------------------------------
3610 -- Is_Descendent_Of_Address --
3611 ------------------------------
3613 function Is_Descendent_Of_Address
(T1
: Entity_Id
) return Boolean is
3615 -- If Address has not been loaded, answer must be False
3617 if not RTU_Loaded
(System
) then
3620 -- Otherwise we can get the entity we are interested in without
3621 -- causing an unwanted dependency on System, and do the test.
3624 return Is_Descendent_Of
(T1
, Base_Type
(RTE
(RE_Address
)));
3626 end Is_Descendent_Of_Address
;
3632 function Is_False
(U
: Uint
) return Boolean is
3637 ---------------------------
3638 -- Is_Fixed_Model_Number --
3639 ---------------------------
3641 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
3642 S
: constant Ureal
:= Small_Value
(T
);
3643 M
: Urealp
.Save_Mark
;
3648 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
3651 end Is_Fixed_Model_Number
;
3653 -------------------------------
3654 -- Is_Fully_Initialized_Type --
3655 -------------------------------
3657 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
3659 if Is_Scalar_Type
(Typ
) then
3662 elsif Is_Access_Type
(Typ
) then
3665 elsif Is_Array_Type
(Typ
) then
3666 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
3670 -- An interesting case, if we have a constrained type one of whose
3671 -- bounds is known to be null, then there are no elements to be
3672 -- initialized, so all the elements are initialized!
3674 if Is_Constrained
(Typ
) then
3677 Indx_Typ
: Entity_Id
;
3681 Indx
:= First_Index
(Typ
);
3682 while Present
(Indx
) loop
3684 if Etype
(Indx
) = Any_Type
then
3687 -- If index is a range, use directly
3689 elsif Nkind
(Indx
) = N_Range
then
3690 Lbd
:= Low_Bound
(Indx
);
3691 Hbd
:= High_Bound
(Indx
);
3694 Indx_Typ
:= Etype
(Indx
);
3696 if Is_Private_Type
(Indx_Typ
) then
3697 Indx_Typ
:= Full_View
(Indx_Typ
);
3700 if No
(Indx_Typ
) then
3703 Lbd
:= Type_Low_Bound
(Indx_Typ
);
3704 Hbd
:= Type_High_Bound
(Indx_Typ
);
3708 if Compile_Time_Known_Value
(Lbd
)
3709 and then Compile_Time_Known_Value
(Hbd
)
3711 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
3721 -- If no null indexes, then type is not fully initialized
3727 elsif Is_Record_Type
(Typ
) then
3728 if Has_Discriminants
(Typ
)
3730 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
3731 and then Is_Fully_Initialized_Variant
(Typ
)
3736 -- Controlled records are considered to be fully initialized if
3737 -- there is a user defined Initialize routine. This may not be
3738 -- entirely correct, but as the spec notes, we are guessing here
3739 -- what is best from the point of view of issuing warnings.
3741 if Is_Controlled
(Typ
) then
3743 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3746 if Present
(Utyp
) then
3748 Init
: constant Entity_Id
:=
3750 (Underlying_Type
(Typ
), Name_Initialize
));
3754 and then Comes_From_Source
(Init
)
3756 Is_Predefined_File_Name
3757 (File_Name
(Get_Source_File_Index
(Sloc
(Init
))))
3761 elsif Has_Null_Extension
(Typ
)
3763 Is_Fully_Initialized_Type
3764 (Etype
(Base_Type
(Typ
)))
3773 -- Otherwise see if all record components are initialized
3779 Ent
:= First_Entity
(Typ
);
3781 while Present
(Ent
) loop
3782 if Chars
(Ent
) = Name_uController
then
3785 elsif Ekind
(Ent
) = E_Component
3786 and then (No
(Parent
(Ent
))
3787 or else No
(Expression
(Parent
(Ent
))))
3788 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
3797 -- No uninitialized components, so type is fully initialized.
3798 -- Note that this catches the case of no components as well.
3802 elsif Is_Concurrent_Type
(Typ
) then
3805 elsif Is_Private_Type
(Typ
) then
3807 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3813 return Is_Fully_Initialized_Type
(U
);
3820 end Is_Fully_Initialized_Type
;
3822 ----------------------------------
3823 -- Is_Fully_Initialized_Variant --
3824 ----------------------------------
3826 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
3827 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3828 Constraints
: constant List_Id
:= New_List
;
3829 Components
: constant Elist_Id
:= New_Elmt_List
;
3830 Comp_Elmt
: Elmt_Id
;
3832 Comp_List
: Node_Id
;
3834 Discr_Val
: Node_Id
;
3835 Report_Errors
: Boolean;
3838 if Serious_Errors_Detected
> 0 then
3842 if Is_Record_Type
(Typ
)
3843 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
3844 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
3846 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
3847 Discr
:= First_Discriminant
(Typ
);
3849 while Present
(Discr
) loop
3850 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
3851 Discr_Val
:= Expression
(Parent
(Discr
));
3853 if Present
(Discr_Val
)
3854 and then Is_OK_Static_Expression
(Discr_Val
)
3856 Append_To
(Constraints
,
3857 Make_Component_Association
(Loc
,
3858 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
3859 Expression
=> New_Copy
(Discr_Val
)));
3867 Next_Discriminant
(Discr
);
3872 Comp_List
=> Comp_List
,
3873 Governed_By
=> Constraints
,
3875 Report_Errors
=> Report_Errors
);
3877 -- Check that each component present is fully initialized
3879 Comp_Elmt
:= First_Elmt
(Components
);
3881 while Present
(Comp_Elmt
) loop
3882 Comp_Id
:= Node
(Comp_Elmt
);
3884 if Ekind
(Comp_Id
) = E_Component
3885 and then (No
(Parent
(Comp_Id
))
3886 or else No
(Expression
(Parent
(Comp_Id
))))
3887 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
3892 Next_Elmt
(Comp_Elmt
);
3897 elsif Is_Private_Type
(Typ
) then
3899 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3905 return Is_Fully_Initialized_Variant
(U
);
3911 end Is_Fully_Initialized_Variant
;
3913 ----------------------------
3914 -- Is_Inherited_Operation --
3915 ----------------------------
3917 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
3918 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
3921 pragma Assert
(Is_Overloadable
(E
));
3922 return Kind
= N_Full_Type_Declaration
3923 or else Kind
= N_Private_Extension_Declaration
3924 or else Kind
= N_Subtype_Declaration
3925 or else (Ekind
(E
) = E_Enumeration_Literal
3926 and then Is_Derived_Type
(Etype
(E
)));
3927 end Is_Inherited_Operation
;
3929 -----------------------------
3930 -- Is_Library_Level_Entity --
3931 -----------------------------
3933 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
3935 -- The following is a small optimization, and it also handles
3936 -- properly discriminals, which in task bodies might appear in
3937 -- expressions before the corresponding procedure has been
3938 -- created, and which therefore do not have an assigned scope.
3940 if Ekind
(E
) in Formal_Kind
then
3944 -- Normal test is simply that the enclosing dynamic scope is Standard
3946 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
3947 end Is_Library_Level_Entity
;
3949 ---------------------------------
3950 -- Is_Local_Variable_Reference --
3951 ---------------------------------
3953 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
3955 if not Is_Entity_Name
(Expr
) then
3960 Ent
: constant Entity_Id
:= Entity
(Expr
);
3961 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
3964 if Ekind
(Ent
) /= E_Variable
3966 Ekind
(Ent
) /= E_In_Out_Parameter
3971 return Present
(Sub
) and then Sub
= Current_Subprogram
;
3975 end Is_Local_Variable_Reference
;
3981 function Is_Lvalue
(N
: Node_Id
) return Boolean is
3982 P
: constant Node_Id
:= Parent
(N
);
3987 -- Test left side of assignment
3989 when N_Assignment_Statement
=>
3990 return N
= Name
(P
);
3992 -- Test prefix of component or attribute
3994 when N_Attribute_Reference |
3996 N_Explicit_Dereference |
3997 N_Indexed_Component |
3999 N_Selected_Component |
4001 return N
= Prefix
(P
);
4003 -- Test subprogram parameter (we really should check the
4004 -- parameter mode, but it is not worth the trouble)
4006 when N_Function_Call |
4007 N_Procedure_Call_Statement |
4008 N_Accept_Statement |
4009 N_Parameter_Association
=>
4012 -- Test for appearing in a conversion that itself appears
4013 -- in an lvalue context, since this should be an lvalue.
4015 when N_Type_Conversion
=>
4016 return Is_Lvalue
(P
);
4018 -- Test for appearence in object renaming declaration
4020 when N_Object_Renaming_Declaration
=>
4023 -- All other references are definitely not Lvalues
4031 -------------------------
4032 -- Is_Object_Reference --
4033 -------------------------
4035 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
4037 if Is_Entity_Name
(N
) then
4038 return Is_Object
(Entity
(N
));
4042 when N_Indexed_Component | N_Slice
=>
4043 return Is_Object_Reference
(Prefix
(N
));
4045 -- In Ada95, a function call is a constant object
4047 when N_Function_Call
=>
4050 -- A reference to the stream attribute Input is a function call
4052 when N_Attribute_Reference
=>
4053 return Attribute_Name
(N
) = Name_Input
;
4055 when N_Selected_Component
=>
4057 Is_Object_Reference
(Selector_Name
(N
))
4058 and then Is_Object_Reference
(Prefix
(N
));
4060 when N_Explicit_Dereference
=>
4063 -- A view conversion of a tagged object is an object reference
4065 when N_Type_Conversion
=>
4066 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
4067 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
4068 and then Is_Object_Reference
(Expression
(N
));
4070 -- An unchecked type conversion is considered to be an object if
4071 -- the operand is an object (this construction arises only as a
4072 -- result of expansion activities).
4074 when N_Unchecked_Type_Conversion
=>
4081 end Is_Object_Reference
;
4083 -----------------------------------
4084 -- Is_OK_Variable_For_Out_Formal --
4085 -----------------------------------
4087 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
4089 Note_Possible_Modification
(AV
);
4091 -- We must reject parenthesized variable names. The check for
4092 -- Comes_From_Source is present because there are currently
4093 -- cases where the compiler violates this rule (e.g. passing
4094 -- a task object to its controlled Initialize routine).
4096 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
4099 -- A variable is always allowed
4101 elsif Is_Variable
(AV
) then
4104 -- Unchecked conversions are allowed only if they come from the
4105 -- generated code, which sometimes uses unchecked conversions for
4106 -- out parameters in cases where code generation is unaffected.
4107 -- We tell source unchecked conversions by seeing if they are
4108 -- rewrites of an original UC function call, or of an explicit
4109 -- conversion of a function call.
4111 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
4112 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
4115 elsif Comes_From_Source
(AV
)
4116 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
4120 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
4121 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
4127 -- Normal type conversions are allowed if argument is a variable
4129 elsif Nkind
(AV
) = N_Type_Conversion
then
4130 if Is_Variable
(Expression
(AV
))
4131 and then Paren_Count
(Expression
(AV
)) = 0
4133 Note_Possible_Modification
(Expression
(AV
));
4136 -- We also allow a non-parenthesized expression that raises
4137 -- constraint error if it rewrites what used to be a variable
4139 elsif Raises_Constraint_Error
(Expression
(AV
))
4140 and then Paren_Count
(Expression
(AV
)) = 0
4141 and then Is_Variable
(Original_Node
(Expression
(AV
)))
4145 -- Type conversion of something other than a variable
4151 -- If this node is rewritten, then test the original form, if that is
4152 -- OK, then we consider the rewritten node OK (for example, if the
4153 -- original node is a conversion, then Is_Variable will not be true
4154 -- but we still want to allow the conversion if it converts a variable).
4156 elsif Original_Node
(AV
) /= AV
then
4157 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
4159 -- All other non-variables are rejected
4164 end Is_OK_Variable_For_Out_Formal
;
4166 -----------------------------------
4167 -- Is_Partially_Initialized_Type --
4168 -----------------------------------
4170 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
4172 if Is_Scalar_Type
(Typ
) then
4175 elsif Is_Access_Type
(Typ
) then
4178 elsif Is_Array_Type
(Typ
) then
4180 -- If component type is partially initialized, so is array type
4182 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
4185 -- Otherwise we are only partially initialized if we are fully
4186 -- initialized (this is the empty array case, no point in us
4187 -- duplicating that code here).
4190 return Is_Fully_Initialized_Type
(Typ
);
4193 elsif Is_Record_Type
(Typ
) then
4195 -- A discriminated type is always partially initialized
4197 if Has_Discriminants
(Typ
) then
4200 -- A tagged type is always partially initialized
4202 elsif Is_Tagged_Type
(Typ
) then
4205 -- Case of non-discriminated record
4211 Component_Present
: Boolean := False;
4212 -- Set True if at least one component is present. If no
4213 -- components are present, then record type is fully
4214 -- initialized (another odd case, like the null array).
4217 -- Loop through components
4219 Ent
:= First_Entity
(Typ
);
4220 while Present
(Ent
) loop
4221 if Ekind
(Ent
) = E_Component
then
4222 Component_Present
:= True;
4224 -- If a component has an initialization expression then
4225 -- the enclosing record type is partially initialized
4227 if Present
(Parent
(Ent
))
4228 and then Present
(Expression
(Parent
(Ent
)))
4232 -- If a component is of a type which is itself partially
4233 -- initialized, then the enclosing record type is also.
4235 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
4243 -- No initialized components found. If we found any components
4244 -- they were all uninitialized so the result is false.
4246 if Component_Present
then
4249 -- But if we found no components, then all the components are
4250 -- initialized so we consider the type to be initialized.
4258 -- Concurrent types are always fully initialized
4260 elsif Is_Concurrent_Type
(Typ
) then
4263 -- For a private type, go to underlying type. If there is no underlying
4264 -- type then just assume this partially initialized. Not clear if this
4265 -- can happen in a non-error case, but no harm in testing for this.
4267 elsif Is_Private_Type
(Typ
) then
4269 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4275 return Is_Partially_Initialized_Type
(U
);
4279 -- For any other type (are there any?) assume partially initialized
4284 end Is_Partially_Initialized_Type
;
4286 -----------------------------
4287 -- Is_RCI_Pkg_Spec_Or_Body --
4288 -----------------------------
4290 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
4292 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
4293 -- Return True if the unit of Cunit is an RCI package declaration
4295 ---------------------------
4296 -- Is_RCI_Pkg_Decl_Cunit --
4297 ---------------------------
4299 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
4300 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
4303 if Nkind
(The_Unit
) /= N_Package_Declaration
then
4306 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
4307 end Is_RCI_Pkg_Decl_Cunit
;
4309 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
4312 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
4314 (Nkind
(Unit
(Cunit
)) = N_Package_Body
4315 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
4316 end Is_RCI_Pkg_Spec_Or_Body
;
4318 -----------------------------------------
4319 -- Is_Remote_Access_To_Class_Wide_Type --
4320 -----------------------------------------
4322 function Is_Remote_Access_To_Class_Wide_Type
4323 (E
: Entity_Id
) return Boolean
4327 function Comes_From_Limited_Private_Type_Declaration
4330 -- Check that the type is declared by a limited type declaration,
4331 -- or else is derived from a Remote_Type ancestor through private
4334 -------------------------------------------------
4335 -- Comes_From_Limited_Private_Type_Declaration --
4336 -------------------------------------------------
4338 function Comes_From_Limited_Private_Type_Declaration
(E
: in Entity_Id
)
4341 N
: constant Node_Id
:= Declaration_Node
(E
);
4343 if Nkind
(N
) = N_Private_Type_Declaration
4344 and then Limited_Present
(N
)
4349 if Nkind
(N
) = N_Private_Extension_Declaration
then
4351 Comes_From_Limited_Private_Type_Declaration
(Etype
(E
))
4353 (Is_Remote_Types
(Etype
(E
))
4354 and then Is_Limited_Record
(Etype
(E
))
4355 and then Has_Private_Declaration
(Etype
(E
)));
4359 end Comes_From_Limited_Private_Type_Declaration
;
4361 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
4364 if not (Is_Remote_Call_Interface
(E
)
4365 or else Is_Remote_Types
(E
))
4366 or else Ekind
(E
) /= E_General_Access_Type
4371 D
:= Designated_Type
(E
);
4373 if Ekind
(D
) /= E_Class_Wide_Type
then
4377 return Comes_From_Limited_Private_Type_Declaration
4378 (Defining_Identifier
(Parent
(D
)));
4379 end Is_Remote_Access_To_Class_Wide_Type
;
4381 -----------------------------------------
4382 -- Is_Remote_Access_To_Subprogram_Type --
4383 -----------------------------------------
4385 function Is_Remote_Access_To_Subprogram_Type
4386 (E
: Entity_Id
) return Boolean
4389 return (Ekind
(E
) = E_Access_Subprogram_Type
4390 or else (Ekind
(E
) = E_Record_Type
4391 and then Present
(Corresponding_Remote_Type
(E
))))
4392 and then (Is_Remote_Call_Interface
(E
)
4393 or else Is_Remote_Types
(E
));
4394 end Is_Remote_Access_To_Subprogram_Type
;
4396 --------------------
4397 -- Is_Remote_Call --
4398 --------------------
4400 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
4402 if Nkind
(N
) /= N_Procedure_Call_Statement
4403 and then Nkind
(N
) /= N_Function_Call
4405 -- An entry call cannot be remote
4409 elsif Nkind
(Name
(N
)) in N_Has_Entity
4410 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
4412 -- A subprogram declared in the spec of a RCI package is remote
4416 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
4417 and then Is_Remote_Access_To_Subprogram_Type
4418 (Etype
(Prefix
(Name
(N
))))
4420 -- The dereference of a RAS is a remote call
4424 elsif Present
(Controlling_Argument
(N
))
4425 and then Is_Remote_Access_To_Class_Wide_Type
4426 (Etype
(Controlling_Argument
(N
)))
4428 -- Any primitive operation call with a controlling argument of
4429 -- a RACW type is a remote call.
4434 -- All other calls are local calls
4439 ----------------------
4440 -- Is_Selector_Name --
4441 ----------------------
4443 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
4446 if not Is_List_Member
(N
) then
4448 P
: constant Node_Id
:= Parent
(N
);
4449 K
: constant Node_Kind
:= Nkind
(P
);
4453 (K
= N_Expanded_Name
or else
4454 K
= N_Generic_Association
or else
4455 K
= N_Parameter_Association
or else
4456 K
= N_Selected_Component
)
4457 and then Selector_Name
(P
) = N
;
4462 L
: constant List_Id
:= List_Containing
(N
);
4463 P
: constant Node_Id
:= Parent
(L
);
4466 return (Nkind
(P
) = N_Discriminant_Association
4467 and then Selector_Names
(P
) = L
)
4469 (Nkind
(P
) = N_Component_Association
4470 and then Choices
(P
) = L
);
4473 end Is_Selector_Name
;
4479 function Is_Statement
(N
: Node_Id
) return Boolean is
4482 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
4483 or else Nkind
(N
) = N_Procedure_Call_Statement
;
4490 function Is_Transfer
(N
: Node_Id
) return Boolean is
4491 Kind
: constant Node_Kind
:= Nkind
(N
);
4494 if Kind
= N_Return_Statement
4496 Kind
= N_Goto_Statement
4498 Kind
= N_Raise_Statement
4500 Kind
= N_Requeue_Statement
4504 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
4505 and then No
(Condition
(N
))
4509 elsif Kind
= N_Procedure_Call_Statement
4510 and then Is_Entity_Name
(Name
(N
))
4511 and then Present
(Entity
(Name
(N
)))
4512 and then No_Return
(Entity
(Name
(N
)))
4516 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
4528 function Is_True
(U
: Uint
) return Boolean is
4537 function Is_Variable
(N
: Node_Id
) return Boolean is
4539 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
4540 -- We do the test on the original node, since this is basically a
4541 -- test of syntactic categories, so it must not be disturbed by
4542 -- whatever rewriting might have occurred. For example, an aggregate,
4543 -- which is certainly NOT a variable, could be turned into a variable
4546 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
4547 -- Within a protected function, the private components of the
4548 -- enclosing protected type are constants. A function nested within
4549 -- a (protected) procedure is not itself protected.
4551 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
4552 -- Prefixes can involve implicit dereferences, in which case we
4553 -- must test for the case of a reference of a constant access
4554 -- type, which can never be a variable.
4556 ---------------------------
4557 -- In_Protected_Function --
4558 ---------------------------
4560 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
4561 Prot
: constant Entity_Id
:= Scope
(E
);
4565 if not Is_Protected_Type
(Prot
) then
4570 while Present
(S
) and then S
/= Prot
loop
4572 if Ekind
(S
) = E_Function
4573 and then Scope
(S
) = Prot
4583 end In_Protected_Function
;
4585 ------------------------
4586 -- Is_Variable_Prefix --
4587 ------------------------
4589 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
4591 if Is_Access_Type
(Etype
(P
)) then
4592 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
4594 -- For the case of an indexed component whose prefix has a packed
4595 -- array type, the prefix has been rewritten into a type conversion.
4596 -- Determine variable-ness from the converted expression.
4598 elsif Nkind
(P
) = N_Type_Conversion
4599 and then not Comes_From_Source
(P
)
4600 and then Is_Array_Type
(Etype
(P
))
4601 and then Is_Packed
(Etype
(P
))
4603 return Is_Variable
(Expression
(P
));
4606 return Is_Variable
(P
);
4608 end Is_Variable_Prefix
;
4610 -- Start of processing for Is_Variable
4613 -- Definitely OK if Assignment_OK is set. Since this is something that
4614 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
4616 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
4619 -- Normally we go to the original node, but there is one exception
4620 -- where we use the rewritten node, namely when it is an explicit
4621 -- dereference. The generated code may rewrite a prefix which is an
4622 -- access type with an explicit dereference. The dereference is a
4623 -- variable, even though the original node may not be (since it could
4624 -- be a constant of the access type).
4626 elsif Nkind
(N
) = N_Explicit_Dereference
4627 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
4628 and then Is_Access_Type
(Etype
(Orig_Node
))
4630 return Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
4632 -- All remaining checks use the original node
4634 elsif Is_Entity_Name
(Orig_Node
) then
4636 E
: constant Entity_Id
:= Entity
(Orig_Node
);
4637 K
: constant Entity_Kind
:= Ekind
(E
);
4640 return (K
= E_Variable
4641 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
4642 or else (K
= E_Component
4643 and then not In_Protected_Function
(E
))
4644 or else K
= E_Out_Parameter
4645 or else K
= E_In_Out_Parameter
4646 or else K
= E_Generic_In_Out_Parameter
4648 -- Current instance of type:
4650 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
4651 or else (Is_Incomplete_Or_Private_Type
(E
)
4652 and then In_Open_Scopes
(Full_View
(E
)));
4656 case Nkind
(Orig_Node
) is
4657 when N_Indexed_Component | N_Slice
=>
4658 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
4660 when N_Selected_Component
=>
4661 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
4662 and then Is_Variable
(Selector_Name
(Orig_Node
));
4664 -- For an explicit dereference, the type of the prefix cannot
4665 -- be an access to constant or an access to subprogram.
4667 when N_Explicit_Dereference
=>
4669 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
4672 return Is_Access_Type
(Typ
)
4673 and then not Is_Access_Constant
(Root_Type
(Typ
))
4674 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
4677 -- The type conversion is the case where we do not deal with the
4678 -- context dependent special case of an actual parameter. Thus
4679 -- the type conversion is only considered a variable for the
4680 -- purposes of this routine if the target type is tagged. However,
4681 -- a type conversion is considered to be a variable if it does not
4682 -- come from source (this deals for example with the conversions
4683 -- of expressions to their actual subtypes).
4685 when N_Type_Conversion
=>
4686 return Is_Variable
(Expression
(Orig_Node
))
4688 (not Comes_From_Source
(Orig_Node
)
4690 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
4692 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
4694 -- GNAT allows an unchecked type conversion as a variable. This
4695 -- only affects the generation of internal expanded code, since
4696 -- calls to instantiations of Unchecked_Conversion are never
4697 -- considered variables (since they are function calls).
4698 -- This is also true for expression actions.
4700 when N_Unchecked_Type_Conversion
=>
4701 return Is_Variable
(Expression
(Orig_Node
));
4709 ------------------------
4710 -- Is_Volatile_Object --
4711 ------------------------
4713 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
4715 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
4716 -- Determines if given object has volatile components
4718 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
4719 -- If prefix is an implicit dereference, examine designated type
4721 ------------------------
4722 -- Is_Volatile_Prefix --
4723 ------------------------
4725 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
4726 Typ
: constant Entity_Id
:= Etype
(N
);
4729 if Is_Access_Type
(Typ
) then
4731 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
4734 return Is_Volatile
(Dtyp
)
4735 or else Has_Volatile_Components
(Dtyp
);
4739 return Object_Has_Volatile_Components
(N
);
4741 end Is_Volatile_Prefix
;
4743 ------------------------------------
4744 -- Object_Has_Volatile_Components --
4745 ------------------------------------
4747 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
4748 Typ
: constant Entity_Id
:= Etype
(N
);
4751 if Is_Volatile
(Typ
)
4752 or else Has_Volatile_Components
(Typ
)
4756 elsif Is_Entity_Name
(N
)
4757 and then (Has_Volatile_Components
(Entity
(N
))
4758 or else Is_Volatile
(Entity
(N
)))
4762 elsif Nkind
(N
) = N_Indexed_Component
4763 or else Nkind
(N
) = N_Selected_Component
4765 return Is_Volatile_Prefix
(Prefix
(N
));
4770 end Object_Has_Volatile_Components
;
4772 -- Start of processing for Is_Volatile_Object
4775 if Is_Volatile
(Etype
(N
))
4776 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
4780 elsif Nkind
(N
) = N_Indexed_Component
4781 or else Nkind
(N
) = N_Selected_Component
4783 return Is_Volatile_Prefix
(Prefix
(N
));
4788 end Is_Volatile_Object
;
4790 -------------------------
4791 -- Kill_Current_Values --
4792 -------------------------
4794 procedure Kill_Current_Values
is
4797 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
4798 -- Clear current value for entity E and all entities chained to E
4800 ------------------------------------------
4801 -- Kill_Current_Values_For_Entity_Chain --
4802 ------------------------------------------
4804 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
4809 while Present
(Ent
) loop
4810 if Is_Object
(Ent
) then
4811 Set_Current_Value
(Ent
, Empty
);
4813 if not Can_Never_Be_Null
(Ent
) then
4814 Set_Is_Known_Non_Null
(Ent
, False);
4820 end Kill_Current_Values_For_Entity_Chain
;
4822 -- Start of processing for Kill_Current_Values
4825 -- Kill all saved checks, a special case of killing saved values
4829 -- Loop through relevant scopes, which includes the current scope and
4830 -- any parent scopes if the current scope is a block or a package.
4835 -- Clear current values of all entities in current scope
4837 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
4839 -- If scope is a package, also clear current values of all
4840 -- private entities in the scope.
4842 if Ekind
(S
) = E_Package
4844 Ekind
(S
) = E_Generic_Package
4846 Is_Concurrent_Type
(S
)
4848 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
4851 -- If this is a block or nested package, deal with parent
4853 if Ekind
(S
) = E_Block
4854 or else (Ekind
(S
) = E_Package
4855 and then not Is_Library_Level_Entity
(S
))
4861 end loop Scope_Loop
;
4862 end Kill_Current_Values
;
4864 --------------------------
4865 -- Kill_Size_Check_Code --
4866 --------------------------
4868 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
4870 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
4871 and then Present
(Size_Check_Code
(E
))
4873 Remove
(Size_Check_Code
(E
));
4874 Set_Size_Check_Code
(E
, Empty
);
4876 end Kill_Size_Check_Code
;
4878 -------------------------
4879 -- New_External_Entity --
4880 -------------------------
4882 function New_External_Entity
4883 (Kind
: Entity_Kind
;
4884 Scope_Id
: Entity_Id
;
4885 Sloc_Value
: Source_Ptr
;
4886 Related_Id
: Entity_Id
;
4888 Suffix_Index
: Nat
:= 0;
4889 Prefix
: Character := ' ') return Entity_Id
4891 N
: constant Entity_Id
:=
4892 Make_Defining_Identifier
(Sloc_Value
,
4894 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
4897 Set_Ekind
(N
, Kind
);
4898 Set_Is_Internal
(N
, True);
4899 Append_Entity
(N
, Scope_Id
);
4900 Set_Public_Status
(N
);
4902 if Kind
in Type_Kind
then
4903 Init_Size_Align
(N
);
4907 end New_External_Entity
;
4909 -------------------------
4910 -- New_Internal_Entity --
4911 -------------------------
4913 function New_Internal_Entity
4914 (Kind
: Entity_Kind
;
4915 Scope_Id
: Entity_Id
;
4916 Sloc_Value
: Source_Ptr
;
4917 Id_Char
: Character) return Entity_Id
4919 N
: constant Entity_Id
:=
4920 Make_Defining_Identifier
(Sloc_Value
, New_Internal_Name
(Id_Char
));
4923 Set_Ekind
(N
, Kind
);
4924 Set_Is_Internal
(N
, True);
4925 Append_Entity
(N
, Scope_Id
);
4927 if Kind
in Type_Kind
then
4928 Init_Size_Align
(N
);
4932 end New_Internal_Entity
;
4938 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
4942 -- If we are pointing at a positional parameter, it is a member of
4943 -- a node list (the list of parameters), and the next parameter
4944 -- is the next node on the list, unless we hit a parameter
4945 -- association, in which case we shift to using the chain whose
4946 -- head is the First_Named_Actual in the parent, and then is
4947 -- threaded using the Next_Named_Actual of the Parameter_Association.
4948 -- All this fiddling is because the original node list is in the
4949 -- textual call order, and what we need is the declaration order.
4951 if Is_List_Member
(Actual_Id
) then
4952 N
:= Next
(Actual_Id
);
4954 if Nkind
(N
) = N_Parameter_Association
then
4955 return First_Named_Actual
(Parent
(Actual_Id
));
4961 return Next_Named_Actual
(Parent
(Actual_Id
));
4965 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
4967 Actual_Id
:= Next_Actual
(Actual_Id
);
4970 -----------------------
4971 -- Normalize_Actuals --
4972 -----------------------
4974 -- Chain actuals according to formals of subprogram. If there are
4975 -- no named associations, the chain is simply the list of Parameter
4976 -- Associations, since the order is the same as the declaration order.
4977 -- If there are named associations, then the First_Named_Actual field
4978 -- in the N_Procedure_Call_Statement node or N_Function_Call node
4979 -- points to the Parameter_Association node for the parameter that
4980 -- comes first in declaration order. The remaining named parameters
4981 -- are then chained in declaration order using Next_Named_Actual.
4983 -- This routine also verifies that the number of actuals is compatible
4984 -- with the number and default values of formals, but performs no type
4985 -- checking (type checking is done by the caller).
4987 -- If the matching succeeds, Success is set to True, and the caller
4988 -- proceeds with type-checking. If the match is unsuccessful, then
4989 -- Success is set to False, and the caller attempts a different
4990 -- interpretation, if there is one.
4992 -- If the flag Report is on, the call is not overloaded, and a failure
4993 -- to match can be reported here, rather than in the caller.
4995 procedure Normalize_Actuals
4999 Success
: out Boolean)
5001 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
5002 Actual
: Node_Id
:= Empty
;
5004 Last
: Node_Id
:= Empty
;
5005 First_Named
: Node_Id
:= Empty
;
5008 Formals_To_Match
: Integer := 0;
5009 Actuals_To_Match
: Integer := 0;
5011 procedure Chain
(A
: Node_Id
);
5012 -- Add named actual at the proper place in the list, using the
5013 -- Next_Named_Actual link.
5015 function Reporting
return Boolean;
5016 -- Determines if an error is to be reported. To report an error, we
5017 -- need Report to be True, and also we do not report errors caused
5018 -- by calls to init procs that occur within other init procs. Such
5019 -- errors must always be cascaded errors, since if all the types are
5020 -- declared correctly, the compiler will certainly build decent calls!
5026 procedure Chain
(A
: Node_Id
) is
5030 -- Call node points to first actual in list
5032 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
5035 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
5039 Set_Next_Named_Actual
(Last
, Empty
);
5046 function Reporting
return Boolean is
5051 elsif not Within_Init_Proc
then
5054 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
5062 -- Start of processing for Normalize_Actuals
5065 if Is_Access_Type
(S
) then
5067 -- The name in the call is a function call that returns an access
5068 -- to subprogram. The designated type has the list of formals.
5070 Formal
:= First_Formal
(Designated_Type
(S
));
5072 Formal
:= First_Formal
(S
);
5075 while Present
(Formal
) loop
5076 Formals_To_Match
:= Formals_To_Match
+ 1;
5077 Next_Formal
(Formal
);
5080 -- Find if there is a named association, and verify that no positional
5081 -- associations appear after named ones.
5083 if Present
(Actuals
) then
5084 Actual
:= First
(Actuals
);
5087 while Present
(Actual
)
5088 and then Nkind
(Actual
) /= N_Parameter_Association
5090 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5094 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
5096 -- Most common case: positional notation, no defaults
5101 elsif Actuals_To_Match
> Formals_To_Match
then
5103 -- Too many actuals: will not work
5106 if Is_Entity_Name
(Name
(N
)) then
5107 Error_Msg_N
("too many arguments in call to&", Name
(N
));
5109 Error_Msg_N
("too many arguments in call", N
);
5117 First_Named
:= Actual
;
5119 while Present
(Actual
) loop
5120 if Nkind
(Actual
) /= N_Parameter_Association
then
5122 ("positional parameters not allowed after named ones", Actual
);
5127 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5133 if Present
(Actuals
) then
5134 Actual
:= First
(Actuals
);
5137 Formal
:= First_Formal
(S
);
5138 while Present
(Formal
) loop
5140 -- Match the formals in order. If the corresponding actual
5141 -- is positional, nothing to do. Else scan the list of named
5142 -- actuals to find the one with the right name.
5145 and then Nkind
(Actual
) /= N_Parameter_Association
5148 Actuals_To_Match
:= Actuals_To_Match
- 1;
5149 Formals_To_Match
:= Formals_To_Match
- 1;
5152 -- For named parameters, search the list of actuals to find
5153 -- one that matches the next formal name.
5155 Actual
:= First_Named
;
5158 while Present
(Actual
) loop
5159 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
5162 Actuals_To_Match
:= Actuals_To_Match
- 1;
5163 Formals_To_Match
:= Formals_To_Match
- 1;
5171 if Ekind
(Formal
) /= E_In_Parameter
5172 or else No
(Default_Value
(Formal
))
5175 if (Comes_From_Source
(S
)
5176 or else Sloc
(S
) = Standard_Location
)
5177 and then Is_Overloadable
(S
)
5181 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
5183 (Nkind
(Parent
(N
)) = N_Function_Call
5185 Nkind
(Parent
(N
)) = N_Parameter_Association
))
5186 and then Ekind
(S
) /= E_Function
5188 Set_Etype
(N
, Etype
(S
));
5190 Error_Msg_Name_1
:= Chars
(S
);
5191 Error_Msg_Sloc
:= Sloc
(S
);
5193 ("missing argument for parameter & " &
5194 "in call to % declared #", N
, Formal
);
5197 elsif Is_Overloadable
(S
) then
5198 Error_Msg_Name_1
:= Chars
(S
);
5200 -- Point to type derivation that generated the
5203 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
5206 ("missing argument for parameter & " &
5207 "in call to % (inherited) #", N
, Formal
);
5211 ("missing argument for parameter &", N
, Formal
);
5219 Formals_To_Match
:= Formals_To_Match
- 1;
5224 Next_Formal
(Formal
);
5227 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
5234 -- Find some superfluous named actual that did not get
5235 -- attached to the list of associations.
5237 Actual
:= First
(Actuals
);
5239 while Present
(Actual
) loop
5240 if Nkind
(Actual
) = N_Parameter_Association
5241 and then Actual
/= Last
5242 and then No
(Next_Named_Actual
(Actual
))
5244 Error_Msg_N
("unmatched actual & in call",
5245 Selector_Name
(Actual
));
5256 end Normalize_Actuals
;
5258 --------------------------------
5259 -- Note_Possible_Modification --
5260 --------------------------------
5262 procedure Note_Possible_Modification
(N
: Node_Id
) is
5263 Modification_Comes_From_Source
: constant Boolean :=
5264 Comes_From_Source
(Parent
(N
));
5270 -- Loop to find referenced entity, if there is one
5277 if Is_Entity_Name
(Exp
) then
5278 Ent
:= Entity
(Exp
);
5280 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
5282 P
: constant Node_Id
:= Prefix
(Exp
);
5285 if Nkind
(P
) = N_Selected_Component
5287 Entry_Formal
(Entity
(Selector_Name
(P
))))
5289 -- Case of a reference to an entry formal
5291 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
5293 elsif Nkind
(P
) = N_Identifier
5294 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
5295 and then Present
(Expression
(Parent
(Entity
(P
))))
5296 and then Nkind
(Expression
(Parent
(Entity
(P
))))
5299 -- Case of a reference to a value on which
5300 -- side effects have been removed.
5302 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
5310 elsif Nkind
(Exp
) = N_Type_Conversion
5311 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
5313 Exp
:= Expression
(Exp
);
5315 elsif Nkind
(Exp
) = N_Slice
5316 or else Nkind
(Exp
) = N_Indexed_Component
5317 or else Nkind
(Exp
) = N_Selected_Component
5319 Exp
:= Prefix
(Exp
);
5326 -- Now look for entity being referenced
5328 if Present
(Ent
) then
5330 if Is_Object
(Ent
) then
5331 if Comes_From_Source
(Exp
)
5332 or else Modification_Comes_From_Source
5334 Set_Never_Set_In_Source
(Ent
, False);
5337 Set_Is_True_Constant
(Ent
, False);
5338 Set_Current_Value
(Ent
, Empty
);
5340 if not Can_Never_Be_Null
(Ent
) then
5341 Set_Is_Known_Non_Null
(Ent
, False);
5344 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
5345 and then Present
(Renamed_Object
(Ent
))
5347 Exp
:= Renamed_Object
(Ent
);
5351 -- Generate a reference only if the assignment comes from
5352 -- source. This excludes, for example, calls to a dispatching
5353 -- assignment operation when the left-hand side is tagged.
5355 if Modification_Comes_From_Source
then
5356 Generate_Reference
(Ent
, Exp
, 'm');
5364 end Note_Possible_Modification
;
5366 -------------------------
5367 -- Object_Access_Level --
5368 -------------------------
5370 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
5373 -- Returns the static accessibility level of the view denoted
5374 -- by Obj. Note that the value returned is the result of a
5375 -- call to Scope_Depth. Only scope depths associated with
5376 -- dynamic scopes can actually be returned. Since only
5377 -- relative levels matter for accessibility checking, the fact
5378 -- that the distance between successive levels of accessibility
5379 -- is not always one is immaterial (invariant: if level(E2) is
5380 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
5383 if Is_Entity_Name
(Obj
) then
5386 -- If E is a type then it denotes a current instance.
5387 -- For this case we add one to the normal accessibility
5388 -- level of the type to ensure that current instances
5389 -- are treated as always being deeper than than the level
5390 -- of any visible named access type (see 3.10.2(21)).
5393 return Type_Access_Level
(E
) + 1;
5395 elsif Present
(Renamed_Object
(E
)) then
5396 return Object_Access_Level
(Renamed_Object
(E
));
5398 -- Similarly, if E is a component of the current instance of a
5399 -- protected type, any instance of it is assumed to be at a deeper
5400 -- level than the type. For a protected object (whose type is an
5401 -- anonymous protected type) its components are at the same level
5402 -- as the type itself.
5404 elsif not Is_Overloadable
(E
)
5405 and then Ekind
(Scope
(E
)) = E_Protected_Type
5406 and then Comes_From_Source
(Scope
(E
))
5408 return Type_Access_Level
(Scope
(E
)) + 1;
5411 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
5414 elsif Nkind
(Obj
) = N_Selected_Component
then
5415 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5416 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5418 return Object_Access_Level
(Prefix
(Obj
));
5421 elsif Nkind
(Obj
) = N_Indexed_Component
then
5422 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5423 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5425 return Object_Access_Level
(Prefix
(Obj
));
5428 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
5430 -- If the prefix is a selected access discriminant then
5431 -- we make a recursive call on the prefix, which will
5432 -- in turn check the level of the prefix object of
5433 -- the selected discriminant.
5435 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
5436 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
5438 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
5440 return Object_Access_Level
(Prefix
(Obj
));
5442 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5445 elsif Nkind
(Obj
) = N_Type_Conversion
5446 or else Nkind
(Obj
) = N_Unchecked_Type_Conversion
5448 return Object_Access_Level
(Expression
(Obj
));
5450 -- Function results are objects, so we get either the access level
5451 -- of the function or, in the case of an indirect call, the level of
5452 -- of the access-to-subprogram type.
5454 elsif Nkind
(Obj
) = N_Function_Call
then
5455 if Is_Entity_Name
(Name
(Obj
)) then
5456 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
5458 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
5461 -- For convenience we handle qualified expressions, even though
5462 -- they aren't technically object names.
5464 elsif Nkind
(Obj
) = N_Qualified_Expression
then
5465 return Object_Access_Level
(Expression
(Obj
));
5467 -- Otherwise return the scope level of Standard.
5468 -- (If there are cases that fall through
5469 -- to this point they will be treated as
5470 -- having global accessibility for now. ???)
5473 return Scope_Depth
(Standard_Standard
);
5475 end Object_Access_Level
;
5477 -----------------------
5478 -- Private_Component --
5479 -----------------------
5481 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
5482 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
5484 function Trace_Components
5486 Check
: Boolean) return Entity_Id
;
5487 -- Recursive function that does the work, and checks against circular
5488 -- definition for each subcomponent type.
5490 ----------------------
5491 -- Trace_Components --
5492 ----------------------
5494 function Trace_Components
5496 Check
: Boolean) return Entity_Id
5498 Btype
: constant Entity_Id
:= Base_Type
(T
);
5499 Component
: Entity_Id
;
5501 Candidate
: Entity_Id
:= Empty
;
5504 if Check
and then Btype
= Ancestor
then
5505 Error_Msg_N
("circular type definition", Type_Id
);
5509 if Is_Private_Type
(Btype
)
5510 and then not Is_Generic_Type
(Btype
)
5512 if Present
(Full_View
(Btype
))
5513 and then Is_Record_Type
(Full_View
(Btype
))
5514 and then not Is_Frozen
(Btype
)
5516 -- To indicate that the ancestor depends on a private type,
5517 -- the current Btype is sufficient. However, to check for
5518 -- circular definition we must recurse on the full view.
5520 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
5522 if Candidate
= Any_Type
then
5532 elsif Is_Array_Type
(Btype
) then
5533 return Trace_Components
(Component_Type
(Btype
), True);
5535 elsif Is_Record_Type
(Btype
) then
5536 Component
:= First_Entity
(Btype
);
5537 while Present
(Component
) loop
5539 -- Skip anonymous types generated by constrained components
5541 if not Is_Type
(Component
) then
5542 P
:= Trace_Components
(Etype
(Component
), True);
5545 if P
= Any_Type
then
5553 Next_Entity
(Component
);
5561 end Trace_Components
;
5563 -- Start of processing for Private_Component
5566 return Trace_Components
(Type_Id
, False);
5567 end Private_Component
;
5569 -----------------------
5570 -- Process_End_Label --
5571 -----------------------
5573 procedure Process_End_Label
5581 Label_Ref
: Boolean;
5582 -- Set True if reference to end label itself is required
5585 -- Gets set to the operator symbol or identifier that references
5586 -- the entity Ent. For the child unit case, this is the identifier
5587 -- from the designator. For other cases, this is simply Endl.
5589 procedure Generate_Parent_Ref
(N
: Node_Id
);
5590 -- N is an identifier node that appears as a parent unit reference
5591 -- in the case where Ent is a child unit. This procedure generates
5592 -- an appropriate cross-reference entry.
5594 -------------------------
5595 -- Generate_Parent_Ref --
5596 -------------------------
5598 procedure Generate_Parent_Ref
(N
: Node_Id
) is
5599 Parent_Ent
: Entity_Id
;
5602 -- Search up scope stack. The reason we do this is that normal
5603 -- visibility analysis would not work for two reasons. First in
5604 -- some subunit cases, the entry for the parent unit may not be
5605 -- visible, and in any case there can be a local entity that
5606 -- hides the scope entity.
5608 Parent_Ent
:= Current_Scope
;
5609 while Present
(Parent_Ent
) loop
5610 if Chars
(Parent_Ent
) = Chars
(N
) then
5612 -- Generate the reference. We do NOT consider this as a
5613 -- reference for unreferenced symbol purposes, but we do
5614 -- force a cross-reference even if the end line does not
5615 -- come from source (the caller already generated the
5616 -- appropriate Typ for this situation).
5619 (Parent_Ent
, N
, 'r', Set_Ref
=> False, Force
=> True);
5620 Style
.Check_Identifier
(N
, Parent_Ent
);
5624 Parent_Ent
:= Scope
(Parent_Ent
);
5627 -- Fall through means entity was not found -- that's odd, but
5628 -- the appropriate thing is simply to ignore and not generate
5629 -- any cross-reference for this entry.
5632 end Generate_Parent_Ref
;
5634 -- Start of processing for Process_End_Label
5637 -- If no node, ignore. This happens in some error situations,
5638 -- and also for some internally generated structures where no
5639 -- end label references are required in any case.
5645 -- Nothing to do if no End_Label, happens for internally generated
5646 -- constructs where we don't want an end label reference anyway.
5647 -- Also nothing to do if Endl is a string literal, which means
5648 -- there was some prior error (bad operator symbol)
5650 Endl
:= End_Label
(N
);
5652 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
5656 -- Reference node is not in extended main source unit
5658 if not In_Extended_Main_Source_Unit
(N
) then
5660 -- Generally we do not collect references except for the
5661 -- extended main source unit. The one exception is the 'e'
5662 -- entry for a package spec, where it is useful for a client
5663 -- to have the ending information to define scopes.
5671 -- For this case, we can ignore any parent references,
5672 -- but we need the package name itself for the 'e' entry.
5674 if Nkind
(Endl
) = N_Designator
then
5675 Endl
:= Identifier
(Endl
);
5679 -- Reference is in extended main source unit
5684 -- For designator, generate references for the parent entries
5686 if Nkind
(Endl
) = N_Designator
then
5688 -- Generate references for the prefix if the END line comes
5689 -- from source (otherwise we do not need these references)
5691 if Comes_From_Source
(Endl
) then
5693 while Nkind
(Nam
) = N_Selected_Component
loop
5694 Generate_Parent_Ref
(Selector_Name
(Nam
));
5695 Nam
:= Prefix
(Nam
);
5698 Generate_Parent_Ref
(Nam
);
5701 Endl
:= Identifier
(Endl
);
5705 -- If the end label is not for the given entity, then either we have
5706 -- some previous error, or this is a generic instantiation for which
5707 -- we do not need to make a cross-reference in this case anyway. In
5708 -- either case we simply ignore the call.
5710 if Chars
(Ent
) /= Chars
(Endl
) then
5714 -- If label was really there, then generate a normal reference
5715 -- and then adjust the location in the end label to point past
5716 -- the name (which should almost always be the semicolon).
5720 if Comes_From_Source
(Endl
) then
5722 -- If a label reference is required, then do the style check
5723 -- and generate an l-type cross-reference entry for the label
5727 Style
.Check_Identifier
(Endl
, Ent
);
5729 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
5732 -- Set the location to point past the label (normally this will
5733 -- mean the semicolon immediately following the label). This is
5734 -- done for the sake of the 'e' or 't' entry generated below.
5736 Get_Decoded_Name_String
(Chars
(Endl
));
5737 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
5740 -- Now generate the e/t reference
5742 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
5744 -- Restore Sloc, in case modified above, since we have an identifier
5745 -- and the normal Sloc should be left set in the tree.
5747 Set_Sloc
(Endl
, Loc
);
5748 end Process_End_Label
;
5754 -- We do the conversion to get the value of the real string by using
5755 -- the scanner, see Sinput for details on use of the internal source
5756 -- buffer for scanning internal strings.
5758 function Real_Convert
(S
: String) return Node_Id
is
5759 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
5763 Source
:= Internal_Source_Ptr
;
5766 for J
in S
'Range loop
5767 Source
(Source_Ptr
(J
)) := S
(J
);
5770 Source
(S
'Length + 1) := EOF
;
5772 if Source
(Scan_Ptr
) = '-' then
5774 Scan_Ptr
:= Scan_Ptr
+ 1;
5782 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
5789 ---------------------
5790 -- Rep_To_Pos_Flag --
5791 ---------------------
5793 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
5795 return New_Occurrence_Of
5796 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
5797 end Rep_To_Pos_Flag
;
5799 --------------------
5800 -- Require_Entity --
5801 --------------------
5803 procedure Require_Entity
(N
: Node_Id
) is
5805 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
5806 if Total_Errors_Detected
/= 0 then
5807 Set_Entity
(N
, Any_Id
);
5809 raise Program_Error
;
5814 ------------------------------
5815 -- Requires_Transient_Scope --
5816 ------------------------------
5818 -- A transient scope is required when variable-sized temporaries are
5819 -- allocated in the primary or secondary stack, or when finalization
5820 -- actions must be generated before the next instruction.
5822 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
5823 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
5825 -- Start of processing for Requires_Transient_Scope
5828 -- This is a private type which is not completed yet. This can only
5829 -- happen in a default expression (of a formal parameter or of a
5830 -- record component). Do not expand transient scope in this case
5835 -- Do not expand transient scope for non-existent procedure return
5837 elsif Typ
= Standard_Void_Type
then
5840 -- Elementary types do not require a transient scope
5842 elsif Is_Elementary_Type
(Typ
) then
5845 -- Generally, indefinite subtypes require a transient scope, since the
5846 -- back end cannot generate temporaries, since this is not a valid type
5847 -- for declaring an object. It might be possible to relax this in the
5848 -- future, e.g. by declaring the maximum possible space for the type.
5850 elsif Is_Indefinite_Subtype
(Typ
) then
5853 -- Functions returning tagged types may dispatch on result so their
5854 -- returned value is allocated on the secondary stack. Controlled
5855 -- type temporaries need finalization.
5857 elsif Is_Tagged_Type
(Typ
)
5858 or else Has_Controlled_Component
(Typ
)
5864 elsif Is_Record_Type
(Typ
) then
5866 -- In GCC 2, discriminated records always require a transient
5867 -- scope because the back end otherwise tries to allocate a
5868 -- variable length temporary for the particular variant.
5870 if Opt
.GCC_Version
= 2
5871 and then Has_Discriminants
(Typ
)
5875 -- For GCC 3, or for a non-discriminated record in GCC 2, we are
5876 -- OK if none of the component types requires a transient scope.
5877 -- Note that we already know that this is a definite type (i.e.
5878 -- has discriminant defaults if it is a discriminated record).
5884 Comp
:= First_Entity
(Typ
);
5885 while Present
(Comp
) loop
5886 if Requires_Transient_Scope
(Etype
(Comp
)) then
5897 -- String literal types never require transient scope
5899 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
5902 -- Array type. Note that we already know that this is a constrained
5903 -- array, since unconstrained arrays will fail the indefinite test.
5905 elsif Is_Array_Type
(Typ
) then
5907 -- If component type requires a transient scope, the array does too
5909 if Requires_Transient_Scope
(Component_Type
(Typ
)) then
5912 -- Otherwise, we only need a transient scope if the size is not
5913 -- known at compile time.
5916 return not Size_Known_At_Compile_Time
(Typ
);
5919 -- All other cases do not require a transient scope
5924 end Requires_Transient_Scope
;
5926 --------------------------
5927 -- Reset_Analyzed_Flags --
5928 --------------------------
5930 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
5932 function Clear_Analyzed
5933 (N
: Node_Id
) return Traverse_Result
;
5934 -- Function used to reset Analyzed flags in tree. Note that we do
5935 -- not reset Analyzed flags in entities, since there is no need to
5936 -- renalalyze entities, and indeed, it is wrong to do so, since it
5937 -- can result in generating auxiliary stuff more than once.
5939 --------------------
5940 -- Clear_Analyzed --
5941 --------------------
5943 function Clear_Analyzed
5944 (N
: Node_Id
) return Traverse_Result
5947 if not Has_Extension
(N
) then
5948 Set_Analyzed
(N
, False);
5954 function Reset_Analyzed
is
5955 new Traverse_Func
(Clear_Analyzed
);
5957 Discard
: Traverse_Result
;
5958 pragma Warnings
(Off
, Discard
);
5960 -- Start of processing for Reset_Analyzed_Flags
5963 Discard
:= Reset_Analyzed
(N
);
5964 end Reset_Analyzed_Flags
;
5966 ---------------------------
5967 -- Safe_To_Capture_Value --
5968 ---------------------------
5970 function Safe_To_Capture_Value
5972 Ent
: Entity_Id
) return Boolean
5975 -- The only entities for which we track constant values are variables,
5976 -- out parameters and in out parameters, so check if we have this case.
5978 if Ekind
(Ent
) /= E_Variable
5980 Ekind
(Ent
) /= E_Out_Parameter
5982 Ekind
(Ent
) /= E_In_Out_Parameter
5987 -- Skip volatile and aliased variables, since funny things might
5988 -- be going on in these cases which we cannot necessarily track.
5990 if Treat_As_Volatile
(Ent
) or else Is_Aliased
(Ent
) then
5994 -- OK, all above conditions are met. We also require that the scope
5995 -- of the reference be the same as the scope of the entity, not
5996 -- counting packages and blocks.
5999 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
6000 R_Scope
: Entity_Id
;
6003 R_Scope
:= Current_Scope
;
6004 while R_Scope
/= Standard_Standard
loop
6005 exit when R_Scope
= E_Scope
;
6007 if Ekind
(R_Scope
) /= E_Package
6009 Ekind
(R_Scope
) /= E_Block
6013 R_Scope
:= Scope
(R_Scope
);
6018 -- We also require that the reference does not appear in a context
6019 -- where it is not sure to be executed (i.e. a conditional context
6020 -- or an exception handler).
6027 while Present
(P
) loop
6028 if Nkind
(P
) = N_If_Statement
6030 Nkind
(P
) = N_Case_Statement
6032 Nkind
(P
) = N_Exception_Handler
6034 Nkind
(P
) = N_Selective_Accept
6036 Nkind
(P
) = N_Conditional_Entry_Call
6038 Nkind
(P
) = N_Timed_Entry_Call
6040 Nkind
(P
) = N_Asynchronous_Select
6049 -- OK, looks safe to set value
6052 end Safe_To_Capture_Value
;
6058 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
6059 K1
: constant Node_Kind
:= Nkind
(N1
);
6060 K2
: constant Node_Kind
:= Nkind
(N2
);
6063 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
6064 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
6066 return Chars
(N1
) = Chars
(N2
);
6068 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
6069 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
6071 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
6072 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
6083 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
6088 elsif not Is_Constrained
(T1
)
6089 and then not Is_Constrained
(T2
)
6090 and then Base_Type
(T1
) = Base_Type
(T2
)
6094 -- For now don't bother with case of identical constraints, to be
6095 -- fiddled with later on perhaps (this is only used for optimization
6096 -- purposes, so it is not critical to do a best possible job)
6103 ------------------------
6104 -- Scope_Is_Transient --
6105 ------------------------
6107 function Scope_Is_Transient
return Boolean is
6109 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
6110 end Scope_Is_Transient
;
6116 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6121 while Scop
/= Standard_Standard
loop
6122 Scop
:= Scope
(Scop
);
6124 if Scop
= Scope2
then
6132 --------------------------
6133 -- Scope_Within_Or_Same --
6134 --------------------------
6136 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6141 while Scop
/= Standard_Standard
loop
6142 if Scop
= Scope2
then
6145 Scop
:= Scope
(Scop
);
6150 end Scope_Within_Or_Same
;
6152 ------------------------
6153 -- Set_Current_Entity --
6154 ------------------------
6156 -- The given entity is to be set as the currently visible definition
6157 -- of its associated name (i.e. the Node_Id associated with its name).
6158 -- All we have to do is to get the name from the identifier, and
6159 -- then set the associated Node_Id to point to the given entity.
6161 procedure Set_Current_Entity
(E
: Entity_Id
) is
6163 Set_Name_Entity_Id
(Chars
(E
), E
);
6164 end Set_Current_Entity
;
6166 ---------------------------------
6167 -- Set_Entity_With_Style_Check --
6168 ---------------------------------
6170 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
6171 Val_Actual
: Entity_Id
;
6175 Set_Entity
(N
, Val
);
6178 and then not Suppress_Style_Checks
(Val
)
6179 and then not In_Instance
6181 if Nkind
(N
) = N_Identifier
then
6184 elsif Nkind
(N
) = N_Expanded_Name
then
6185 Nod
:= Selector_Name
(N
);
6193 -- A special situation arises for derived operations, where we want
6194 -- to do the check against the parent (since the Sloc of the derived
6195 -- operation points to the derived type declaration itself).
6197 while not Comes_From_Source
(Val_Actual
)
6198 and then Nkind
(Val_Actual
) in N_Entity
6199 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
6200 or else Is_Subprogram
(Val_Actual
)
6201 or else Is_Generic_Subprogram
(Val_Actual
))
6202 and then Present
(Alias
(Val_Actual
))
6204 Val_Actual
:= Alias
(Val_Actual
);
6207 -- Renaming declarations for generic actuals do not come from source,
6208 -- and have a different name from that of the entity they rename, so
6209 -- there is no style check to perform here.
6211 if Chars
(Nod
) = Chars
(Val_Actual
) then
6212 Style
.Check_Identifier
(Nod
, Val_Actual
);
6216 Set_Entity
(N
, Val
);
6217 end Set_Entity_With_Style_Check
;
6219 ------------------------
6220 -- Set_Name_Entity_Id --
6221 ------------------------
6223 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
6225 Set_Name_Table_Info
(Id
, Int
(Val
));
6226 end Set_Name_Entity_Id
;
6228 ---------------------
6229 -- Set_Next_Actual --
6230 ---------------------
6232 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
6234 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
6235 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
6237 end Set_Next_Actual
;
6239 -----------------------
6240 -- Set_Public_Status --
6241 -----------------------
6243 procedure Set_Public_Status
(Id
: Entity_Id
) is
6244 S
: constant Entity_Id
:= Current_Scope
;
6247 if S
= Standard_Standard
6248 or else (Is_Public
(S
)
6249 and then (Ekind
(S
) = E_Package
6250 or else Is_Record_Type
(S
)
6251 or else Ekind
(S
) = E_Void
))
6255 -- The bounds of an entry family declaration can generate object
6256 -- declarations that are visible to the back-end, e.g. in the
6257 -- the declaration of a composite type that contains tasks.
6260 and then Is_Concurrent_Type
(S
)
6261 and then not Has_Completion
(S
)
6262 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
6266 end Set_Public_Status
;
6268 ----------------------------
6269 -- Set_Scope_Is_Transient --
6270 ----------------------------
6272 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
6274 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
6275 end Set_Scope_Is_Transient
;
6281 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
6283 -- We copy Esize, but not RM_Size, since in general RM_Size is
6284 -- subtype specific and does not get inherited by all subtypes.
6286 Set_Esize
(T1
, Esize
(T2
));
6287 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
6289 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
6291 Is_Discrete_Or_Fixed_Point_Type
(T2
)
6293 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
6295 Set_Alignment
(T1
, Alignment
(T2
));
6298 --------------------
6299 -- Static_Integer --
6300 --------------------
6302 function Static_Integer
(N
: Node_Id
) return Uint
is
6304 Analyze_And_Resolve
(N
, Any_Integer
);
6307 or else Error_Posted
(N
)
6308 or else Etype
(N
) = Any_Type
6313 if Is_Static_Expression
(N
) then
6314 if not Raises_Constraint_Error
(N
) then
6315 return Expr_Value
(N
);
6320 elsif Etype
(N
) = Any_Type
then
6324 Flag_Non_Static_Expr
6325 ("static integer expression required here", N
);
6330 --------------------------
6331 -- Statically_Different --
6332 --------------------------
6334 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
6335 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
6336 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
6339 return Is_Entity_Name
(R1
)
6340 and then Is_Entity_Name
(R2
)
6341 and then Entity
(R1
) /= Entity
(R2
)
6342 and then not Is_Formal
(Entity
(R1
))
6343 and then not Is_Formal
(Entity
(R2
));
6344 end Statically_Different
;
6346 -----------------------------
6347 -- Subprogram_Access_Level --
6348 -----------------------------
6350 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
6352 if Present
(Alias
(Subp
)) then
6353 return Subprogram_Access_Level
(Alias
(Subp
));
6355 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
6357 end Subprogram_Access_Level
;
6363 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
6365 if Debug_Flag_W
then
6366 for J
in 0 .. Scope_Stack
.Last
loop
6371 Write_Name
(Chars
(E
));
6372 Write_Str
(" line ");
6373 Write_Int
(Int
(Get_Logical_Line_Number
(Sloc
(N
))));
6378 -----------------------
6379 -- Transfer_Entities --
6380 -----------------------
6382 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
6383 Ent
: Entity_Id
:= First_Entity
(From
);
6390 if (Last_Entity
(To
)) = Empty
then
6391 Set_First_Entity
(To
, Ent
);
6393 Set_Next_Entity
(Last_Entity
(To
), Ent
);
6396 Set_Last_Entity
(To
, Last_Entity
(From
));
6398 while Present
(Ent
) loop
6399 Set_Scope
(Ent
, To
);
6401 if not Is_Public
(Ent
) then
6402 Set_Public_Status
(Ent
);
6405 and then Ekind
(Ent
) = E_Record_Subtype
6408 -- The components of the propagated Itype must be public
6415 Comp
:= First_Entity
(Ent
);
6417 while Present
(Comp
) loop
6418 Set_Is_Public
(Comp
);
6428 Set_First_Entity
(From
, Empty
);
6429 Set_Last_Entity
(From
, Empty
);
6430 end Transfer_Entities
;
6432 -----------------------
6433 -- Type_Access_Level --
6434 -----------------------
6436 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
6440 -- If the type is an anonymous access type we treat it as being
6441 -- declared at the library level to ensure that names such as
6442 -- X.all'access don't fail static accessibility checks.
6444 -- Ada 2005 (AI-230): In case of anonymous access types that are
6445 -- component_definition or discriminants of a nonlimited type,
6446 -- the level is the same as that of the enclosing component type.
6448 Btyp
:= Base_Type
(Typ
);
6449 if Ekind
(Btyp
) in Access_Kind
then
6450 if Ekind
(Btyp
) = E_Anonymous_Access_Type
6451 and then not Is_Array_Type
(Scope
(Btyp
)) -- Ada 2005 (AI-230)
6452 and then Ekind
(Scope
(Btyp
)) /= E_Record_Type
-- Ada 2005 (AI-230)
6454 return Scope_Depth
(Standard_Standard
);
6457 Btyp
:= Root_Type
(Btyp
);
6460 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
6461 end Type_Access_Level
;
6463 --------------------------
6464 -- Unit_Declaration_Node --
6465 --------------------------
6467 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
6468 N
: Node_Id
:= Parent
(Unit_Id
);
6471 -- Predefined operators do not have a full function declaration
6473 if Ekind
(Unit_Id
) = E_Operator
then
6477 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
6478 and then Nkind
(N
) /= N_Formal_Package_Declaration
6479 and then Nkind
(N
) /= N_Function_Instantiation
6480 and then Nkind
(N
) /= N_Generic_Package_Declaration
6481 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
6482 and then Nkind
(N
) /= N_Package_Declaration
6483 and then Nkind
(N
) /= N_Package_Body
6484 and then Nkind
(N
) /= N_Package_Instantiation
6485 and then Nkind
(N
) /= N_Package_Renaming_Declaration
6486 and then Nkind
(N
) /= N_Procedure_Instantiation
6487 and then Nkind
(N
) /= N_Protected_Body
6488 and then Nkind
(N
) /= N_Subprogram_Declaration
6489 and then Nkind
(N
) /= N_Subprogram_Body
6490 and then Nkind
(N
) /= N_Subprogram_Body_Stub
6491 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
6492 and then Nkind
(N
) /= N_Task_Body
6493 and then Nkind
(N
) /= N_Task_Type_Declaration
6494 and then Nkind
(N
) not in N_Formal_Subprogram_Declaration
6495 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
6498 pragma Assert
(Present
(N
));
6502 end Unit_Declaration_Node
;
6504 ------------------------------
6505 -- Universal_Interpretation --
6506 ------------------------------
6508 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
6509 Index
: Interp_Index
;
6513 -- The argument may be a formal parameter of an operator or subprogram
6514 -- with multiple interpretations, or else an expression for an actual.
6516 if Nkind
(Opnd
) = N_Defining_Identifier
6517 or else not Is_Overloaded
(Opnd
)
6519 if Etype
(Opnd
) = Universal_Integer
6520 or else Etype
(Opnd
) = Universal_Real
6522 return Etype
(Opnd
);
6528 Get_First_Interp
(Opnd
, Index
, It
);
6530 while Present
(It
.Typ
) loop
6532 if It
.Typ
= Universal_Integer
6533 or else It
.Typ
= Universal_Real
6538 Get_Next_Interp
(Index
, It
);
6543 end Universal_Interpretation
;
6545 ----------------------
6546 -- Within_Init_Proc --
6547 ----------------------
6549 function Within_Init_Proc
return Boolean is
6554 while not Is_Overloadable
(S
) loop
6555 if S
= Standard_Standard
then
6562 return Is_Init_Proc
(S
);
6563 end Within_Init_Proc
;
6569 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
6570 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
6571 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
6573 function Has_One_Matching_Field
return Boolean;
6574 -- Determines whether Expec_Type is a record type with a single
6575 -- component or discriminant whose type matches the found type or
6576 -- is a one dimensional array whose component type matches the
6579 function Has_One_Matching_Field
return Boolean is
6583 if Is_Array_Type
(Expec_Type
)
6584 and then Number_Dimensions
(Expec_Type
) = 1
6586 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
6590 elsif not Is_Record_Type
(Expec_Type
) then
6594 E
:= First_Entity
(Expec_Type
);
6600 elsif (Ekind
(E
) /= E_Discriminant
6601 and then Ekind
(E
) /= E_Component
)
6602 or else (Chars
(E
) = Name_uTag
6603 or else Chars
(E
) = Name_uParent
)
6612 if not Covers
(Etype
(E
), Found_Type
) then
6615 elsif Present
(Next_Entity
(E
)) then
6622 end Has_One_Matching_Field
;
6624 -- Start of processing for Wrong_Type
6627 -- Don't output message if either type is Any_Type, or if a message
6628 -- has already been posted for this node. We need to do the latter
6629 -- check explicitly (it is ordinarily done in Errout), because we
6630 -- are using ! to force the output of the error messages.
6632 if Expec_Type
= Any_Type
6633 or else Found_Type
= Any_Type
6634 or else Error_Posted
(Expr
)
6638 -- In an instance, there is an ongoing problem with completion of
6639 -- type derived from private types. Their structure is what Gigi
6640 -- expects, but the Etype is the parent type rather than the
6641 -- derived private type itself. Do not flag error in this case. The
6642 -- private completion is an entity without a parent, like an Itype.
6643 -- Similarly, full and partial views may be incorrect in the instance.
6644 -- There is no simple way to insure that it is consistent ???
6646 elsif In_Instance
then
6648 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
6650 (Has_Private_Declaration
(Expected_Type
)
6651 or else Has_Private_Declaration
(Etype
(Expr
)))
6652 and then No
(Parent
(Expected_Type
))
6658 -- An interesting special check. If the expression is parenthesized
6659 -- and its type corresponds to the type of the sole component of the
6660 -- expected record type, or to the component type of the expected one
6661 -- dimensional array type, then assume we have a bad aggregate attempt.
6663 if Nkind
(Expr
) in N_Subexpr
6664 and then Paren_Count
(Expr
) /= 0
6665 and then Has_One_Matching_Field
6667 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
6669 -- Another special check, if we are looking for a pool-specific access
6670 -- type and we found an E_Access_Attribute_Type, then we have the case
6671 -- of an Access attribute being used in a context which needs a pool-
6672 -- specific type, which is never allowed. The one extra check we make
6673 -- is that the expected designated type covers the Found_Type.
6675 elsif Is_Access_Type
(Expec_Type
)
6676 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
6677 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
6678 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
6680 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
6682 Error_Msg_N
("result must be general access type!", Expr
);
6683 Error_Msg_NE
("add ALL to }!", Expr
, Expec_Type
);
6685 -- If the expected type is an anonymous access type, as for access
6686 -- parameters and discriminants, the error is on the designated types.
6688 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
6689 if Comes_From_Source
(Expec_Type
) then
6690 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
6693 ("expected an access type with designated}",
6694 Expr
, Designated_Type
(Expec_Type
));
6697 if Is_Access_Type
(Found_Type
)
6698 and then not Comes_From_Source
(Found_Type
)
6701 ("found an access type with designated}!",
6702 Expr
, Designated_Type
(Found_Type
));
6704 if From_With_Type
(Found_Type
) then
6705 Error_Msg_NE
("found incomplete}!", Expr
, Found_Type
);
6707 ("\possibly missing with_clause on&", Expr
,
6708 Scope
(Found_Type
));
6710 Error_Msg_NE
("found}!", Expr
, Found_Type
);
6714 -- Normal case of one type found, some other type expected
6717 -- If the names of the two types are the same, see if some
6718 -- number of levels of qualification will help. Don't try
6719 -- more than three levels, and if we get to standard, it's
6720 -- no use (and probably represents an error in the compiler)
6721 -- Also do not bother with internal scope names.
6724 Expec_Scope
: Entity_Id
;
6725 Found_Scope
: Entity_Id
;
6728 Expec_Scope
:= Expec_Type
;
6729 Found_Scope
:= Found_Type
;
6731 for Levels
in Int
range 0 .. 3 loop
6732 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
6733 Error_Msg_Qual_Level
:= Levels
;
6737 Expec_Scope
:= Scope
(Expec_Scope
);
6738 Found_Scope
:= Scope
(Found_Scope
);
6740 exit when Expec_Scope
= Standard_Standard
6742 Found_Scope
= Standard_Standard
6744 not Comes_From_Source
(Expec_Scope
)
6746 not Comes_From_Source
(Found_Scope
);
6750 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
6752 if Is_Entity_Name
(Expr
)
6753 and then Is_Package
(Entity
(Expr
))
6755 Error_Msg_N
("found package name!", Expr
);
6757 elsif Is_Entity_Name
(Expr
)
6759 (Ekind
(Entity
(Expr
)) = E_Procedure
6761 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
6763 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
6765 ("found procedure name, possibly missing Access attribute!",
6768 Error_Msg_N
("found procedure name instead of function!", Expr
);
6771 elsif Nkind
(Expr
) = N_Function_Call
6772 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
6773 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
6774 and then No
(Parameter_Associations
(Expr
))
6777 ("found function name, possibly missing Access attribute!",
6780 -- Catch common error: a prefix or infix operator which is not
6781 -- directly visible because the type isn't.
6783 elsif Nkind
(Expr
) in N_Op
6784 and then Is_Overloaded
(Expr
)
6785 and then not Is_Immediately_Visible
(Expec_Type
)
6786 and then not Is_Potentially_Use_Visible
(Expec_Type
)
6787 and then not In_Use
(Expec_Type
)
6788 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
6791 "operator of the type is not directly visible!", Expr
);
6793 elsif Ekind
(Found_Type
) = E_Void
6794 and then Present
(Parent
(Found_Type
))
6795 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
6797 Error_Msg_NE
("found premature usage of}!", Expr
, Found_Type
);
6800 Error_Msg_NE
("found}!", Expr
, Found_Type
);
6803 Error_Msg_Qual_Level
:= 0;