1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Errout
; use Errout
;
32 with Elists
; use Elists
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Exp_Util
; use Exp_Util
;
35 with Fname
; use Fname
;
36 with Freeze
; use Freeze
;
38 with Lib
.Xref
; use Lib
.Xref
;
39 with Namet
; use Namet
;
40 with Nlists
; use Nlists
;
41 with Nmake
; use Nmake
;
42 with Output
; use Output
;
44 with Rtsfind
; use Rtsfind
;
45 with Scans
; use Scans
;
48 with Sem_Ch8
; use Sem_Ch8
;
49 with Sem_Eval
; use Sem_Eval
;
50 with Sem_Res
; use Sem_Res
;
51 with Sem_Type
; use Sem_Type
;
52 with Sinfo
; use Sinfo
;
53 with Sinput
; use Sinput
;
54 with Snames
; use Snames
;
55 with Stand
; use Stand
;
57 with Stringt
; use Stringt
;
58 with Targparm
; use Targparm
;
59 with Tbuild
; use Tbuild
;
60 with Ttypes
; use Ttypes
;
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 /= 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
2529 P
: constant Nat
:= UI_To_Int
(Pos
);
2532 -- In the case where the literal is either of type Wide_Character
2533 -- or Character or of a type derived from them, there needs to be
2534 -- some special handling since there is no explicit chain of
2535 -- literals to search. Instead, an N_Character_Literal node is
2536 -- created with the appropriate Char_Code and Chars fields.
2538 if Root_Type
(T
) = Standard_Character
2539 or else Root_Type
(T
) = Standard_Wide_Character
2541 Set_Character_Literal_Name
(Char_Code
(P
));
2543 Make_Character_Literal
(Loc
,
2545 Char_Literal_Value
=> Char_Code
(P
));
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 .. P
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
));
2570 if Present
(Renamed_Object
(Ent
)) then
2571 return Renamed_Object
(Ent
);
2575 end Get_Generic_Entity
;
2577 ----------------------
2578 -- Get_Index_Bounds --
2579 ----------------------
2581 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
2582 Kind
: constant Node_Kind
:= Nkind
(N
);
2586 if Kind
= N_Range
then
2588 H
:= High_Bound
(N
);
2590 elsif Kind
= N_Subtype_Indication
then
2591 R
:= Range_Expression
(Constraint
(N
));
2599 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
2600 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
2603 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
2604 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
2608 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
2609 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
2612 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
2613 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
2617 -- N is an expression, indicating a range with one value
2622 end Get_Index_Bounds
;
2624 ----------------------------------
2625 -- Get_Library_Unit_Name_string --
2626 ----------------------------------
2628 procedure Get_Library_Unit_Name_String
(Decl_Node
: Node_Id
) is
2629 Unit_Name_Id
: constant Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
2632 Get_Unit_Name_String
(Unit_Name_Id
);
2634 -- Remove seven last character (" (spec)" or " (body)")
2636 Name_Len
:= Name_Len
- 7;
2637 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
2638 end Get_Library_Unit_Name_String
;
2640 ------------------------
2641 -- Get_Name_Entity_Id --
2642 ------------------------
2644 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
2646 return Entity_Id
(Get_Name_Table_Info
(Id
));
2647 end Get_Name_Entity_Id
;
2649 ---------------------------
2650 -- Get_Referenced_Object --
2651 ---------------------------
2653 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
2657 while Is_Entity_Name
(R
)
2658 and then Present
(Renamed_Object
(Entity
(R
)))
2660 R
:= Renamed_Object
(Entity
(R
));
2664 end Get_Referenced_Object
;
2666 -------------------------
2667 -- Get_Subprogram_Body --
2668 -------------------------
2670 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
2674 Decl
:= Unit_Declaration_Node
(E
);
2676 if Nkind
(Decl
) = N_Subprogram_Body
then
2679 -- The below comment is bad, because it is possible for
2680 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
2682 else -- Nkind (Decl) = N_Subprogram_Declaration
2684 if Present
(Corresponding_Body
(Decl
)) then
2685 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2687 -- Imported subprogram case
2693 end Get_Subprogram_Body
;
2695 -----------------------------
2696 -- Get_Task_Body_Procedure --
2697 -----------------------------
2699 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
2701 return Task_Body_Procedure
(Declaration_Node
(Root_Type
(E
)));
2702 end Get_Task_Body_Procedure
;
2704 -----------------------
2705 -- Has_Access_Values --
2706 -----------------------
2708 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
2709 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
2712 -- Case of a private type which is not completed yet. This can only
2713 -- happen in the case of a generic format type appearing directly, or
2714 -- as a component of the type to which this function is being applied
2715 -- at the top level. Return False in this case, since we certainly do
2716 -- not know that the type contains access types.
2721 elsif Is_Access_Type
(Typ
) then
2724 elsif Is_Array_Type
(Typ
) then
2725 return Has_Access_Values
(Component_Type
(Typ
));
2727 elsif Is_Record_Type
(Typ
) then
2732 Comp
:= First_Entity
(Typ
);
2733 while Present
(Comp
) loop
2734 if (Ekind
(Comp
) = E_Component
2736 Ekind
(Comp
) = E_Discriminant
)
2737 and then Has_Access_Values
(Etype
(Comp
))
2751 end Has_Access_Values
;
2753 ----------------------
2754 -- Has_Declarations --
2755 ----------------------
2757 function Has_Declarations
(N
: Node_Id
) return Boolean is
2758 K
: constant Node_Kind
:= Nkind
(N
);
2760 return K
= N_Accept_Statement
2761 or else K
= N_Block_Statement
2762 or else K
= N_Compilation_Unit_Aux
2763 or else K
= N_Entry_Body
2764 or else K
= N_Package_Body
2765 or else K
= N_Protected_Body
2766 or else K
= N_Subprogram_Body
2767 or else K
= N_Task_Body
2768 or else K
= N_Package_Specification
;
2769 end Has_Declarations
;
2771 --------------------
2772 -- Has_Infinities --
2773 --------------------
2775 function Has_Infinities
(E
: Entity_Id
) return Boolean is
2778 Is_Floating_Point_Type
(E
)
2779 and then Nkind
(Scalar_Range
(E
)) = N_Range
2780 and then Includes_Infinities
(Scalar_Range
(E
));
2783 ------------------------
2784 -- Has_Null_Extension --
2785 ------------------------
2787 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
2788 B
: constant Entity_Id
:= Base_Type
(T
);
2793 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
2794 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
2796 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
2798 if Present
(Ext
) then
2799 if Null_Present
(Ext
) then
2802 Comps
:= Component_List
(Ext
);
2804 -- The null component list is rewritten during analysis to
2805 -- include the parent component. Any other component indicates
2806 -- that the extension was not originally null.
2808 return Null_Present
(Comps
)
2809 or else No
(Next
(First
(Component_Items
(Comps
))));
2818 end Has_Null_Extension
;
2820 ---------------------------
2821 -- Has_Private_Component --
2822 ---------------------------
2824 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
2825 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
2826 Component
: Entity_Id
;
2829 if Error_Posted
(Type_Id
)
2830 or else Error_Posted
(Btype
)
2835 if Is_Class_Wide_Type
(Btype
) then
2836 Btype
:= Root_Type
(Btype
);
2839 if Is_Private_Type
(Btype
) then
2841 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
2845 if No
(Full_View
(Btype
)) then
2846 return not Is_Generic_Type
(Btype
)
2847 and then not Is_Generic_Type
(Root_Type
(Btype
));
2850 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
2854 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
2857 elsif Is_Array_Type
(Btype
) then
2858 return Has_Private_Component
(Component_Type
(Btype
));
2860 elsif Is_Record_Type
(Btype
) then
2862 Component
:= First_Component
(Btype
);
2863 while Present
(Component
) loop
2865 if Has_Private_Component
(Etype
(Component
)) then
2869 Next_Component
(Component
);
2874 elsif Is_Protected_Type
(Btype
)
2875 and then Present
(Corresponding_Record_Type
(Btype
))
2877 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
2882 end Has_Private_Component
;
2888 function Has_Stream
(T
: Entity_Id
) return Boolean is
2895 elsif Is_RTE
(Root_Type
(T
), RE_Root_Stream_Type
) then
2898 elsif Is_Array_Type
(T
) then
2899 return Has_Stream
(Component_Type
(T
));
2901 elsif Is_Record_Type
(T
) then
2902 E
:= First_Component
(T
);
2903 while Present
(E
) loop
2904 if Has_Stream
(Etype
(E
)) then
2913 elsif Is_Private_Type
(T
) then
2914 return Has_Stream
(Underlying_Type
(T
));
2921 --------------------------
2922 -- Has_Tagged_Component --
2923 --------------------------
2925 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
2929 if Is_Private_Type
(Typ
)
2930 and then Present
(Underlying_Type
(Typ
))
2932 return Has_Tagged_Component
(Underlying_Type
(Typ
));
2934 elsif Is_Array_Type
(Typ
) then
2935 return Has_Tagged_Component
(Component_Type
(Typ
));
2937 elsif Is_Tagged_Type
(Typ
) then
2940 elsif Is_Record_Type
(Typ
) then
2941 Comp
:= First_Component
(Typ
);
2943 while Present
(Comp
) loop
2944 if Has_Tagged_Component
(Etype
(Comp
)) then
2948 Comp
:= Next_Component
(Typ
);
2956 end Has_Tagged_Component
;
2962 function In_Instance
return Boolean is
2963 S
: Entity_Id
:= Current_Scope
;
2967 and then S
/= Standard_Standard
2969 if (Ekind
(S
) = E_Function
2970 or else Ekind
(S
) = E_Package
2971 or else Ekind
(S
) = E_Procedure
)
2972 and then Is_Generic_Instance
(S
)
2983 ----------------------
2984 -- In_Instance_Body --
2985 ----------------------
2987 function In_Instance_Body
return Boolean is
2988 S
: Entity_Id
:= Current_Scope
;
2992 and then S
/= Standard_Standard
2994 if (Ekind
(S
) = E_Function
2995 or else Ekind
(S
) = E_Procedure
)
2996 and then Is_Generic_Instance
(S
)
3000 elsif Ekind
(S
) = E_Package
3001 and then In_Package_Body
(S
)
3002 and then Is_Generic_Instance
(S
)
3011 end In_Instance_Body
;
3013 -----------------------------
3014 -- In_Instance_Not_Visible --
3015 -----------------------------
3017 function In_Instance_Not_Visible
return Boolean is
3018 S
: Entity_Id
:= Current_Scope
;
3022 and then S
/= Standard_Standard
3024 if (Ekind
(S
) = E_Function
3025 or else Ekind
(S
) = E_Procedure
)
3026 and then Is_Generic_Instance
(S
)
3030 elsif Ekind
(S
) = E_Package
3031 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
3032 and then Is_Generic_Instance
(S
)
3041 end In_Instance_Not_Visible
;
3043 ------------------------------
3044 -- In_Instance_Visible_Part --
3045 ------------------------------
3047 function In_Instance_Visible_Part
return Boolean is
3048 S
: Entity_Id
:= Current_Scope
;
3052 and then S
/= Standard_Standard
3054 if Ekind
(S
) = E_Package
3055 and then Is_Generic_Instance
(S
)
3056 and then not In_Package_Body
(S
)
3057 and then not In_Private_Part
(S
)
3066 end In_Instance_Visible_Part
;
3068 ----------------------
3069 -- In_Packiage_Body --
3070 ----------------------
3072 function In_Package_Body
return Boolean is
3073 S
: Entity_Id
:= Current_Scope
;
3077 and then S
/= Standard_Standard
3079 if Ekind
(S
) = E_Package
3080 and then In_Package_Body
(S
)
3089 end In_Package_Body
;
3091 --------------------------------------
3092 -- In_Subprogram_Or_Concurrent_Unit --
3093 --------------------------------------
3095 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
3100 -- Use scope chain to check successively outer scopes
3106 if K
in Subprogram_Kind
3107 or else K
in Concurrent_Kind
3108 or else K
in Generic_Subprogram_Kind
3112 elsif E
= Standard_Standard
then
3118 end In_Subprogram_Or_Concurrent_Unit
;
3120 ---------------------
3121 -- In_Visible_Part --
3122 ---------------------
3124 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
3127 Is_Package
(Scope_Id
)
3128 and then In_Open_Scopes
(Scope_Id
)
3129 and then not In_Package_Body
(Scope_Id
)
3130 and then not In_Private_Part
(Scope_Id
);
3131 end In_Visible_Part
;
3133 ---------------------------------
3134 -- Insert_Explicit_Dereference --
3135 ---------------------------------
3137 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
3138 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
3139 Ent
: Entity_Id
:= Empty
;
3145 Save_Interps
(N
, New_Prefix
);
3147 Make_Explicit_Dereference
(Sloc
(N
), Prefix
=> New_Prefix
));
3149 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
3151 if Is_Overloaded
(New_Prefix
) then
3153 -- The deference is also overloaded, and its interpretations are the
3154 -- designated types of the interpretations of the original node.
3156 Set_Etype
(N
, Any_Type
);
3157 Get_First_Interp
(New_Prefix
, I
, It
);
3159 while Present
(It
.Nam
) loop
3162 if Is_Access_Type
(T
) then
3163 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
3166 Get_Next_Interp
(I
, It
);
3172 -- Prefix is unambiguous: mark the original prefix (which might
3173 -- Come_From_Source) as a reference, since the new (relocated) one
3174 -- won't be taken into account.
3176 if Is_Entity_Name
(New_Prefix
) then
3177 Ent
:= Entity
(New_Prefix
);
3178 elsif Nkind
(New_Prefix
) = N_Selected_Component
then
3179 Ent
:= Entity
(Selector_Name
(New_Prefix
));
3182 if Present
(Ent
) then
3183 Generate_Reference
(Ent
, New_Prefix
);
3186 end Insert_Explicit_Dereference
;
3192 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
3194 pragma Assert
(Is_Type
(E
));
3196 return AAMP_On_Target
3197 and then Is_Floating_Point_Type
(E
)
3198 and then E
= Base_Type
(E
);
3201 -------------------------
3202 -- Is_Actual_Parameter --
3203 -------------------------
3205 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
3206 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3210 when N_Parameter_Association
=>
3211 return N
= Explicit_Actual_Parameter
(Parent
(N
));
3213 when N_Function_Call | N_Procedure_Call_Statement
=>
3214 return Is_List_Member
(N
)
3216 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
3221 end Is_Actual_Parameter
;
3223 ---------------------
3224 -- Is_Aliased_View --
3225 ---------------------
3227 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
3231 if Is_Entity_Name
(Obj
) then
3239 or else (Present
(Renamed_Object
(E
))
3240 and then Is_Aliased_View
(Renamed_Object
(E
)))))
3242 or else ((Is_Formal
(E
)
3243 or else Ekind
(E
) = E_Generic_In_Out_Parameter
3244 or else Ekind
(E
) = E_Generic_In_Parameter
)
3245 and then Is_Tagged_Type
(Etype
(E
)))
3247 or else ((Ekind
(E
) = E_Task_Type
3248 or else Ekind
(E
) = E_Protected_Type
)
3249 and then In_Open_Scopes
(E
))
3251 -- Current instance of type
3253 or else (Is_Type
(E
) and then E
= Current_Scope
)
3254 or else (Is_Incomplete_Or_Private_Type
(E
)
3255 and then Full_View
(E
) = Current_Scope
);
3257 elsif Nkind
(Obj
) = N_Selected_Component
then
3258 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
3260 elsif Nkind
(Obj
) = N_Indexed_Component
then
3261 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
3263 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
3265 Has_Aliased_Components
3266 (Designated_Type
(Etype
(Prefix
(Obj
)))));
3268 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
3269 or else Nkind
(Obj
) = N_Type_Conversion
3271 return Is_Tagged_Type
(Etype
(Obj
))
3272 and then Is_Aliased_View
(Expression
(Obj
));
3274 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
3275 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
3280 end Is_Aliased_View
;
3282 -------------------------
3283 -- Is_Ancestor_Package --
3284 -------------------------
3286 function Is_Ancestor_Package
3288 E2
: Entity_Id
) return Boolean
3295 and then Par
/= Standard_Standard
3305 end Is_Ancestor_Package
;
3307 ----------------------
3308 -- Is_Atomic_Object --
3309 ----------------------
3311 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
3313 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
3314 -- Determines if given object has atomic components
3316 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
3317 -- If prefix is an implicit dereference, examine designated type
3319 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
3321 if Is_Access_Type
(Etype
(N
)) then
3323 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
3325 return Object_Has_Atomic_Components
(N
);
3327 end Is_Atomic_Prefix
;
3329 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
3331 if Has_Atomic_Components
(Etype
(N
))
3332 or else Is_Atomic
(Etype
(N
))
3336 elsif Is_Entity_Name
(N
)
3337 and then (Has_Atomic_Components
(Entity
(N
))
3338 or else Is_Atomic
(Entity
(N
)))
3342 elsif Nkind
(N
) = N_Indexed_Component
3343 or else Nkind
(N
) = N_Selected_Component
3345 return Is_Atomic_Prefix
(Prefix
(N
));
3350 end Object_Has_Atomic_Components
;
3352 -- Start of processing for Is_Atomic_Object
3355 if Is_Atomic
(Etype
(N
))
3356 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
3360 elsif Nkind
(N
) = N_Indexed_Component
3361 or else Nkind
(N
) = N_Selected_Component
3363 return Is_Atomic_Prefix
(Prefix
(N
));
3368 end Is_Atomic_Object
;
3370 ----------------------------------------------
3371 -- Is_Dependent_Component_Of_Mutable_Object --
3372 ----------------------------------------------
3374 function Is_Dependent_Component_Of_Mutable_Object
3375 (Object
: Node_Id
) return Boolean
3378 Prefix_Type
: Entity_Id
;
3379 P_Aliased
: Boolean := False;
3382 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean;
3383 -- Returns True if and only if Comp has a constrained subtype
3384 -- that depends on a discriminant.
3386 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
3387 -- Returns True if and only if Comp is declared within a variant part
3389 ------------------------------
3390 -- Has_Dependent_Constraint --
3391 ------------------------------
3393 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean is
3394 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3395 Subt_Indic
: constant Node_Id
:=
3396 Subtype_Indication
(Component_Definition
(Comp_Decl
));
3401 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
3402 Constr
:= Constraint
(Subt_Indic
);
3404 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
3405 Assn
:= First
(Constraints
(Constr
));
3406 while Present
(Assn
) loop
3407 case Nkind
(Assn
) is
3408 when N_Subtype_Indication |
3412 if Depends_On_Discriminant
(Assn
) then
3416 when N_Discriminant_Association
=>
3417 if Depends_On_Discriminant
(Expression
(Assn
)) then
3432 end Has_Dependent_Constraint
;
3434 --------------------------------
3435 -- Is_Declared_Within_Variant --
3436 --------------------------------
3438 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
3439 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3440 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
3443 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
3444 end Is_Declared_Within_Variant
;
3446 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
3449 if Is_Variable
(Object
) then
3451 if Nkind
(Object
) = N_Selected_Component
then
3452 P
:= Prefix
(Object
);
3453 Prefix_Type
:= Etype
(P
);
3455 if Is_Entity_Name
(P
) then
3457 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
3458 Prefix_Type
:= Base_Type
(Prefix_Type
);
3461 if Is_Aliased
(Entity
(P
)) then
3465 -- A discriminant check on a selected component may be
3466 -- expanded into a dereference when removing side-effects.
3467 -- Recover the original node and its type, which may be
3470 elsif Nkind
(P
) = N_Explicit_Dereference
3471 and then not (Comes_From_Source
(P
))
3473 P
:= Original_Node
(P
);
3474 Prefix_Type
:= Etype
(P
);
3477 -- Check for prefix being an aliased component ???
3482 if Is_Access_Type
(Prefix_Type
)
3483 or else Nkind
(P
) = N_Explicit_Dereference
3489 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
3491 -- As per AI-0017, the renaming is illegal in a generic body,
3492 -- even if the subtype is indefinite.
3494 if not Is_Constrained
(Prefix_Type
)
3495 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
3497 (Is_Generic_Type
(Prefix_Type
)
3498 and then Ekind
(Current_Scope
) = E_Generic_Package
3499 and then In_Package_Body
(Current_Scope
)))
3501 and then (Is_Declared_Within_Variant
(Comp
)
3502 or else Has_Dependent_Constraint
(Comp
))
3503 and then not P_Aliased
3509 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3513 elsif Nkind
(Object
) = N_Indexed_Component
3514 or else Nkind
(Object
) = N_Slice
3516 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3518 -- A type conversion that Is_Variable is a view conversion:
3519 -- go back to the denoted object.
3521 elsif Nkind
(Object
) = N_Type_Conversion
then
3523 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
3528 end Is_Dependent_Component_Of_Mutable_Object
;
3530 ---------------------
3531 -- Is_Dereferenced --
3532 ---------------------
3534 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
3535 P
: constant Node_Id
:= Parent
(N
);
3539 (Nkind
(P
) = N_Selected_Component
3541 Nkind
(P
) = N_Explicit_Dereference
3543 Nkind
(P
) = N_Indexed_Component
3545 Nkind
(P
) = N_Slice
)
3546 and then Prefix
(P
) = N
;
3547 end Is_Dereferenced
;
3549 ----------------------
3550 -- Is_Descendent_Of --
3551 ----------------------
3553 function Is_Descendent_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
3558 pragma Assert
(Nkind
(T1
) in N_Entity
);
3559 pragma Assert
(Nkind
(T2
) in N_Entity
);
3561 T
:= Base_Type
(T1
);
3563 -- Immediate return if the types match
3568 -- Comment needed here ???
3570 elsif Ekind
(T
) = E_Class_Wide_Type
then
3571 return Etype
(T
) = T2
;
3579 -- Done if we found the type we are looking for
3584 -- Done if no more derivations to check
3591 -- Following test catches error cases resulting from prev errors
3593 elsif No
(Etyp
) then
3596 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
3599 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
3603 T
:= Base_Type
(Etyp
);
3607 raise Program_Error
;
3608 end Is_Descendent_Of
;
3610 ------------------------------
3611 -- Is_Descendent_Of_Address --
3612 ------------------------------
3614 function Is_Descendent_Of_Address
(T1
: Entity_Id
) return Boolean is
3616 -- If Address has not been loaded, answer must be False
3618 if not RTU_Loaded
(System
) then
3621 -- Otherwise we can get the entity we are interested in without
3622 -- causing an unwanted dependency on System, and do the test.
3625 return Is_Descendent_Of
(T1
, Base_Type
(RTE
(RE_Address
)));
3627 end Is_Descendent_Of_Address
;
3633 function Is_False
(U
: Uint
) return Boolean is
3638 ---------------------------
3639 -- Is_Fixed_Model_Number --
3640 ---------------------------
3642 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
3643 S
: constant Ureal
:= Small_Value
(T
);
3644 M
: Urealp
.Save_Mark
;
3649 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
3652 end Is_Fixed_Model_Number
;
3654 -------------------------------
3655 -- Is_Fully_Initialized_Type --
3656 -------------------------------
3658 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
3660 if Is_Scalar_Type
(Typ
) then
3663 elsif Is_Access_Type
(Typ
) then
3666 elsif Is_Array_Type
(Typ
) then
3667 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
3671 -- An interesting case, if we have a constrained type one of whose
3672 -- bounds is known to be null, then there are no elements to be
3673 -- initialized, so all the elements are initialized!
3675 if Is_Constrained
(Typ
) then
3678 Indx_Typ
: Entity_Id
;
3682 Indx
:= First_Index
(Typ
);
3683 while Present
(Indx
) loop
3685 if Etype
(Indx
) = Any_Type
then
3688 -- If index is a range, use directly
3690 elsif Nkind
(Indx
) = N_Range
then
3691 Lbd
:= Low_Bound
(Indx
);
3692 Hbd
:= High_Bound
(Indx
);
3695 Indx_Typ
:= Etype
(Indx
);
3697 if Is_Private_Type
(Indx_Typ
) then
3698 Indx_Typ
:= Full_View
(Indx_Typ
);
3701 if No
(Indx_Typ
) then
3704 Lbd
:= Type_Low_Bound
(Indx_Typ
);
3705 Hbd
:= Type_High_Bound
(Indx_Typ
);
3709 if Compile_Time_Known_Value
(Lbd
)
3710 and then Compile_Time_Known_Value
(Hbd
)
3712 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
3722 -- If no null indexes, then type is not fully initialized
3728 elsif Is_Record_Type
(Typ
) then
3729 if Has_Discriminants
(Typ
)
3731 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
3732 and then Is_Fully_Initialized_Variant
(Typ
)
3737 -- Controlled records are considered to be fully initialized if
3738 -- there is a user defined Initialize routine. This may not be
3739 -- entirely correct, but as the spec notes, we are guessing here
3740 -- what is best from the point of view of issuing warnings.
3742 if Is_Controlled
(Typ
) then
3744 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3747 if Present
(Utyp
) then
3749 Init
: constant Entity_Id
:=
3751 (Underlying_Type
(Typ
), Name_Initialize
));
3755 and then Comes_From_Source
(Init
)
3757 Is_Predefined_File_Name
3758 (File_Name
(Get_Source_File_Index
(Sloc
(Init
))))
3762 elsif Has_Null_Extension
(Typ
)
3764 Is_Fully_Initialized_Type
3765 (Etype
(Base_Type
(Typ
)))
3774 -- Otherwise see if all record components are initialized
3780 Ent
:= First_Entity
(Typ
);
3782 while Present
(Ent
) loop
3783 if Chars
(Ent
) = Name_uController
then
3786 elsif Ekind
(Ent
) = E_Component
3787 and then (No
(Parent
(Ent
))
3788 or else No
(Expression
(Parent
(Ent
))))
3789 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
3798 -- No uninitialized components, so type is fully initialized.
3799 -- Note that this catches the case of no components as well.
3803 elsif Is_Concurrent_Type
(Typ
) then
3806 elsif Is_Private_Type
(Typ
) then
3808 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3814 return Is_Fully_Initialized_Type
(U
);
3821 end Is_Fully_Initialized_Type
;
3823 ----------------------------------
3824 -- Is_Fully_Initialized_Variant --
3825 ----------------------------------
3827 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
3828 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3829 Constraints
: constant List_Id
:= New_List
;
3830 Components
: constant Elist_Id
:= New_Elmt_List
;
3831 Comp_Elmt
: Elmt_Id
;
3833 Comp_List
: Node_Id
;
3835 Discr_Val
: Node_Id
;
3836 Report_Errors
: Boolean;
3839 if Serious_Errors_Detected
> 0 then
3843 if Is_Record_Type
(Typ
)
3844 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
3845 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
3847 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
3848 Discr
:= First_Discriminant
(Typ
);
3850 while Present
(Discr
) loop
3851 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
3852 Discr_Val
:= Expression
(Parent
(Discr
));
3854 if Present
(Discr_Val
)
3855 and then Is_OK_Static_Expression
(Discr_Val
)
3857 Append_To
(Constraints
,
3858 Make_Component_Association
(Loc
,
3859 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
3860 Expression
=> New_Copy
(Discr_Val
)));
3868 Next_Discriminant
(Discr
);
3873 Comp_List
=> Comp_List
,
3874 Governed_By
=> Constraints
,
3876 Report_Errors
=> Report_Errors
);
3878 -- Check that each component present is fully initialized
3880 Comp_Elmt
:= First_Elmt
(Components
);
3882 while Present
(Comp_Elmt
) loop
3883 Comp_Id
:= Node
(Comp_Elmt
);
3885 if Ekind
(Comp_Id
) = E_Component
3886 and then (No
(Parent
(Comp_Id
))
3887 or else No
(Expression
(Parent
(Comp_Id
))))
3888 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
3893 Next_Elmt
(Comp_Elmt
);
3898 elsif Is_Private_Type
(Typ
) then
3900 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3906 return Is_Fully_Initialized_Variant
(U
);
3912 end Is_Fully_Initialized_Variant
;
3914 ----------------------------
3915 -- Is_Inherited_Operation --
3916 ----------------------------
3918 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
3919 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
3922 pragma Assert
(Is_Overloadable
(E
));
3923 return Kind
= N_Full_Type_Declaration
3924 or else Kind
= N_Private_Extension_Declaration
3925 or else Kind
= N_Subtype_Declaration
3926 or else (Ekind
(E
) = E_Enumeration_Literal
3927 and then Is_Derived_Type
(Etype
(E
)));
3928 end Is_Inherited_Operation
;
3930 -----------------------------
3931 -- Is_Library_Level_Entity --
3932 -----------------------------
3934 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
3936 -- The following is a small optimization, and it also handles
3937 -- properly discriminals, which in task bodies might appear in
3938 -- expressions before the corresponding procedure has been
3939 -- created, and which therefore do not have an assigned scope.
3941 if Ekind
(E
) in Formal_Kind
then
3945 -- Normal test is simply that the enclosing dynamic scope is Standard
3947 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
3948 end Is_Library_Level_Entity
;
3950 ---------------------------------
3951 -- Is_Local_Variable_Reference --
3952 ---------------------------------
3954 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
3956 if not Is_Entity_Name
(Expr
) then
3961 Ent
: constant Entity_Id
:= Entity
(Expr
);
3962 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
3965 if Ekind
(Ent
) /= E_Variable
3967 Ekind
(Ent
) /= E_In_Out_Parameter
3972 return Present
(Sub
) and then Sub
= Current_Subprogram
;
3976 end Is_Local_Variable_Reference
;
3982 function Is_Lvalue
(N
: Node_Id
) return Boolean is
3983 P
: constant Node_Id
:= Parent
(N
);
3988 -- Test left side of assignment
3990 when N_Assignment_Statement
=>
3991 return N
= Name
(P
);
3993 -- Test prefix of component or attribute
3995 when N_Attribute_Reference |
3997 N_Explicit_Dereference |
3998 N_Indexed_Component |
4000 N_Selected_Component |
4002 return N
= Prefix
(P
);
4004 -- Test subprogram parameter (we really should check the
4005 -- parameter mode, but it is not worth the trouble)
4007 when N_Function_Call |
4008 N_Procedure_Call_Statement |
4009 N_Accept_Statement |
4010 N_Parameter_Association
=>
4013 -- Test for appearing in a conversion that itself appears
4014 -- in an lvalue context, since this should be an lvalue.
4016 when N_Type_Conversion
=>
4017 return Is_Lvalue
(P
);
4019 -- Test for appearence in object renaming declaration
4021 when N_Object_Renaming_Declaration
=>
4024 -- All other references are definitely not Lvalues
4032 -------------------------
4033 -- Is_Object_Reference --
4034 -------------------------
4036 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
4038 if Is_Entity_Name
(N
) then
4039 return Is_Object
(Entity
(N
));
4043 when N_Indexed_Component | N_Slice
=>
4044 return Is_Object_Reference
(Prefix
(N
));
4046 -- In Ada95, a function call is a constant object
4048 when N_Function_Call
=>
4051 -- A reference to the stream attribute Input is a function call
4053 when N_Attribute_Reference
=>
4054 return Attribute_Name
(N
) = Name_Input
;
4056 when N_Selected_Component
=>
4058 Is_Object_Reference
(Selector_Name
(N
))
4059 and then Is_Object_Reference
(Prefix
(N
));
4061 when N_Explicit_Dereference
=>
4064 -- A view conversion of a tagged object is an object reference
4066 when N_Type_Conversion
=>
4067 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
4068 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
4069 and then Is_Object_Reference
(Expression
(N
));
4071 -- An unchecked type conversion is considered to be an object if
4072 -- the operand is an object (this construction arises only as a
4073 -- result of expansion activities).
4075 when N_Unchecked_Type_Conversion
=>
4082 end Is_Object_Reference
;
4084 -----------------------------------
4085 -- Is_OK_Variable_For_Out_Formal --
4086 -----------------------------------
4088 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
4090 Note_Possible_Modification
(AV
);
4092 -- We must reject parenthesized variable names. The check for
4093 -- Comes_From_Source is present because there are currently
4094 -- cases where the compiler violates this rule (e.g. passing
4095 -- a task object to its controlled Initialize routine).
4097 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
4100 -- A variable is always allowed
4102 elsif Is_Variable
(AV
) then
4105 -- Unchecked conversions are allowed only if they come from the
4106 -- generated code, which sometimes uses unchecked conversions for
4107 -- out parameters in cases where code generation is unaffected.
4108 -- We tell source unchecked conversions by seeing if they are
4109 -- rewrites of an original UC function call, or of an explicit
4110 -- conversion of a function call.
4112 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
4113 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
4116 elsif Comes_From_Source
(AV
)
4117 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
4121 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
4122 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
4128 -- Normal type conversions are allowed if argument is a variable
4130 elsif Nkind
(AV
) = N_Type_Conversion
then
4131 if Is_Variable
(Expression
(AV
))
4132 and then Paren_Count
(Expression
(AV
)) = 0
4134 Note_Possible_Modification
(Expression
(AV
));
4137 -- We also allow a non-parenthesized expression that raises
4138 -- constraint error if it rewrites what used to be a variable
4140 elsif Raises_Constraint_Error
(Expression
(AV
))
4141 and then Paren_Count
(Expression
(AV
)) = 0
4142 and then Is_Variable
(Original_Node
(Expression
(AV
)))
4146 -- Type conversion of something other than a variable
4152 -- If this node is rewritten, then test the original form, if that is
4153 -- OK, then we consider the rewritten node OK (for example, if the
4154 -- original node is a conversion, then Is_Variable will not be true
4155 -- but we still want to allow the conversion if it converts a variable).
4157 elsif Original_Node
(AV
) /= AV
then
4158 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
4160 -- All other non-variables are rejected
4165 end Is_OK_Variable_For_Out_Formal
;
4167 -----------------------------------
4168 -- Is_Partially_Initialized_Type --
4169 -----------------------------------
4171 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
4173 if Is_Scalar_Type
(Typ
) then
4176 elsif Is_Access_Type
(Typ
) then
4179 elsif Is_Array_Type
(Typ
) then
4181 -- If component type is partially initialized, so is array type
4183 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
4186 -- Otherwise we are only partially initialized if we are fully
4187 -- initialized (this is the empty array case, no point in us
4188 -- duplicating that code here).
4191 return Is_Fully_Initialized_Type
(Typ
);
4194 elsif Is_Record_Type
(Typ
) then
4196 -- A discriminated type is always partially initialized
4198 if Has_Discriminants
(Typ
) then
4201 -- A tagged type is always partially initialized
4203 elsif Is_Tagged_Type
(Typ
) then
4206 -- Case of non-discriminated record
4212 Component_Present
: Boolean := False;
4213 -- Set True if at least one component is present. If no
4214 -- components are present, then record type is fully
4215 -- initialized (another odd case, like the null array).
4218 -- Loop through components
4220 Ent
:= First_Entity
(Typ
);
4221 while Present
(Ent
) loop
4222 if Ekind
(Ent
) = E_Component
then
4223 Component_Present
:= True;
4225 -- If a component has an initialization expression then
4226 -- the enclosing record type is partially initialized
4228 if Present
(Parent
(Ent
))
4229 and then Present
(Expression
(Parent
(Ent
)))
4233 -- If a component is of a type which is itself partially
4234 -- initialized, then the enclosing record type is also.
4236 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
4244 -- No initialized components found. If we found any components
4245 -- they were all uninitialized so the result is false.
4247 if Component_Present
then
4250 -- But if we found no components, then all the components are
4251 -- initialized so we consider the type to be initialized.
4259 -- Concurrent types are always fully initialized
4261 elsif Is_Concurrent_Type
(Typ
) then
4264 -- For a private type, go to underlying type. If there is no underlying
4265 -- type then just assume this partially initialized. Not clear if this
4266 -- can happen in a non-error case, but no harm in testing for this.
4268 elsif Is_Private_Type
(Typ
) then
4270 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4276 return Is_Partially_Initialized_Type
(U
);
4280 -- For any other type (are there any?) assume partially initialized
4285 end Is_Partially_Initialized_Type
;
4287 -----------------------------
4288 -- Is_RCI_Pkg_Spec_Or_Body --
4289 -----------------------------
4291 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
4293 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
4294 -- Return True if the unit of Cunit is an RCI package declaration
4296 ---------------------------
4297 -- Is_RCI_Pkg_Decl_Cunit --
4298 ---------------------------
4300 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
4301 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
4304 if Nkind
(The_Unit
) /= N_Package_Declaration
then
4307 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
4308 end Is_RCI_Pkg_Decl_Cunit
;
4310 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
4313 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
4315 (Nkind
(Unit
(Cunit
)) = N_Package_Body
4316 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
4317 end Is_RCI_Pkg_Spec_Or_Body
;
4319 -----------------------------------------
4320 -- Is_Remote_Access_To_Class_Wide_Type --
4321 -----------------------------------------
4323 function Is_Remote_Access_To_Class_Wide_Type
4324 (E
: Entity_Id
) return Boolean
4328 function Comes_From_Limited_Private_Type_Declaration
4331 -- Check that the type is declared by a limited type declaration,
4332 -- or else is derived from a Remote_Type ancestor through private
4335 -------------------------------------------------
4336 -- Comes_From_Limited_Private_Type_Declaration --
4337 -------------------------------------------------
4339 function Comes_From_Limited_Private_Type_Declaration
(E
: in Entity_Id
)
4342 N
: constant Node_Id
:= Declaration_Node
(E
);
4344 if Nkind
(N
) = N_Private_Type_Declaration
4345 and then Limited_Present
(N
)
4350 if Nkind
(N
) = N_Private_Extension_Declaration
then
4352 Comes_From_Limited_Private_Type_Declaration
(Etype
(E
))
4354 (Is_Remote_Types
(Etype
(E
))
4355 and then Is_Limited_Record
(Etype
(E
))
4356 and then Has_Private_Declaration
(Etype
(E
)));
4360 end Comes_From_Limited_Private_Type_Declaration
;
4362 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
4365 if not (Is_Remote_Call_Interface
(E
)
4366 or else Is_Remote_Types
(E
))
4367 or else Ekind
(E
) /= E_General_Access_Type
4372 D
:= Designated_Type
(E
);
4374 if Ekind
(D
) /= E_Class_Wide_Type
then
4378 return Comes_From_Limited_Private_Type_Declaration
4379 (Defining_Identifier
(Parent
(D
)));
4380 end Is_Remote_Access_To_Class_Wide_Type
;
4382 -----------------------------------------
4383 -- Is_Remote_Access_To_Subprogram_Type --
4384 -----------------------------------------
4386 function Is_Remote_Access_To_Subprogram_Type
4387 (E
: Entity_Id
) return Boolean
4390 return (Ekind
(E
) = E_Access_Subprogram_Type
4391 or else (Ekind
(E
) = E_Record_Type
4392 and then Present
(Corresponding_Remote_Type
(E
))))
4393 and then (Is_Remote_Call_Interface
(E
)
4394 or else Is_Remote_Types
(E
));
4395 end Is_Remote_Access_To_Subprogram_Type
;
4397 --------------------
4398 -- Is_Remote_Call --
4399 --------------------
4401 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
4403 if Nkind
(N
) /= N_Procedure_Call_Statement
4404 and then Nkind
(N
) /= N_Function_Call
4406 -- An entry call cannot be remote
4410 elsif Nkind
(Name
(N
)) in N_Has_Entity
4411 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
4413 -- A subprogram declared in the spec of a RCI package is remote
4417 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
4418 and then Is_Remote_Access_To_Subprogram_Type
4419 (Etype
(Prefix
(Name
(N
))))
4421 -- The dereference of a RAS is a remote call
4425 elsif Present
(Controlling_Argument
(N
))
4426 and then Is_Remote_Access_To_Class_Wide_Type
4427 (Etype
(Controlling_Argument
(N
)))
4429 -- Any primitive operation call with a controlling argument of
4430 -- a RACW type is a remote call.
4435 -- All other calls are local calls
4440 ----------------------
4441 -- Is_Selector_Name --
4442 ----------------------
4444 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
4447 if not Is_List_Member
(N
) then
4449 P
: constant Node_Id
:= Parent
(N
);
4450 K
: constant Node_Kind
:= Nkind
(P
);
4454 (K
= N_Expanded_Name
or else
4455 K
= N_Generic_Association
or else
4456 K
= N_Parameter_Association
or else
4457 K
= N_Selected_Component
)
4458 and then Selector_Name
(P
) = N
;
4463 L
: constant List_Id
:= List_Containing
(N
);
4464 P
: constant Node_Id
:= Parent
(L
);
4467 return (Nkind
(P
) = N_Discriminant_Association
4468 and then Selector_Names
(P
) = L
)
4470 (Nkind
(P
) = N_Component_Association
4471 and then Choices
(P
) = L
);
4474 end Is_Selector_Name
;
4480 function Is_Statement
(N
: Node_Id
) return Boolean is
4483 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
4484 or else Nkind
(N
) = N_Procedure_Call_Statement
;
4491 function Is_Transfer
(N
: Node_Id
) return Boolean is
4492 Kind
: constant Node_Kind
:= Nkind
(N
);
4495 if Kind
= N_Return_Statement
4497 Kind
= N_Goto_Statement
4499 Kind
= N_Raise_Statement
4501 Kind
= N_Requeue_Statement
4505 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
4506 and then No
(Condition
(N
))
4510 elsif Kind
= N_Procedure_Call_Statement
4511 and then Is_Entity_Name
(Name
(N
))
4512 and then Present
(Entity
(Name
(N
)))
4513 and then No_Return
(Entity
(Name
(N
)))
4517 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
4529 function Is_True
(U
: Uint
) return Boolean is
4538 function Is_Variable
(N
: Node_Id
) return Boolean is
4540 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
4541 -- We do the test on the original node, since this is basically a
4542 -- test of syntactic categories, so it must not be disturbed by
4543 -- whatever rewriting might have occurred. For example, an aggregate,
4544 -- which is certainly NOT a variable, could be turned into a variable
4547 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
4548 -- Within a protected function, the private components of the
4549 -- enclosing protected type are constants. A function nested within
4550 -- a (protected) procedure is not itself protected.
4552 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
4553 -- Prefixes can involve implicit dereferences, in which case we
4554 -- must test for the case of a reference of a constant access
4555 -- type, which can never be a variable.
4557 ---------------------------
4558 -- In_Protected_Function --
4559 ---------------------------
4561 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
4562 Prot
: constant Entity_Id
:= Scope
(E
);
4566 if not Is_Protected_Type
(Prot
) then
4571 while Present
(S
) and then S
/= Prot
loop
4573 if Ekind
(S
) = E_Function
4574 and then Scope
(S
) = Prot
4584 end In_Protected_Function
;
4586 ------------------------
4587 -- Is_Variable_Prefix --
4588 ------------------------
4590 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
4592 if Is_Access_Type
(Etype
(P
)) then
4593 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
4595 return Is_Variable
(P
);
4597 end Is_Variable_Prefix
;
4599 -- Start of processing for Is_Variable
4602 -- Definitely OK if Assignment_OK is set. Since this is something that
4603 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
4605 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
4608 -- Normally we go to the original node, but there is one exception
4609 -- where we use the rewritten node, namely when it is an explicit
4610 -- dereference. The generated code may rewrite a prefix which is an
4611 -- access type with an explicit dereference. The dereference is a
4612 -- variable, even though the original node may not be (since it could
4613 -- be a constant of the access type).
4615 elsif Nkind
(N
) = N_Explicit_Dereference
4616 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
4617 and then Is_Access_Type
(Etype
(Orig_Node
))
4619 return Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
4621 -- All remaining checks use the original node
4623 elsif Is_Entity_Name
(Orig_Node
) then
4625 E
: constant Entity_Id
:= Entity
(Orig_Node
);
4626 K
: constant Entity_Kind
:= Ekind
(E
);
4629 return (K
= E_Variable
4630 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
4631 or else (K
= E_Component
4632 and then not In_Protected_Function
(E
))
4633 or else K
= E_Out_Parameter
4634 or else K
= E_In_Out_Parameter
4635 or else K
= E_Generic_In_Out_Parameter
4637 -- Current instance of type:
4639 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
4640 or else (Is_Incomplete_Or_Private_Type
(E
)
4641 and then In_Open_Scopes
(Full_View
(E
)));
4645 case Nkind
(Orig_Node
) is
4646 when N_Indexed_Component | N_Slice
=>
4647 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
4649 when N_Selected_Component
=>
4650 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
4651 and then Is_Variable
(Selector_Name
(Orig_Node
));
4653 -- For an explicit dereference, the type of the prefix cannot
4654 -- be an access to constant or an access to subprogram.
4656 when N_Explicit_Dereference
=>
4658 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
4661 return Is_Access_Type
(Typ
)
4662 and then not Is_Access_Constant
(Root_Type
(Typ
))
4663 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
4666 -- The type conversion is the case where we do not deal with the
4667 -- context dependent special case of an actual parameter. Thus
4668 -- the type conversion is only considered a variable for the
4669 -- purposes of this routine if the target type is tagged. However,
4670 -- a type conversion is considered to be a variable if it does not
4671 -- come from source (this deals for example with the conversions
4672 -- of expressions to their actual subtypes).
4674 when N_Type_Conversion
=>
4675 return Is_Variable
(Expression
(Orig_Node
))
4677 (not Comes_From_Source
(Orig_Node
)
4679 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
4681 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
4683 -- GNAT allows an unchecked type conversion as a variable. This
4684 -- only affects the generation of internal expanded code, since
4685 -- calls to instantiations of Unchecked_Conversion are never
4686 -- considered variables (since they are function calls).
4687 -- This is also true for expression actions.
4689 when N_Unchecked_Type_Conversion
=>
4690 return Is_Variable
(Expression
(Orig_Node
));
4698 ------------------------
4699 -- Is_Volatile_Object --
4700 ------------------------
4702 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
4704 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
4705 -- Determines if given object has volatile components
4707 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
4708 -- If prefix is an implicit dereference, examine designated type
4710 ------------------------
4711 -- Is_Volatile_Prefix --
4712 ------------------------
4714 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
4715 Typ
: constant Entity_Id
:= Etype
(N
);
4718 if Is_Access_Type
(Typ
) then
4720 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
4723 return Is_Volatile
(Dtyp
)
4724 or else Has_Volatile_Components
(Dtyp
);
4728 return Object_Has_Volatile_Components
(N
);
4730 end Is_Volatile_Prefix
;
4732 ------------------------------------
4733 -- Object_Has_Volatile_Components --
4734 ------------------------------------
4736 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
4737 Typ
: constant Entity_Id
:= Etype
(N
);
4740 if Is_Volatile
(Typ
)
4741 or else Has_Volatile_Components
(Typ
)
4745 elsif Is_Entity_Name
(N
)
4746 and then (Has_Volatile_Components
(Entity
(N
))
4747 or else Is_Volatile
(Entity
(N
)))
4751 elsif Nkind
(N
) = N_Indexed_Component
4752 or else Nkind
(N
) = N_Selected_Component
4754 return Is_Volatile_Prefix
(Prefix
(N
));
4759 end Object_Has_Volatile_Components
;
4761 -- Start of processing for Is_Volatile_Object
4764 if Is_Volatile
(Etype
(N
))
4765 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
4769 elsif Nkind
(N
) = N_Indexed_Component
4770 or else Nkind
(N
) = N_Selected_Component
4772 return Is_Volatile_Prefix
(Prefix
(N
));
4777 end Is_Volatile_Object
;
4779 -------------------------
4780 -- Kill_Current_Values --
4781 -------------------------
4783 procedure Kill_Current_Values
is
4786 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
4787 -- Clear current value for entity E and all entities chained to E
4789 ------------------------------------------
4790 -- Kill_Current_Values_For_Entity_Chain --
4791 ------------------------------------------
4793 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
4798 while Present
(Ent
) loop
4799 if Is_Object
(Ent
) then
4800 Set_Current_Value
(Ent
, Empty
);
4802 if not Can_Never_Be_Null
(Ent
) then
4803 Set_Is_Known_Non_Null
(Ent
, False);
4809 end Kill_Current_Values_For_Entity_Chain
;
4811 -- Start of processing for Kill_Current_Values
4814 -- Kill all saved checks, a special case of killing saved values
4818 -- Loop through relevant scopes, which includes the current scope and
4819 -- any parent scopes if the current scope is a block or a package.
4824 -- Clear current values of all entities in current scope
4826 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
4828 -- If scope is a package, also clear current values of all
4829 -- private entities in the scope.
4831 if Ekind
(S
) = E_Package
4833 Ekind
(S
) = E_Generic_Package
4835 Is_Concurrent_Type
(S
)
4837 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
4840 -- If this is a block or nested package, deal with parent
4842 if Ekind
(S
) = E_Block
4843 or else (Ekind
(S
) = E_Package
4844 and then not Is_Library_Level_Entity
(S
))
4850 end loop Scope_Loop
;
4851 end Kill_Current_Values
;
4853 --------------------------
4854 -- Kill_Size_Check_Code --
4855 --------------------------
4857 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
4859 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
4860 and then Present
(Size_Check_Code
(E
))
4862 Remove
(Size_Check_Code
(E
));
4863 Set_Size_Check_Code
(E
, Empty
);
4865 end Kill_Size_Check_Code
;
4867 -------------------------
4868 -- New_External_Entity --
4869 -------------------------
4871 function New_External_Entity
4872 (Kind
: Entity_Kind
;
4873 Scope_Id
: Entity_Id
;
4874 Sloc_Value
: Source_Ptr
;
4875 Related_Id
: Entity_Id
;
4877 Suffix_Index
: Nat
:= 0;
4878 Prefix
: Character := ' ') return Entity_Id
4880 N
: constant Entity_Id
:=
4881 Make_Defining_Identifier
(Sloc_Value
,
4883 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
4886 Set_Ekind
(N
, Kind
);
4887 Set_Is_Internal
(N
, True);
4888 Append_Entity
(N
, Scope_Id
);
4889 Set_Public_Status
(N
);
4891 if Kind
in Type_Kind
then
4892 Init_Size_Align
(N
);
4896 end New_External_Entity
;
4898 -------------------------
4899 -- New_Internal_Entity --
4900 -------------------------
4902 function New_Internal_Entity
4903 (Kind
: Entity_Kind
;
4904 Scope_Id
: Entity_Id
;
4905 Sloc_Value
: Source_Ptr
;
4906 Id_Char
: Character) return Entity_Id
4908 N
: constant Entity_Id
:=
4909 Make_Defining_Identifier
(Sloc_Value
, New_Internal_Name
(Id_Char
));
4912 Set_Ekind
(N
, Kind
);
4913 Set_Is_Internal
(N
, True);
4914 Append_Entity
(N
, Scope_Id
);
4916 if Kind
in Type_Kind
then
4917 Init_Size_Align
(N
);
4921 end New_Internal_Entity
;
4927 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
4931 -- If we are pointing at a positional parameter, it is a member of
4932 -- a node list (the list of parameters), and the next parameter
4933 -- is the next node on the list, unless we hit a parameter
4934 -- association, in which case we shift to using the chain whose
4935 -- head is the First_Named_Actual in the parent, and then is
4936 -- threaded using the Next_Named_Actual of the Parameter_Association.
4937 -- All this fiddling is because the original node list is in the
4938 -- textual call order, and what we need is the declaration order.
4940 if Is_List_Member
(Actual_Id
) then
4941 N
:= Next
(Actual_Id
);
4943 if Nkind
(N
) = N_Parameter_Association
then
4944 return First_Named_Actual
(Parent
(Actual_Id
));
4950 return Next_Named_Actual
(Parent
(Actual_Id
));
4954 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
4956 Actual_Id
:= Next_Actual
(Actual_Id
);
4959 -----------------------
4960 -- Normalize_Actuals --
4961 -----------------------
4963 -- Chain actuals according to formals of subprogram. If there are
4964 -- no named associations, the chain is simply the list of Parameter
4965 -- Associations, since the order is the same as the declaration order.
4966 -- If there are named associations, then the First_Named_Actual field
4967 -- in the N_Procedure_Call_Statement node or N_Function_Call node
4968 -- points to the Parameter_Association node for the parameter that
4969 -- comes first in declaration order. The remaining named parameters
4970 -- are then chained in declaration order using Next_Named_Actual.
4972 -- This routine also verifies that the number of actuals is compatible
4973 -- with the number and default values of formals, but performs no type
4974 -- checking (type checking is done by the caller).
4976 -- If the matching succeeds, Success is set to True, and the caller
4977 -- proceeds with type-checking. If the match is unsuccessful, then
4978 -- Success is set to False, and the caller attempts a different
4979 -- interpretation, if there is one.
4981 -- If the flag Report is on, the call is not overloaded, and a failure
4982 -- to match can be reported here, rather than in the caller.
4984 procedure Normalize_Actuals
4988 Success
: out Boolean)
4990 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
4991 Actual
: Node_Id
:= Empty
;
4993 Last
: Node_Id
:= Empty
;
4994 First_Named
: Node_Id
:= Empty
;
4997 Formals_To_Match
: Integer := 0;
4998 Actuals_To_Match
: Integer := 0;
5000 procedure Chain
(A
: Node_Id
);
5001 -- Add named actual at the proper place in the list, using the
5002 -- Next_Named_Actual link.
5004 function Reporting
return Boolean;
5005 -- Determines if an error is to be reported. To report an error, we
5006 -- need Report to be True, and also we do not report errors caused
5007 -- by calls to init procs that occur within other init procs. Such
5008 -- errors must always be cascaded errors, since if all the types are
5009 -- declared correctly, the compiler will certainly build decent calls!
5015 procedure Chain
(A
: Node_Id
) is
5019 -- Call node points to first actual in list
5021 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
5024 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
5028 Set_Next_Named_Actual
(Last
, Empty
);
5035 function Reporting
return Boolean is
5040 elsif not Within_Init_Proc
then
5043 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
5051 -- Start of processing for Normalize_Actuals
5054 if Is_Access_Type
(S
) then
5056 -- The name in the call is a function call that returns an access
5057 -- to subprogram. The designated type has the list of formals.
5059 Formal
:= First_Formal
(Designated_Type
(S
));
5061 Formal
:= First_Formal
(S
);
5064 while Present
(Formal
) loop
5065 Formals_To_Match
:= Formals_To_Match
+ 1;
5066 Next_Formal
(Formal
);
5069 -- Find if there is a named association, and verify that no positional
5070 -- associations appear after named ones.
5072 if Present
(Actuals
) then
5073 Actual
:= First
(Actuals
);
5076 while Present
(Actual
)
5077 and then Nkind
(Actual
) /= N_Parameter_Association
5079 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5083 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
5085 -- Most common case: positional notation, no defaults
5090 elsif Actuals_To_Match
> Formals_To_Match
then
5092 -- Too many actuals: will not work
5095 if Is_Entity_Name
(Name
(N
)) then
5096 Error_Msg_N
("too many arguments in call to&", Name
(N
));
5098 Error_Msg_N
("too many arguments in call", N
);
5106 First_Named
:= Actual
;
5108 while Present
(Actual
) loop
5109 if Nkind
(Actual
) /= N_Parameter_Association
then
5111 ("positional parameters not allowed after named ones", Actual
);
5116 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5122 if Present
(Actuals
) then
5123 Actual
:= First
(Actuals
);
5126 Formal
:= First_Formal
(S
);
5127 while Present
(Formal
) loop
5129 -- Match the formals in order. If the corresponding actual
5130 -- is positional, nothing to do. Else scan the list of named
5131 -- actuals to find the one with the right name.
5134 and then Nkind
(Actual
) /= N_Parameter_Association
5137 Actuals_To_Match
:= Actuals_To_Match
- 1;
5138 Formals_To_Match
:= Formals_To_Match
- 1;
5141 -- For named parameters, search the list of actuals to find
5142 -- one that matches the next formal name.
5144 Actual
:= First_Named
;
5147 while Present
(Actual
) loop
5148 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
5151 Actuals_To_Match
:= Actuals_To_Match
- 1;
5152 Formals_To_Match
:= Formals_To_Match
- 1;
5160 if Ekind
(Formal
) /= E_In_Parameter
5161 or else No
(Default_Value
(Formal
))
5164 if (Comes_From_Source
(S
)
5165 or else Sloc
(S
) = Standard_Location
)
5166 and then Is_Overloadable
(S
)
5170 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
5172 (Nkind
(Parent
(N
)) = N_Function_Call
5174 Nkind
(Parent
(N
)) = N_Parameter_Association
))
5175 and then Ekind
(S
) /= E_Function
5177 Set_Etype
(N
, Etype
(S
));
5179 Error_Msg_Name_1
:= Chars
(S
);
5180 Error_Msg_Sloc
:= Sloc
(S
);
5182 ("missing argument for parameter & " &
5183 "in call to % declared #", N
, Formal
);
5186 elsif Is_Overloadable
(S
) then
5187 Error_Msg_Name_1
:= Chars
(S
);
5189 -- Point to type derivation that generated the
5192 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
5195 ("missing argument for parameter & " &
5196 "in call to % (inherited) #", N
, Formal
);
5200 ("missing argument for parameter &", N
, Formal
);
5208 Formals_To_Match
:= Formals_To_Match
- 1;
5213 Next_Formal
(Formal
);
5216 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
5223 -- Find some superfluous named actual that did not get
5224 -- attached to the list of associations.
5226 Actual
:= First
(Actuals
);
5228 while Present
(Actual
) loop
5229 if Nkind
(Actual
) = N_Parameter_Association
5230 and then Actual
/= Last
5231 and then No
(Next_Named_Actual
(Actual
))
5233 Error_Msg_N
("unmatched actual & in call",
5234 Selector_Name
(Actual
));
5245 end Normalize_Actuals
;
5247 --------------------------------
5248 -- Note_Possible_Modification --
5249 --------------------------------
5251 procedure Note_Possible_Modification
(N
: Node_Id
) is
5252 Modification_Comes_From_Source
: constant Boolean :=
5253 Comes_From_Source
(Parent
(N
));
5259 -- Loop to find referenced entity, if there is one
5266 if Is_Entity_Name
(Exp
) then
5267 Ent
:= Entity
(Exp
);
5269 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
5271 P
: constant Node_Id
:= Prefix
(Exp
);
5274 if Nkind
(P
) = N_Selected_Component
5276 Entry_Formal
(Entity
(Selector_Name
(P
))))
5278 -- Case of a reference to an entry formal
5280 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
5282 elsif Nkind
(P
) = N_Identifier
5283 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
5284 and then Present
(Expression
(Parent
(Entity
(P
))))
5285 and then Nkind
(Expression
(Parent
(Entity
(P
))))
5288 -- Case of a reference to a value on which
5289 -- side effects have been removed.
5291 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
5299 elsif Nkind
(Exp
) = N_Type_Conversion
5300 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
5302 Exp
:= Expression
(Exp
);
5304 elsif Nkind
(Exp
) = N_Slice
5305 or else Nkind
(Exp
) = N_Indexed_Component
5306 or else Nkind
(Exp
) = N_Selected_Component
5308 Exp
:= Prefix
(Exp
);
5315 -- Now look for entity being referenced
5317 if Present
(Ent
) then
5319 if Is_Object
(Ent
) then
5320 if Comes_From_Source
(Exp
)
5321 or else Modification_Comes_From_Source
5323 Set_Never_Set_In_Source
(Ent
, False);
5326 Set_Is_True_Constant
(Ent
, False);
5327 Set_Current_Value
(Ent
, Empty
);
5329 if not Can_Never_Be_Null
(Ent
) then
5330 Set_Is_Known_Non_Null
(Ent
, False);
5333 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
5334 and then Present
(Renamed_Object
(Ent
))
5336 Exp
:= Renamed_Object
(Ent
);
5340 -- Generate a reference only if the assignment comes from
5341 -- source. This excludes, for example, calls to a dispatching
5342 -- assignment operation when the left-hand side is tagged.
5344 if Modification_Comes_From_Source
then
5345 Generate_Reference
(Ent
, Exp
, 'm');
5353 end Note_Possible_Modification
;
5355 -------------------------
5356 -- Object_Access_Level --
5357 -------------------------
5359 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
5362 -- Returns the static accessibility level of the view denoted
5363 -- by Obj. Note that the value returned is the result of a
5364 -- call to Scope_Depth. Only scope depths associated with
5365 -- dynamic scopes can actually be returned. Since only
5366 -- relative levels matter for accessibility checking, the fact
5367 -- that the distance between successive levels of accessibility
5368 -- is not always one is immaterial (invariant: if level(E2) is
5369 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
5372 if Is_Entity_Name
(Obj
) then
5375 -- If E is a type then it denotes a current instance.
5376 -- For this case we add one to the normal accessibility
5377 -- level of the type to ensure that current instances
5378 -- are treated as always being deeper than than the level
5379 -- of any visible named access type (see 3.10.2(21)).
5382 return Type_Access_Level
(E
) + 1;
5384 elsif Present
(Renamed_Object
(E
)) then
5385 return Object_Access_Level
(Renamed_Object
(E
));
5387 -- Similarly, if E is a component of the current instance of a
5388 -- protected type, any instance of it is assumed to be at a deeper
5389 -- level than the type. For a protected object (whose type is an
5390 -- anonymous protected type) its components are at the same level
5391 -- as the type itself.
5393 elsif not Is_Overloadable
(E
)
5394 and then Ekind
(Scope
(E
)) = E_Protected_Type
5395 and then Comes_From_Source
(Scope
(E
))
5397 return Type_Access_Level
(Scope
(E
)) + 1;
5400 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
5403 elsif Nkind
(Obj
) = N_Selected_Component
then
5404 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5405 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5407 return Object_Access_Level
(Prefix
(Obj
));
5410 elsif Nkind
(Obj
) = N_Indexed_Component
then
5411 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5412 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5414 return Object_Access_Level
(Prefix
(Obj
));
5417 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
5419 -- If the prefix is a selected access discriminant then
5420 -- we make a recursive call on the prefix, which will
5421 -- in turn check the level of the prefix object of
5422 -- the selected discriminant.
5424 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
5425 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
5427 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
5429 return Object_Access_Level
(Prefix
(Obj
));
5431 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5434 elsif Nkind
(Obj
) = N_Type_Conversion
5435 or else Nkind
(Obj
) = N_Unchecked_Type_Conversion
5437 return Object_Access_Level
(Expression
(Obj
));
5439 -- Function results are objects, so we get either the access level
5440 -- of the function or, in the case of an indirect call, the level of
5441 -- of the access-to-subprogram type.
5443 elsif Nkind
(Obj
) = N_Function_Call
then
5444 if Is_Entity_Name
(Name
(Obj
)) then
5445 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
5447 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
5450 -- For convenience we handle qualified expressions, even though
5451 -- they aren't technically object names.
5453 elsif Nkind
(Obj
) = N_Qualified_Expression
then
5454 return Object_Access_Level
(Expression
(Obj
));
5456 -- Otherwise return the scope level of Standard.
5457 -- (If there are cases that fall through
5458 -- to this point they will be treated as
5459 -- having global accessibility for now. ???)
5462 return Scope_Depth
(Standard_Standard
);
5464 end Object_Access_Level
;
5466 -----------------------
5467 -- Private_Component --
5468 -----------------------
5470 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
5471 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
5473 function Trace_Components
5475 Check
: Boolean) return Entity_Id
;
5476 -- Recursive function that does the work, and checks against circular
5477 -- definition for each subcomponent type.
5479 ----------------------
5480 -- Trace_Components --
5481 ----------------------
5483 function Trace_Components
5485 Check
: Boolean) return Entity_Id
5487 Btype
: constant Entity_Id
:= Base_Type
(T
);
5488 Component
: Entity_Id
;
5490 Candidate
: Entity_Id
:= Empty
;
5493 if Check
and then Btype
= Ancestor
then
5494 Error_Msg_N
("circular type definition", Type_Id
);
5498 if Is_Private_Type
(Btype
)
5499 and then not Is_Generic_Type
(Btype
)
5501 if Present
(Full_View
(Btype
))
5502 and then Is_Record_Type
(Full_View
(Btype
))
5503 and then not Is_Frozen
(Btype
)
5505 -- To indicate that the ancestor depends on a private type,
5506 -- the current Btype is sufficient. However, to check for
5507 -- circular definition we must recurse on the full view.
5509 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
5511 if Candidate
= Any_Type
then
5521 elsif Is_Array_Type
(Btype
) then
5522 return Trace_Components
(Component_Type
(Btype
), True);
5524 elsif Is_Record_Type
(Btype
) then
5525 Component
:= First_Entity
(Btype
);
5526 while Present
(Component
) loop
5528 -- Skip anonymous types generated by constrained components
5530 if not Is_Type
(Component
) then
5531 P
:= Trace_Components
(Etype
(Component
), True);
5534 if P
= Any_Type
then
5542 Next_Entity
(Component
);
5550 end Trace_Components
;
5552 -- Start of processing for Private_Component
5555 return Trace_Components
(Type_Id
, False);
5556 end Private_Component
;
5558 -----------------------
5559 -- Process_End_Label --
5560 -----------------------
5562 procedure Process_End_Label
5570 Label_Ref
: Boolean;
5571 -- Set True if reference to end label itself is required
5574 -- Gets set to the operator symbol or identifier that references
5575 -- the entity Ent. For the child unit case, this is the identifier
5576 -- from the designator. For other cases, this is simply Endl.
5578 procedure Generate_Parent_Ref
(N
: Node_Id
);
5579 -- N is an identifier node that appears as a parent unit reference
5580 -- in the case where Ent is a child unit. This procedure generates
5581 -- an appropriate cross-reference entry.
5583 -------------------------
5584 -- Generate_Parent_Ref --
5585 -------------------------
5587 procedure Generate_Parent_Ref
(N
: Node_Id
) is
5588 Parent_Ent
: Entity_Id
;
5591 -- Search up scope stack. The reason we do this is that normal
5592 -- visibility analysis would not work for two reasons. First in
5593 -- some subunit cases, the entry for the parent unit may not be
5594 -- visible, and in any case there can be a local entity that
5595 -- hides the scope entity.
5597 Parent_Ent
:= Current_Scope
;
5598 while Present
(Parent_Ent
) loop
5599 if Chars
(Parent_Ent
) = Chars
(N
) then
5601 -- Generate the reference. We do NOT consider this as a
5602 -- reference for unreferenced symbol purposes, but we do
5603 -- force a cross-reference even if the end line does not
5604 -- come from source (the caller already generated the
5605 -- appropriate Typ for this situation).
5608 (Parent_Ent
, N
, 'r', Set_Ref
=> False, Force
=> True);
5609 Style
.Check_Identifier
(N
, Parent_Ent
);
5613 Parent_Ent
:= Scope
(Parent_Ent
);
5616 -- Fall through means entity was not found -- that's odd, but
5617 -- the appropriate thing is simply to ignore and not generate
5618 -- any cross-reference for this entry.
5621 end Generate_Parent_Ref
;
5623 -- Start of processing for Process_End_Label
5626 -- If no node, ignore. This happens in some error situations,
5627 -- and also for some internally generated structures where no
5628 -- end label references are required in any case.
5634 -- Nothing to do if no End_Label, happens for internally generated
5635 -- constructs where we don't want an end label reference anyway.
5636 -- Also nothing to do if Endl is a string literal, which means
5637 -- there was some prior error (bad operator symbol)
5639 Endl
:= End_Label
(N
);
5641 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
5645 -- Reference node is not in extended main source unit
5647 if not In_Extended_Main_Source_Unit
(N
) then
5649 -- Generally we do not collect references except for the
5650 -- extended main source unit. The one exception is the 'e'
5651 -- entry for a package spec, where it is useful for a client
5652 -- to have the ending information to define scopes.
5660 -- For this case, we can ignore any parent references,
5661 -- but we need the package name itself for the 'e' entry.
5663 if Nkind
(Endl
) = N_Designator
then
5664 Endl
:= Identifier
(Endl
);
5668 -- Reference is in extended main source unit
5673 -- For designator, generate references for the parent entries
5675 if Nkind
(Endl
) = N_Designator
then
5677 -- Generate references for the prefix if the END line comes
5678 -- from source (otherwise we do not need these references)
5680 if Comes_From_Source
(Endl
) then
5682 while Nkind
(Nam
) = N_Selected_Component
loop
5683 Generate_Parent_Ref
(Selector_Name
(Nam
));
5684 Nam
:= Prefix
(Nam
);
5687 Generate_Parent_Ref
(Nam
);
5690 Endl
:= Identifier
(Endl
);
5694 -- If the end label is not for the given entity, then either we have
5695 -- some previous error, or this is a generic instantiation for which
5696 -- we do not need to make a cross-reference in this case anyway. In
5697 -- either case we simply ignore the call.
5699 if Chars
(Ent
) /= Chars
(Endl
) then
5703 -- If label was really there, then generate a normal reference
5704 -- and then adjust the location in the end label to point past
5705 -- the name (which should almost always be the semicolon).
5709 if Comes_From_Source
(Endl
) then
5711 -- If a label reference is required, then do the style check
5712 -- and generate an l-type cross-reference entry for the label
5716 Style
.Check_Identifier
(Endl
, Ent
);
5718 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
5721 -- Set the location to point past the label (normally this will
5722 -- mean the semicolon immediately following the label). This is
5723 -- done for the sake of the 'e' or 't' entry generated below.
5725 Get_Decoded_Name_String
(Chars
(Endl
));
5726 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
5729 -- Now generate the e/t reference
5731 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
5733 -- Restore Sloc, in case modified above, since we have an identifier
5734 -- and the normal Sloc should be left set in the tree.
5736 Set_Sloc
(Endl
, Loc
);
5737 end Process_End_Label
;
5743 -- We do the conversion to get the value of the real string by using
5744 -- the scanner, see Sinput for details on use of the internal source
5745 -- buffer for scanning internal strings.
5747 function Real_Convert
(S
: String) return Node_Id
is
5748 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
5752 Source
:= Internal_Source_Ptr
;
5755 for J
in S
'Range loop
5756 Source
(Source_Ptr
(J
)) := S
(J
);
5759 Source
(S
'Length + 1) := EOF
;
5761 if Source
(Scan_Ptr
) = '-' then
5763 Scan_Ptr
:= Scan_Ptr
+ 1;
5771 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
5778 ---------------------
5779 -- Rep_To_Pos_Flag --
5780 ---------------------
5782 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
5784 return New_Occurrence_Of
5785 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
5786 end Rep_To_Pos_Flag
;
5788 --------------------
5789 -- Require_Entity --
5790 --------------------
5792 procedure Require_Entity
(N
: Node_Id
) is
5794 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
5795 if Total_Errors_Detected
/= 0 then
5796 Set_Entity
(N
, Any_Id
);
5798 raise Program_Error
;
5803 ------------------------------
5804 -- Requires_Transient_Scope --
5805 ------------------------------
5807 -- A transient scope is required when variable-sized temporaries are
5808 -- allocated in the primary or secondary stack, or when finalization
5809 -- actions must be generated before the next instruction.
5811 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
5812 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
5814 -- Start of processing for Requires_Transient_Scope
5817 -- This is a private type which is not completed yet. This can only
5818 -- happen in a default expression (of a formal parameter or of a
5819 -- record component). Do not expand transient scope in this case
5824 -- Do not expand transient scope for non-existent procedure return
5826 elsif Typ
= Standard_Void_Type
then
5829 -- Elementary types do not require a transient scope
5831 elsif Is_Elementary_Type
(Typ
) then
5834 -- Generally, indefinite subtypes require a transient scope, since the
5835 -- back end cannot generate temporaries, since this is not a valid type
5836 -- for declaring an object. It might be possible to relax this in the
5837 -- future, e.g. by declaring the maximum possible space for the type.
5839 elsif Is_Indefinite_Subtype
(Typ
) then
5842 -- Functions returning tagged types may dispatch on result so their
5843 -- returned value is allocated on the secondary stack. Controlled
5844 -- type temporaries need finalization.
5846 elsif Is_Tagged_Type
(Typ
)
5847 or else Has_Controlled_Component
(Typ
)
5853 elsif Is_Record_Type
(Typ
) then
5855 -- In GCC 2, discriminated records always require a transient
5856 -- scope because the back end otherwise tries to allocate a
5857 -- variable length temporary for the particular variant.
5859 if Opt
.GCC_Version
= 2
5860 and then Has_Discriminants
(Typ
)
5864 -- For GCC 3, or for a non-discriminated record in GCC 2, we are
5865 -- OK if none of the component types requires a transient scope.
5866 -- Note that we already know that this is a definite type (i.e.
5867 -- has discriminant defaults if it is a discriminated record).
5873 Comp
:= First_Entity
(Typ
);
5874 while Present
(Comp
) loop
5875 if Requires_Transient_Scope
(Etype
(Comp
)) then
5886 -- String literal types never require transient scope
5888 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
5891 -- Array type. Note that we already know that this is a constrained
5892 -- array, since unconstrained arrays will fail the indefinite test.
5894 elsif Is_Array_Type
(Typ
) then
5896 -- If component type requires a transient scope, the array does too
5898 if Requires_Transient_Scope
(Component_Type
(Typ
)) then
5901 -- Otherwise, we only need a transient scope if the size is not
5902 -- known at compile time.
5905 return not Size_Known_At_Compile_Time
(Typ
);
5908 -- All other cases do not require a transient scope
5913 end Requires_Transient_Scope
;
5915 --------------------------
5916 -- Reset_Analyzed_Flags --
5917 --------------------------
5919 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
5921 function Clear_Analyzed
5922 (N
: Node_Id
) return Traverse_Result
;
5923 -- Function used to reset Analyzed flags in tree. Note that we do
5924 -- not reset Analyzed flags in entities, since there is no need to
5925 -- renalalyze entities, and indeed, it is wrong to do so, since it
5926 -- can result in generating auxiliary stuff more than once.
5928 --------------------
5929 -- Clear_Analyzed --
5930 --------------------
5932 function Clear_Analyzed
5933 (N
: Node_Id
) return Traverse_Result
5936 if not Has_Extension
(N
) then
5937 Set_Analyzed
(N
, False);
5943 function Reset_Analyzed
is
5944 new Traverse_Func
(Clear_Analyzed
);
5946 Discard
: Traverse_Result
;
5947 pragma Warnings
(Off
, Discard
);
5949 -- Start of processing for Reset_Analyzed_Flags
5952 Discard
:= Reset_Analyzed
(N
);
5953 end Reset_Analyzed_Flags
;
5955 ---------------------------
5956 -- Safe_To_Capture_Value --
5957 ---------------------------
5959 function Safe_To_Capture_Value
5961 Ent
: Entity_Id
) return Boolean
5964 -- The only entities for which we track constant values are variables,
5965 -- out parameters and in out parameters, so check if we have this case.
5967 if Ekind
(Ent
) /= E_Variable
5969 Ekind
(Ent
) /= E_Out_Parameter
5971 Ekind
(Ent
) /= E_In_Out_Parameter
5976 -- Skip volatile and aliased variables, since funny things might
5977 -- be going on in these cases which we cannot necessarily track.
5979 if Treat_As_Volatile
(Ent
) or else Is_Aliased
(Ent
) then
5983 -- OK, all above conditions are met. We also require that the scope
5984 -- of the reference be the same as the scope of the entity, not
5985 -- counting packages and blocks.
5988 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
5989 R_Scope
: Entity_Id
;
5992 R_Scope
:= Current_Scope
;
5993 while R_Scope
/= Standard_Standard
loop
5994 exit when R_Scope
= E_Scope
;
5996 if Ekind
(R_Scope
) /= E_Package
5998 Ekind
(R_Scope
) /= E_Block
6002 R_Scope
:= Scope
(R_Scope
);
6007 -- We also require that the reference does not appear in a context
6008 -- where it is not sure to be executed (i.e. a conditional context
6009 -- or an exception handler).
6016 while Present
(P
) loop
6017 if Nkind
(P
) = N_If_Statement
6019 Nkind
(P
) = N_Case_Statement
6021 Nkind
(P
) = N_Exception_Handler
6023 Nkind
(P
) = N_Selective_Accept
6025 Nkind
(P
) = N_Conditional_Entry_Call
6027 Nkind
(P
) = N_Timed_Entry_Call
6029 Nkind
(P
) = N_Asynchronous_Select
6038 -- OK, looks safe to set value
6041 end Safe_To_Capture_Value
;
6047 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
6048 K1
: constant Node_Kind
:= Nkind
(N1
);
6049 K2
: constant Node_Kind
:= Nkind
(N2
);
6052 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
6053 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
6055 return Chars
(N1
) = Chars
(N2
);
6057 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
6058 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
6060 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
6061 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
6072 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
6077 elsif not Is_Constrained
(T1
)
6078 and then not Is_Constrained
(T2
)
6079 and then Base_Type
(T1
) = Base_Type
(T2
)
6083 -- For now don't bother with case of identical constraints, to be
6084 -- fiddled with later on perhaps (this is only used for optimization
6085 -- purposes, so it is not critical to do a best possible job)
6092 ------------------------
6093 -- Scope_Is_Transient --
6094 ------------------------
6096 function Scope_Is_Transient
return Boolean is
6098 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
6099 end Scope_Is_Transient
;
6105 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6110 while Scop
/= Standard_Standard
loop
6111 Scop
:= Scope
(Scop
);
6113 if Scop
= Scope2
then
6121 --------------------------
6122 -- Scope_Within_Or_Same --
6123 --------------------------
6125 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6130 while Scop
/= Standard_Standard
loop
6131 if Scop
= Scope2
then
6134 Scop
:= Scope
(Scop
);
6139 end Scope_Within_Or_Same
;
6141 ------------------------
6142 -- Set_Current_Entity --
6143 ------------------------
6145 -- The given entity is to be set as the currently visible definition
6146 -- of its associated name (i.e. the Node_Id associated with its name).
6147 -- All we have to do is to get the name from the identifier, and
6148 -- then set the associated Node_Id to point to the given entity.
6150 procedure Set_Current_Entity
(E
: Entity_Id
) is
6152 Set_Name_Entity_Id
(Chars
(E
), E
);
6153 end Set_Current_Entity
;
6155 ---------------------------------
6156 -- Set_Entity_With_Style_Check --
6157 ---------------------------------
6159 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
6160 Val_Actual
: Entity_Id
;
6164 Set_Entity
(N
, Val
);
6167 and then not Suppress_Style_Checks
(Val
)
6168 and then not In_Instance
6170 if Nkind
(N
) = N_Identifier
then
6173 elsif Nkind
(N
) = N_Expanded_Name
then
6174 Nod
:= Selector_Name
(N
);
6182 -- A special situation arises for derived operations, where we want
6183 -- to do the check against the parent (since the Sloc of the derived
6184 -- operation points to the derived type declaration itself).
6186 while not Comes_From_Source
(Val_Actual
)
6187 and then Nkind
(Val_Actual
) in N_Entity
6188 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
6189 or else Is_Subprogram
(Val_Actual
)
6190 or else Is_Generic_Subprogram
(Val_Actual
))
6191 and then Present
(Alias
(Val_Actual
))
6193 Val_Actual
:= Alias
(Val_Actual
);
6196 -- Renaming declarations for generic actuals do not come from source,
6197 -- and have a different name from that of the entity they rename, so
6198 -- there is no style check to perform here.
6200 if Chars
(Nod
) = Chars
(Val_Actual
) then
6201 Style
.Check_Identifier
(Nod
, Val_Actual
);
6205 Set_Entity
(N
, Val
);
6206 end Set_Entity_With_Style_Check
;
6208 ------------------------
6209 -- Set_Name_Entity_Id --
6210 ------------------------
6212 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
6214 Set_Name_Table_Info
(Id
, Int
(Val
));
6215 end Set_Name_Entity_Id
;
6217 ---------------------
6218 -- Set_Next_Actual --
6219 ---------------------
6221 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
6223 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
6224 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
6226 end Set_Next_Actual
;
6228 -----------------------
6229 -- Set_Public_Status --
6230 -----------------------
6232 procedure Set_Public_Status
(Id
: Entity_Id
) is
6233 S
: constant Entity_Id
:= Current_Scope
;
6236 if S
= Standard_Standard
6237 or else (Is_Public
(S
)
6238 and then (Ekind
(S
) = E_Package
6239 or else Is_Record_Type
(S
)
6240 or else Ekind
(S
) = E_Void
))
6244 -- The bounds of an entry family declaration can generate object
6245 -- declarations that are visible to the back-end, e.g. in the
6246 -- the declaration of a composite type that contains tasks.
6249 and then Is_Concurrent_Type
(S
)
6250 and then not Has_Completion
(S
)
6251 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
6255 end Set_Public_Status
;
6257 ----------------------------
6258 -- Set_Scope_Is_Transient --
6259 ----------------------------
6261 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
6263 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
6264 end Set_Scope_Is_Transient
;
6270 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
6272 -- We copy Esize, but not RM_Size, since in general RM_Size is
6273 -- subtype specific and does not get inherited by all subtypes.
6275 Set_Esize
(T1
, Esize
(T2
));
6276 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
6278 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
6280 Is_Discrete_Or_Fixed_Point_Type
(T2
)
6282 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
6284 Set_Alignment
(T1
, Alignment
(T2
));
6287 --------------------
6288 -- Static_Integer --
6289 --------------------
6291 function Static_Integer
(N
: Node_Id
) return Uint
is
6293 Analyze_And_Resolve
(N
, Any_Integer
);
6296 or else Error_Posted
(N
)
6297 or else Etype
(N
) = Any_Type
6302 if Is_Static_Expression
(N
) then
6303 if not Raises_Constraint_Error
(N
) then
6304 return Expr_Value
(N
);
6309 elsif Etype
(N
) = Any_Type
then
6313 Flag_Non_Static_Expr
6314 ("static integer expression required here", N
);
6319 --------------------------
6320 -- Statically_Different --
6321 --------------------------
6323 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
6324 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
6325 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
6328 return Is_Entity_Name
(R1
)
6329 and then Is_Entity_Name
(R2
)
6330 and then Entity
(R1
) /= Entity
(R2
)
6331 and then not Is_Formal
(Entity
(R1
))
6332 and then not Is_Formal
(Entity
(R2
));
6333 end Statically_Different
;
6335 -----------------------------
6336 -- Subprogram_Access_Level --
6337 -----------------------------
6339 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
6341 if Present
(Alias
(Subp
)) then
6342 return Subprogram_Access_Level
(Alias
(Subp
));
6344 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
6346 end Subprogram_Access_Level
;
6352 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
6354 if Debug_Flag_W
then
6355 for J
in 0 .. Scope_Stack
.Last
loop
6360 Write_Name
(Chars
(E
));
6361 Write_Str
(" line ");
6362 Write_Int
(Int
(Get_Logical_Line_Number
(Sloc
(N
))));
6367 -----------------------
6368 -- Transfer_Entities --
6369 -----------------------
6371 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
6372 Ent
: Entity_Id
:= First_Entity
(From
);
6379 if (Last_Entity
(To
)) = Empty
then
6380 Set_First_Entity
(To
, Ent
);
6382 Set_Next_Entity
(Last_Entity
(To
), Ent
);
6385 Set_Last_Entity
(To
, Last_Entity
(From
));
6387 while Present
(Ent
) loop
6388 Set_Scope
(Ent
, To
);
6390 if not Is_Public
(Ent
) then
6391 Set_Public_Status
(Ent
);
6394 and then Ekind
(Ent
) = E_Record_Subtype
6397 -- The components of the propagated Itype must be public
6404 Comp
:= First_Entity
(Ent
);
6406 while Present
(Comp
) loop
6407 Set_Is_Public
(Comp
);
6417 Set_First_Entity
(From
, Empty
);
6418 Set_Last_Entity
(From
, Empty
);
6419 end Transfer_Entities
;
6421 -----------------------
6422 -- Type_Access_Level --
6423 -----------------------
6425 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
6429 -- If the type is an anonymous access type we treat it as being
6430 -- declared at the library level to ensure that names such as
6431 -- X.all'access don't fail static accessibility checks.
6433 -- Ada 2005 (AI-230): In case of anonymous access types that are
6434 -- component_definition or discriminants of a nonlimited type,
6435 -- the level is the same as that of the enclosing component type.
6437 Btyp
:= Base_Type
(Typ
);
6438 if Ekind
(Btyp
) in Access_Kind
then
6439 if Ekind
(Btyp
) = E_Anonymous_Access_Type
6440 and then not Is_Array_Type
(Scope
(Btyp
)) -- Ada 2005 (AI-230)
6441 and then Ekind
(Scope
(Btyp
)) /= E_Record_Type
-- Ada 2005 (AI-230)
6443 return Scope_Depth
(Standard_Standard
);
6446 Btyp
:= Root_Type
(Btyp
);
6449 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
6450 end Type_Access_Level
;
6452 --------------------------
6453 -- Unit_Declaration_Node --
6454 --------------------------
6456 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
6457 N
: Node_Id
:= Parent
(Unit_Id
);
6460 -- Predefined operators do not have a full function declaration
6462 if Ekind
(Unit_Id
) = E_Operator
then
6466 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
6467 and then Nkind
(N
) /= N_Formal_Package_Declaration
6468 and then Nkind
(N
) /= N_Formal_Subprogram_Declaration
6469 and then Nkind
(N
) /= N_Function_Instantiation
6470 and then Nkind
(N
) /= N_Generic_Package_Declaration
6471 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
6472 and then Nkind
(N
) /= N_Package_Declaration
6473 and then Nkind
(N
) /= N_Package_Body
6474 and then Nkind
(N
) /= N_Package_Instantiation
6475 and then Nkind
(N
) /= N_Package_Renaming_Declaration
6476 and then Nkind
(N
) /= N_Procedure_Instantiation
6477 and then Nkind
(N
) /= N_Protected_Body
6478 and then Nkind
(N
) /= N_Subprogram_Declaration
6479 and then Nkind
(N
) /= N_Subprogram_Body
6480 and then Nkind
(N
) /= N_Subprogram_Body_Stub
6481 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
6482 and then Nkind
(N
) /= N_Task_Body
6483 and then Nkind
(N
) /= N_Task_Type_Declaration
6484 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
6487 pragma Assert
(Present
(N
));
6491 end Unit_Declaration_Node
;
6493 ------------------------------
6494 -- Universal_Interpretation --
6495 ------------------------------
6497 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
6498 Index
: Interp_Index
;
6502 -- The argument may be a formal parameter of an operator or subprogram
6503 -- with multiple interpretations, or else an expression for an actual.
6505 if Nkind
(Opnd
) = N_Defining_Identifier
6506 or else not Is_Overloaded
(Opnd
)
6508 if Etype
(Opnd
) = Universal_Integer
6509 or else Etype
(Opnd
) = Universal_Real
6511 return Etype
(Opnd
);
6517 Get_First_Interp
(Opnd
, Index
, It
);
6519 while Present
(It
.Typ
) loop
6521 if It
.Typ
= Universal_Integer
6522 or else It
.Typ
= Universal_Real
6527 Get_Next_Interp
(Index
, It
);
6532 end Universal_Interpretation
;
6534 ----------------------
6535 -- Within_Init_Proc --
6536 ----------------------
6538 function Within_Init_Proc
return Boolean is
6543 while not Is_Overloadable
(S
) loop
6544 if S
= Standard_Standard
then
6551 return Is_Init_Proc
(S
);
6552 end Within_Init_Proc
;
6558 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
6559 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
6560 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
6562 function Has_One_Matching_Field
return Boolean;
6563 -- Determines whether Expec_Type is a record type with a single
6564 -- component or discriminant whose type matches the found type or
6565 -- is a one dimensional array whose component type matches the
6568 function Has_One_Matching_Field
return Boolean is
6572 if Is_Array_Type
(Expec_Type
)
6573 and then Number_Dimensions
(Expec_Type
) = 1
6575 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
6579 elsif not Is_Record_Type
(Expec_Type
) then
6583 E
:= First_Entity
(Expec_Type
);
6589 elsif (Ekind
(E
) /= E_Discriminant
6590 and then Ekind
(E
) /= E_Component
)
6591 or else (Chars
(E
) = Name_uTag
6592 or else Chars
(E
) = Name_uParent
)
6601 if not Covers
(Etype
(E
), Found_Type
) then
6604 elsif Present
(Next_Entity
(E
)) then
6611 end Has_One_Matching_Field
;
6613 -- Start of processing for Wrong_Type
6616 -- Don't output message if either type is Any_Type, or if a message
6617 -- has already been posted for this node. We need to do the latter
6618 -- check explicitly (it is ordinarily done in Errout), because we
6619 -- are using ! to force the output of the error messages.
6621 if Expec_Type
= Any_Type
6622 or else Found_Type
= Any_Type
6623 or else Error_Posted
(Expr
)
6627 -- In an instance, there is an ongoing problem with completion of
6628 -- type derived from private types. Their structure is what Gigi
6629 -- expects, but the Etype is the parent type rather than the
6630 -- derived private type itself. Do not flag error in this case. The
6631 -- private completion is an entity without a parent, like an Itype.
6632 -- Similarly, full and partial views may be incorrect in the instance.
6633 -- There is no simple way to insure that it is consistent ???
6635 elsif In_Instance
then
6637 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
6639 (Has_Private_Declaration
(Expected_Type
)
6640 or else Has_Private_Declaration
(Etype
(Expr
)))
6641 and then No
(Parent
(Expected_Type
))
6647 -- An interesting special check. If the expression is parenthesized
6648 -- and its type corresponds to the type of the sole component of the
6649 -- expected record type, or to the component type of the expected one
6650 -- dimensional array type, then assume we have a bad aggregate attempt.
6652 if Nkind
(Expr
) in N_Subexpr
6653 and then Paren_Count
(Expr
) /= 0
6654 and then Has_One_Matching_Field
6656 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
6658 -- Another special check, if we are looking for a pool-specific access
6659 -- type and we found an E_Access_Attribute_Type, then we have the case
6660 -- of an Access attribute being used in a context which needs a pool-
6661 -- specific type, which is never allowed. The one extra check we make
6662 -- is that the expected designated type covers the Found_Type.
6664 elsif Is_Access_Type
(Expec_Type
)
6665 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
6666 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
6667 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
6669 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
6671 Error_Msg_N
("result must be general access type!", Expr
);
6672 Error_Msg_NE
("add ALL to }!", Expr
, Expec_Type
);
6674 -- If the expected type is an anonymous access type, as for access
6675 -- parameters and discriminants, the error is on the designated types.
6677 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
6678 if Comes_From_Source
(Expec_Type
) then
6679 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
6682 ("expected an access type with designated}",
6683 Expr
, Designated_Type
(Expec_Type
));
6686 if Is_Access_Type
(Found_Type
)
6687 and then not Comes_From_Source
(Found_Type
)
6690 ("found an access type with designated}!",
6691 Expr
, Designated_Type
(Found_Type
));
6693 if From_With_Type
(Found_Type
) then
6694 Error_Msg_NE
("found incomplete}!", Expr
, Found_Type
);
6696 ("\possibly missing with_clause on&", Expr
,
6697 Scope
(Found_Type
));
6699 Error_Msg_NE
("found}!", Expr
, Found_Type
);
6703 -- Normal case of one type found, some other type expected
6706 -- If the names of the two types are the same, see if some
6707 -- number of levels of qualification will help. Don't try
6708 -- more than three levels, and if we get to standard, it's
6709 -- no use (and probably represents an error in the compiler)
6710 -- Also do not bother with internal scope names.
6713 Expec_Scope
: Entity_Id
;
6714 Found_Scope
: Entity_Id
;
6717 Expec_Scope
:= Expec_Type
;
6718 Found_Scope
:= Found_Type
;
6720 for Levels
in Int
range 0 .. 3 loop
6721 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
6722 Error_Msg_Qual_Level
:= Levels
;
6726 Expec_Scope
:= Scope
(Expec_Scope
);
6727 Found_Scope
:= Scope
(Found_Scope
);
6729 exit when Expec_Scope
= Standard_Standard
6731 Found_Scope
= Standard_Standard
6733 not Comes_From_Source
(Expec_Scope
)
6735 not Comes_From_Source
(Found_Scope
);
6739 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
6741 if Is_Entity_Name
(Expr
)
6742 and then Is_Package
(Entity
(Expr
))
6744 Error_Msg_N
("found package name!", Expr
);
6746 elsif Is_Entity_Name
(Expr
)
6748 (Ekind
(Entity
(Expr
)) = E_Procedure
6750 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
6752 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
6754 ("found procedure name, possibly missing Access attribute!",
6757 Error_Msg_N
("found procedure name instead of function!", Expr
);
6760 elsif Nkind
(Expr
) = N_Function_Call
6761 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
6762 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
6763 and then No
(Parameter_Associations
(Expr
))
6766 ("found function name, possibly missing Access attribute!",
6769 -- Catch common error: a prefix or infix operator which is not
6770 -- directly visible because the type isn't.
6772 elsif Nkind
(Expr
) in N_Op
6773 and then Is_Overloaded
(Expr
)
6774 and then not Is_Immediately_Visible
(Expec_Type
)
6775 and then not Is_Potentially_Use_Visible
(Expec_Type
)
6776 and then not In_Use
(Expec_Type
)
6777 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
6780 "operator of the type is not directly visible!", Expr
);
6782 elsif Ekind
(Found_Type
) = E_Void
6783 and then Present
(Parent
(Found_Type
))
6784 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
6786 Error_Msg_NE
("found premature usage of}!", Expr
, Found_Type
);
6789 Error_Msg_NE
("found}!", Expr
, Found_Type
);
6792 Error_Msg_Qual_Level
:= 0;