1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 Restrict
; use Restrict
;
45 with Rident
; use Rident
;
46 with Rtsfind
; use Rtsfind
;
47 with Scans
; use Scans
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Eval
; use Sem_Eval
;
52 with Sem_Res
; use Sem_Res
;
53 with Sem_Type
; use Sem_Type
;
54 with Sinfo
; use Sinfo
;
55 with Sinput
; use Sinput
;
56 with Snames
; use Snames
;
57 with Stand
; use Stand
;
59 with Stringt
; use Stringt
;
60 with Targparm
; use Targparm
;
61 with Tbuild
; use Tbuild
;
62 with Ttypes
; use Ttypes
;
63 with Uname
; use Uname
;
65 package body Sem_Util
is
67 -----------------------
68 -- Local Subprograms --
69 -----------------------
71 function Build_Component_Subtype
74 T
: Entity_Id
) return Node_Id
;
75 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
76 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
77 -- Loc is the source location, T is the original subtype.
79 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
80 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
81 -- with discriminants whose default values are static, examine only the
82 -- components in the selected variant to determine whether all of them
85 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
86 -- T is a derived tagged type. Check whether the type extension is null.
87 -- If the parent type is fully initialized, T can be treated as such.
89 --------------------------------
90 -- Add_Access_Type_To_Process --
91 --------------------------------
93 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
97 Ensure_Freeze_Node
(E
);
98 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
102 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
106 end Add_Access_Type_To_Process
;
108 -----------------------
109 -- Alignment_In_Bits --
110 -----------------------
112 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
114 return Alignment
(E
) * System_Storage_Unit
;
115 end Alignment_In_Bits
;
117 -----------------------------------------
118 -- Apply_Compile_Time_Constraint_Error --
119 -----------------------------------------
121 procedure Apply_Compile_Time_Constraint_Error
124 Reason
: RT_Exception_Code
;
125 Ent
: Entity_Id
:= Empty
;
126 Typ
: Entity_Id
:= Empty
;
127 Loc
: Source_Ptr
:= No_Location
;
128 Rep
: Boolean := True;
129 Warn
: Boolean := False)
131 Stat
: constant Boolean := Is_Static_Expression
(N
);
142 Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
148 -- Now we replace the node by an N_Raise_Constraint_Error node
149 -- This does not need reanalyzing, so set it as analyzed now.
152 Make_Raise_Constraint_Error
(Sloc
(N
),
154 Set_Analyzed
(N
, True);
156 Set_Raises_Constraint_Error
(N
);
158 -- If the original expression was marked as static, the result is
159 -- still marked as static, but the Raises_Constraint_Error flag is
160 -- always set so that further static evaluation is not attempted.
163 Set_Is_Static_Expression
(N
);
165 end Apply_Compile_Time_Constraint_Error
;
167 --------------------------
168 -- Build_Actual_Subtype --
169 --------------------------
171 function Build_Actual_Subtype
173 N
: Node_Or_Entity_Id
) return Node_Id
177 Loc
: constant Source_Ptr
:= Sloc
(N
);
178 Constraints
: List_Id
;
184 Disc_Type
: Entity_Id
;
187 if Nkind
(N
) = N_Defining_Identifier
then
188 Obj
:= New_Reference_To
(N
, Loc
);
193 if Is_Array_Type
(T
) then
194 Constraints
:= New_List
;
196 for J
in 1 .. Number_Dimensions
(T
) loop
198 -- Build an array subtype declaration with the nominal
199 -- subtype and the bounds of the actual. Add the declaration
200 -- in front of the local declarations for the subprogram, for
201 -- analysis before any reference to the formal in the body.
204 Make_Attribute_Reference
(Loc
,
206 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
207 Attribute_Name
=> Name_First
,
208 Expressions
=> New_List
(
209 Make_Integer_Literal
(Loc
, J
)));
212 Make_Attribute_Reference
(Loc
,
214 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
215 Attribute_Name
=> Name_Last
,
216 Expressions
=> New_List
(
217 Make_Integer_Literal
(Loc
, J
)));
219 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
222 -- If the type has unknown discriminants there is no constrained
223 -- subtype to build. This is never called for a formal or for a
224 -- lhs, so returning the type is ok ???
226 elsif Has_Unknown_Discriminants
(T
) then
230 Constraints
:= New_List
;
232 if Is_Private_Type
(T
) and then No
(Full_View
(T
)) then
234 -- Type is a generic derived type. Inherit discriminants from
237 Disc_Type
:= Etype
(Base_Type
(T
));
242 Discr
:= First_Discriminant
(Disc_Type
);
244 while Present
(Discr
) loop
245 Append_To
(Constraints
,
246 Make_Selected_Component
(Loc
,
248 Duplicate_Subexpr_No_Checks
(Obj
),
249 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
250 Next_Discriminant
(Discr
);
255 Make_Defining_Identifier
(Loc
,
256 Chars
=> New_Internal_Name
('S'));
257 Set_Is_Internal
(Subt
);
260 Make_Subtype_Declaration
(Loc
,
261 Defining_Identifier
=> Subt
,
262 Subtype_Indication
=>
263 Make_Subtype_Indication
(Loc
,
264 Subtype_Mark
=> New_Reference_To
(T
, Loc
),
266 Make_Index_Or_Discriminant_Constraint
(Loc
,
267 Constraints
=> Constraints
)));
269 Mark_Rewrite_Insertion
(Decl
);
271 end Build_Actual_Subtype
;
273 ---------------------------------------
274 -- Build_Actual_Subtype_Of_Component --
275 ---------------------------------------
277 function Build_Actual_Subtype_Of_Component
279 N
: Node_Id
) return Node_Id
281 Loc
: constant Source_Ptr
:= Sloc
(N
);
282 P
: constant Node_Id
:= Prefix
(N
);
285 Indx_Type
: Entity_Id
;
287 Deaccessed_T
: Entity_Id
;
288 -- This is either a copy of T, or if T is an access type, then it is
289 -- the directly designated type of this access type.
291 function Build_Actual_Array_Constraint
return List_Id
;
292 -- If one or more of the bounds of the component depends on
293 -- discriminants, build actual constraint using the discriminants
296 function Build_Actual_Record_Constraint
return List_Id
;
297 -- Similar to previous one, for discriminated components constrained
298 -- by the discriminant of the enclosing object.
300 -----------------------------------
301 -- Build_Actual_Array_Constraint --
302 -----------------------------------
304 function Build_Actual_Array_Constraint
return List_Id
is
305 Constraints
: constant List_Id
:= New_List
;
313 Indx
:= First_Index
(Deaccessed_T
);
314 while Present
(Indx
) loop
315 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
316 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
318 if Denotes_Discriminant
(Old_Lo
) then
320 Make_Selected_Component
(Loc
,
321 Prefix
=> New_Copy_Tree
(P
),
322 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
325 Lo
:= New_Copy_Tree
(Old_Lo
);
327 -- The new bound will be reanalyzed in the enclosing
328 -- declaration. For literal bounds that come from a type
329 -- declaration, the type of the context must be imposed, so
330 -- insure that analysis will take place. For non-universal
331 -- types this is not strictly necessary.
333 Set_Analyzed
(Lo
, False);
336 if Denotes_Discriminant
(Old_Hi
) then
338 Make_Selected_Component
(Loc
,
339 Prefix
=> New_Copy_Tree
(P
),
340 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
343 Hi
:= New_Copy_Tree
(Old_Hi
);
344 Set_Analyzed
(Hi
, False);
347 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
352 end Build_Actual_Array_Constraint
;
354 ------------------------------------
355 -- Build_Actual_Record_Constraint --
356 ------------------------------------
358 function Build_Actual_Record_Constraint
return List_Id
is
359 Constraints
: constant List_Id
:= New_List
;
364 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
365 while Present
(D
) loop
367 if Denotes_Discriminant
(Node
(D
)) then
368 D_Val
:= Make_Selected_Component
(Loc
,
369 Prefix
=> New_Copy_Tree
(P
),
370 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
373 D_Val
:= New_Copy_Tree
(Node
(D
));
376 Append
(D_Val
, Constraints
);
381 end Build_Actual_Record_Constraint
;
383 -- Start of processing for Build_Actual_Subtype_Of_Component
386 if In_Default_Expression
then
389 elsif Nkind
(N
) = N_Explicit_Dereference
then
390 if Is_Composite_Type
(T
)
391 and then not Is_Constrained
(T
)
392 and then not (Is_Class_Wide_Type
(T
)
393 and then Is_Constrained
(Root_Type
(T
)))
394 and then not Has_Unknown_Discriminants
(T
)
396 -- If the type of the dereference is already constrained, it
397 -- is an actual subtype.
399 if Is_Array_Type
(Etype
(N
))
400 and then Is_Constrained
(Etype
(N
))
404 Remove_Side_Effects
(P
);
405 return Build_Actual_Subtype
(T
, N
);
412 if Ekind
(T
) = E_Access_Subtype
then
413 Deaccessed_T
:= Designated_Type
(T
);
418 if Ekind
(Deaccessed_T
) = E_Array_Subtype
then
419 Id
:= First_Index
(Deaccessed_T
);
421 while Present
(Id
) loop
422 Indx_Type
:= Underlying_Type
(Etype
(Id
));
424 if Denotes_Discriminant
(Type_Low_Bound
(Indx_Type
)) or else
425 Denotes_Discriminant
(Type_High_Bound
(Indx_Type
))
427 Remove_Side_Effects
(P
);
429 Build_Component_Subtype
(
430 Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
436 elsif Is_Composite_Type
(Deaccessed_T
)
437 and then Has_Discriminants
(Deaccessed_T
)
438 and then not Has_Unknown_Discriminants
(Deaccessed_T
)
440 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
441 while Present
(D
) loop
443 if Denotes_Discriminant
(Node
(D
)) then
444 Remove_Side_Effects
(P
);
446 Build_Component_Subtype
(
447 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
454 -- If none of the above, the actual and nominal subtypes are the same
457 end Build_Actual_Subtype_Of_Component
;
459 -----------------------------
460 -- Build_Component_Subtype --
461 -----------------------------
463 function Build_Component_Subtype
466 T
: Entity_Id
) return Node_Id
472 -- Unchecked_Union components do not require component subtypes
474 if Is_Unchecked_Union
(T
) then
479 Make_Defining_Identifier
(Loc
,
480 Chars
=> New_Internal_Name
('S'));
481 Set_Is_Internal
(Subt
);
484 Make_Subtype_Declaration
(Loc
,
485 Defining_Identifier
=> Subt
,
486 Subtype_Indication
=>
487 Make_Subtype_Indication
(Loc
,
488 Subtype_Mark
=> New_Reference_To
(Base_Type
(T
), Loc
),
490 Make_Index_Or_Discriminant_Constraint
(Loc
,
493 Mark_Rewrite_Insertion
(Decl
);
495 end Build_Component_Subtype
;
497 --------------------------------------------
498 -- Build_Discriminal_Subtype_Of_Component --
499 --------------------------------------------
501 function Build_Discriminal_Subtype_Of_Component
502 (T
: Entity_Id
) return Node_Id
504 Loc
: constant Source_Ptr
:= Sloc
(T
);
508 function Build_Discriminal_Array_Constraint
return List_Id
;
509 -- If one or more of the bounds of the component depends on
510 -- discriminants, build actual constraint using the discriminants
513 function Build_Discriminal_Record_Constraint
return List_Id
;
514 -- Similar to previous one, for discriminated components constrained
515 -- by the discriminant of the enclosing object.
517 ----------------------------------------
518 -- Build_Discriminal_Array_Constraint --
519 ----------------------------------------
521 function Build_Discriminal_Array_Constraint
return List_Id
is
522 Constraints
: constant List_Id
:= New_List
;
530 Indx
:= First_Index
(T
);
531 while Present
(Indx
) loop
532 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
533 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
535 if Denotes_Discriminant
(Old_Lo
) then
536 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
539 Lo
:= New_Copy_Tree
(Old_Lo
);
542 if Denotes_Discriminant
(Old_Hi
) then
543 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
546 Hi
:= New_Copy_Tree
(Old_Hi
);
549 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
554 end Build_Discriminal_Array_Constraint
;
556 -----------------------------------------
557 -- Build_Discriminal_Record_Constraint --
558 -----------------------------------------
560 function Build_Discriminal_Record_Constraint
return List_Id
is
561 Constraints
: constant List_Id
:= New_List
;
566 D
:= First_Elmt
(Discriminant_Constraint
(T
));
567 while Present
(D
) loop
568 if Denotes_Discriminant
(Node
(D
)) then
570 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
573 D_Val
:= New_Copy_Tree
(Node
(D
));
576 Append
(D_Val
, Constraints
);
581 end Build_Discriminal_Record_Constraint
;
583 -- Start of processing for Build_Discriminal_Subtype_Of_Component
586 if Ekind
(T
) = E_Array_Subtype
then
587 Id
:= First_Index
(T
);
589 while Present
(Id
) loop
590 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
))) or else
591 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
593 return Build_Component_Subtype
594 (Build_Discriminal_Array_Constraint
, Loc
, T
);
600 elsif Ekind
(T
) = E_Record_Subtype
601 and then Has_Discriminants
(T
)
602 and then not Has_Unknown_Discriminants
(T
)
604 D
:= First_Elmt
(Discriminant_Constraint
(T
));
605 while Present
(D
) loop
606 if Denotes_Discriminant
(Node
(D
)) then
607 return Build_Component_Subtype
608 (Build_Discriminal_Record_Constraint
, Loc
, T
);
615 -- If none of the above, the actual and nominal subtypes are the same
618 end Build_Discriminal_Subtype_Of_Component
;
620 ------------------------------
621 -- Build_Elaboration_Entity --
622 ------------------------------
624 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
625 Loc
: constant Source_Ptr
:= Sloc
(N
);
626 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
629 Elab_Ent
: Entity_Id
;
632 -- Ignore if already constructed
634 if Present
(Elaboration_Entity
(Spec_Id
)) then
638 -- Construct name of elaboration entity as xxx_E, where xxx
639 -- is the unit name with dots replaced by double underscore.
640 -- We have to manually construct this name, since it will
641 -- be elaborated in the outer scope, and thus will not have
642 -- the unit name automatically prepended.
644 Get_Name_String
(Unit_Name
(Unum
));
646 -- Replace the %s by _E
648 Name_Buffer
(Name_Len
- 1 .. Name_Len
) := "_E";
650 -- Replace dots by double underscore
653 while P
< Name_Len
- 2 loop
654 if Name_Buffer
(P
) = '.' then
655 Name_Buffer
(P
+ 2 .. Name_Len
+ 1) :=
656 Name_Buffer
(P
+ 1 .. Name_Len
);
657 Name_Len
:= Name_Len
+ 1;
658 Name_Buffer
(P
) := '_';
659 Name_Buffer
(P
+ 1) := '_';
666 -- Create elaboration flag
669 Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
670 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
672 if No
(Declarations
(Aux_Decls_Node
(N
))) then
673 Set_Declarations
(Aux_Decls_Node
(N
), New_List
);
677 Make_Object_Declaration
(Loc
,
678 Defining_Identifier
=> Elab_Ent
,
680 New_Occurrence_Of
(Standard_Boolean
, Loc
),
682 New_Occurrence_Of
(Standard_False
, Loc
));
684 Append_To
(Declarations
(Aux_Decls_Node
(N
)), Decl
);
687 -- Reset True_Constant indication, since we will indeed
688 -- assign a value to the variable in the binder main.
690 Set_Is_True_Constant
(Elab_Ent
, False);
691 Set_Current_Value
(Elab_Ent
, Empty
);
693 -- We do not want any further qualification of the name (if we did
694 -- not do this, we would pick up the name of the generic package
695 -- in the case of a library level generic instantiation).
697 Set_Has_Qualified_Name
(Elab_Ent
);
698 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
699 end Build_Elaboration_Entity
;
701 -----------------------------------
702 -- Cannot_Raise_Constraint_Error --
703 -----------------------------------
705 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
707 if Compile_Time_Known_Value
(Expr
) then
710 elsif Do_Range_Check
(Expr
) then
713 elsif Raises_Constraint_Error
(Expr
) then
721 when N_Expanded_Name
=>
724 when N_Selected_Component
=>
725 return not Do_Discriminant_Check
(Expr
);
727 when N_Attribute_Reference
=>
728 if Do_Overflow_Check
(Expr
) then
731 elsif No
(Expressions
(Expr
)) then
736 N
: Node_Id
:= First
(Expressions
(Expr
));
739 while Present
(N
) loop
740 if Cannot_Raise_Constraint_Error
(N
) then
751 when N_Type_Conversion
=>
752 if Do_Overflow_Check
(Expr
)
753 or else Do_Length_Check
(Expr
)
754 or else Do_Tag_Check
(Expr
)
759 Cannot_Raise_Constraint_Error
(Expression
(Expr
));
762 when N_Unchecked_Type_Conversion
=>
763 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
766 if Do_Overflow_Check
(Expr
) then
770 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
777 if Do_Division_Check
(Expr
)
778 or else Do_Overflow_Check
(Expr
)
783 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
785 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
804 N_Op_Shift_Right_Arithmetic |
808 if Do_Overflow_Check
(Expr
) then
812 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
814 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
821 end Cannot_Raise_Constraint_Error
;
823 --------------------------
824 -- Check_Fully_Declared --
825 --------------------------
827 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
829 if Ekind
(T
) = E_Incomplete_Type
then
831 -- Ada 2005 (AI-50217): If the type is available through a limited
832 -- with_clause, verify that its full view has been analyzed.
834 if From_With_Type
(T
)
835 and then Present
(Non_Limited_View
(T
))
836 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
838 -- The non-limited view is fully declared
843 ("premature usage of incomplete}", N
, First_Subtype
(T
));
846 elsif Has_Private_Component
(T
)
847 and then not Is_Generic_Type
(Root_Type
(T
))
848 and then not In_Default_Expression
851 -- Special case: if T is the anonymous type created for a single
852 -- task or protected object, use the name of the source object.
854 if Is_Concurrent_Type
(T
)
855 and then not Comes_From_Source
(T
)
856 and then Nkind
(N
) = N_Object_Declaration
858 Error_Msg_NE
("type of& has incomplete component", N
,
859 Defining_Identifier
(N
));
863 ("premature usage of incomplete}", N
, First_Subtype
(T
));
866 end Check_Fully_Declared
;
868 -----------------------
869 -- Check_Obsolescent --
870 -----------------------
872 procedure Check_Obsolescent
(Nam
: Entity_Id
; N
: Node_Id
) is
876 -- Note that we always allow obsolescent references in the compiler
877 -- itself and the run time, since we assume that we know what we are
878 -- doing in such cases. For example the calls in Ada.Characters.Handling
879 -- to its own obsolescent subprograms are just fine.
881 if Is_Obsolescent
(Nam
) and then not GNAT_Mode
then
882 Check_Restriction
(No_Obsolescent_Features
, N
);
884 if Warn_On_Obsolescent_Feature
then
885 if Is_Package_Or_Generic_Package
(Nam
) then
886 Error_Msg_NE
("with of obsolescent package&?", N
, Nam
);
888 Error_Msg_NE
("call to obsolescent subprogram&?", N
, Nam
);
891 -- Output additional warning if present
893 W
:= Obsolescent_Warning
(Nam
);
896 Name_Buffer
(1) := '|';
897 Name_Buffer
(2) := '?';
900 -- Add characters to message, and output message
902 for J
in 1 .. String_Length
(Strval
(W
)) loop
903 Add_Char_To_Name_Buffer
(''');
904 Add_Char_To_Name_Buffer
905 (Get_Character
(Get_String_Char
(Strval
(W
), J
)));
908 Error_Msg_N
(Name_Buffer
(1 .. Name_Len
), N
);
912 end Check_Obsolescent
;
914 ------------------------------------------
915 -- Check_Potentially_Blocking_Operation --
916 ------------------------------------------
918 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
922 -- N is one of the potentially blocking operations listed in 9.5.1(8).
923 -- When pragma Detect_Blocking is active, the run time will raise
924 -- Program_Error. Here we only issue a warning, since we generally
925 -- support the use of potentially blocking operations in the absence
928 -- Indirect blocking through a subprogram call cannot be diagnosed
929 -- statically without interprocedural analysis, so we do not attempt
932 S
:= Scope
(Current_Scope
);
933 while Present
(S
) and then S
/= Standard_Standard
loop
934 if Is_Protected_Type
(S
) then
936 ("potentially blocking operation in protected operation?", N
);
943 end Check_Potentially_Blocking_Operation
;
949 procedure Check_VMS
(Construct
: Node_Id
) is
951 if not OpenVMS_On_Target
then
953 ("this construct is allowed only in Open'V'M'S", Construct
);
957 ----------------------------------
958 -- Collect_Primitive_Operations --
959 ----------------------------------
961 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
962 B_Type
: constant Entity_Id
:= Base_Type
(T
);
963 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
964 B_Scope
: Entity_Id
:= Scope
(B_Type
);
968 Formal_Derived
: Boolean := False;
972 -- For tagged types, the primitive operations are collected as they
973 -- are declared, and held in an explicit list which is simply returned.
975 if Is_Tagged_Type
(B_Type
) then
976 return Primitive_Operations
(B_Type
);
978 -- An untagged generic type that is a derived type inherits the
979 -- primitive operations of its parent type. Other formal types only
980 -- have predefined operators, which are not explicitly represented.
982 elsif Is_Generic_Type
(B_Type
) then
983 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
984 and then Nkind
(Formal_Type_Definition
(B_Decl
))
985 = N_Formal_Derived_Type_Definition
987 Formal_Derived
:= True;
989 return New_Elmt_List
;
993 Op_List
:= New_Elmt_List
;
995 if B_Scope
= Standard_Standard
then
996 if B_Type
= Standard_String
then
997 Append_Elmt
(Standard_Op_Concat
, Op_List
);
999 elsif B_Type
= Standard_Wide_String
then
1000 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
1006 elsif (Is_Package_Or_Generic_Package
(B_Scope
)
1008 Nkind
(Parent
(Declaration_Node
(First_Subtype
(T
)))) /=
1010 or else Is_Derived_Type
(B_Type
)
1012 -- The primitive operations appear after the base type, except
1013 -- if the derivation happens within the private part of B_Scope
1014 -- and the type is a private type, in which case both the type
1015 -- and some primitive operations may appear before the base
1016 -- type, and the list of candidates starts after the type.
1018 if In_Open_Scopes
(B_Scope
)
1019 and then Scope
(T
) = B_Scope
1020 and then In_Private_Part
(B_Scope
)
1022 Id
:= Next_Entity
(T
);
1024 Id
:= Next_Entity
(B_Type
);
1027 while Present
(Id
) loop
1029 -- Note that generic formal subprograms are not
1030 -- considered to be primitive operations and thus
1031 -- are never inherited.
1033 if Is_Overloadable
(Id
)
1034 and then Nkind
(Parent
(Parent
(Id
)))
1035 not in N_Formal_Subprogram_Declaration
1039 if Base_Type
(Etype
(Id
)) = B_Type
then
1042 Formal
:= First_Formal
(Id
);
1043 while Present
(Formal
) loop
1044 if Base_Type
(Etype
(Formal
)) = B_Type
then
1048 elsif Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
1050 (Designated_Type
(Etype
(Formal
))) = B_Type
1056 Next_Formal
(Formal
);
1060 -- For a formal derived type, the only primitives are the
1061 -- ones inherited from the parent type. Operations appearing
1062 -- in the package declaration are not primitive for it.
1065 and then (not Formal_Derived
1066 or else Present
(Alias
(Id
)))
1068 Append_Elmt
(Id
, Op_List
);
1074 -- For a type declared in System, some of its operations
1075 -- may appear in the target-specific extension to System.
1078 and then Chars
(B_Scope
) = Name_System
1079 and then Scope
(B_Scope
) = Standard_Standard
1080 and then Present_System_Aux
1082 B_Scope
:= System_Aux_Id
;
1083 Id
:= First_Entity
(System_Aux_Id
);
1089 end Collect_Primitive_Operations
;
1091 -----------------------------------
1092 -- Compile_Time_Constraint_Error --
1093 -----------------------------------
1095 function Compile_Time_Constraint_Error
1098 Ent
: Entity_Id
:= Empty
;
1099 Loc
: Source_Ptr
:= No_Location
;
1100 Warn
: Boolean := False) return Node_Id
1102 Msgc
: String (1 .. Msg
'Length + 2);
1110 -- A static constraint error in an instance body is not a fatal error.
1111 -- we choose to inhibit the message altogether, because there is no
1112 -- obvious node (for now) on which to post it. On the other hand the
1113 -- offending node must be replaced with a constraint_error in any case.
1115 -- No messages are generated if we already posted an error on this node
1117 if not Error_Posted
(N
) then
1118 if Loc
/= No_Location
then
1124 -- Make all such messages unconditional
1126 Msgc
(1 .. Msg
'Length) := Msg
;
1127 Msgc
(Msg
'Length + 1) := '!';
1128 Msgl
:= Msg
'Length + 1;
1130 -- Message is a warning, even in Ada 95 case
1132 if Msg
(Msg
'Length) = '?' then
1135 -- In Ada 83, all messages are warnings. In the private part and
1136 -- the body of an instance, constraint_checks are only warnings.
1137 -- We also make this a warning if the Warn parameter is set.
1140 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
1146 elsif In_Instance_Not_Visible
then
1151 -- Otherwise we have a real error message (Ada 95 static case)
1157 -- Should we generate a warning? The answer is not quite yes. The
1158 -- very annoying exception occurs in the case of a short circuit
1159 -- operator where the left operand is static and decisive. Climb
1160 -- parents to see if that is the case we have here.
1168 if (Nkind
(P
) = N_And_Then
1169 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1170 and then Is_False
(Expr_Value
(Left_Opnd
(P
))))
1171 or else (Nkind
(P
) = N_Or_Else
1172 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1173 and then Is_True
(Expr_Value
(Left_Opnd
(P
))))
1178 elsif Nkind
(P
) = N_Component_Association
1179 and then Nkind
(Parent
(P
)) = N_Aggregate
1181 null; -- Keep going.
1184 exit when Nkind
(P
) not in N_Subexpr
;
1189 if Present
(Ent
) then
1190 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
1192 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
1196 if Inside_Init_Proc
then
1198 ("\& will be raised for objects of this type!?",
1199 N
, Standard_Constraint_Error
, Eloc
);
1202 ("\& will be raised at run time!?",
1203 N
, Standard_Constraint_Error
, Eloc
);
1207 ("\static expression raises&!",
1208 N
, Standard_Constraint_Error
, Eloc
);
1214 end Compile_Time_Constraint_Error
;
1216 -----------------------
1217 -- Conditional_Delay --
1218 -----------------------
1220 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
1222 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
1223 Set_Has_Delayed_Freeze
(New_Ent
);
1225 end Conditional_Delay
;
1227 --------------------
1228 -- Current_Entity --
1229 --------------------
1231 -- The currently visible definition for a given identifier is the
1232 -- one most chained at the start of the visibility chain, i.e. the
1233 -- one that is referenced by the Node_Id value of the name of the
1234 -- given identifier.
1236 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
1238 return Get_Name_Entity_Id
(Chars
(N
));
1241 -----------------------------
1242 -- Current_Entity_In_Scope --
1243 -----------------------------
1245 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
1247 CS
: constant Entity_Id
:= Current_Scope
;
1249 Transient_Case
: constant Boolean := Scope_Is_Transient
;
1252 E
:= Get_Name_Entity_Id
(Chars
(N
));
1255 and then Scope
(E
) /= CS
1256 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
1262 end Current_Entity_In_Scope
;
1268 function Current_Scope
return Entity_Id
is
1270 if Scope_Stack
.Last
= -1 then
1271 return Standard_Standard
;
1274 C
: constant Entity_Id
:=
1275 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
1280 return Standard_Standard
;
1286 ------------------------
1287 -- Current_Subprogram --
1288 ------------------------
1290 function Current_Subprogram
return Entity_Id
is
1291 Scop
: constant Entity_Id
:= Current_Scope
;
1294 if Is_Subprogram
(Scop
) or else Is_Generic_Subprogram
(Scop
) then
1297 return Enclosing_Subprogram
(Scop
);
1299 end Current_Subprogram
;
1301 ---------------------
1302 -- Defining_Entity --
1303 ---------------------
1305 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
1306 K
: constant Node_Kind
:= Nkind
(N
);
1307 Err
: Entity_Id
:= Empty
;
1312 N_Subprogram_Declaration |
1313 N_Abstract_Subprogram_Declaration |
1315 N_Package_Declaration |
1316 N_Subprogram_Renaming_Declaration |
1317 N_Subprogram_Body_Stub |
1318 N_Generic_Subprogram_Declaration |
1319 N_Generic_Package_Declaration |
1320 N_Formal_Subprogram_Declaration
1322 return Defining_Entity
(Specification
(N
));
1325 N_Component_Declaration |
1326 N_Defining_Program_Unit_Name |
1327 N_Discriminant_Specification |
1329 N_Entry_Declaration |
1330 N_Entry_Index_Specification |
1331 N_Exception_Declaration |
1332 N_Exception_Renaming_Declaration |
1333 N_Formal_Object_Declaration |
1334 N_Formal_Package_Declaration |
1335 N_Formal_Type_Declaration |
1336 N_Full_Type_Declaration |
1337 N_Implicit_Label_Declaration |
1338 N_Incomplete_Type_Declaration |
1339 N_Loop_Parameter_Specification |
1340 N_Number_Declaration |
1341 N_Object_Declaration |
1342 N_Object_Renaming_Declaration |
1343 N_Package_Body_Stub |
1344 N_Parameter_Specification |
1345 N_Private_Extension_Declaration |
1346 N_Private_Type_Declaration |
1348 N_Protected_Body_Stub |
1349 N_Protected_Type_Declaration |
1350 N_Single_Protected_Declaration |
1351 N_Single_Task_Declaration |
1352 N_Subtype_Declaration |
1355 N_Task_Type_Declaration
1357 return Defining_Identifier
(N
);
1360 return Defining_Entity
(Proper_Body
(N
));
1363 N_Function_Instantiation |
1364 N_Function_Specification |
1365 N_Generic_Function_Renaming_Declaration |
1366 N_Generic_Package_Renaming_Declaration |
1367 N_Generic_Procedure_Renaming_Declaration |
1369 N_Package_Instantiation |
1370 N_Package_Renaming_Declaration |
1371 N_Package_Specification |
1372 N_Procedure_Instantiation |
1373 N_Procedure_Specification
1376 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
1379 if Nkind
(Nam
) in N_Entity
then
1382 -- For Error, make up a name and attach to declaration
1383 -- so we can continue semantic analysis
1385 elsif Nam
= Error
then
1387 Make_Defining_Identifier
(Sloc
(N
),
1388 Chars
=> New_Internal_Name
('T'));
1389 Set_Defining_Unit_Name
(N
, Err
);
1392 -- If not an entity, get defining identifier
1395 return Defining_Identifier
(Nam
);
1399 when N_Block_Statement
=>
1400 return Entity
(Identifier
(N
));
1403 raise Program_Error
;
1406 end Defining_Entity
;
1408 --------------------------
1409 -- Denotes_Discriminant --
1410 --------------------------
1412 function Denotes_Discriminant
1414 Check_Protected
: Boolean := False) return Boolean
1418 if not Is_Entity_Name
(N
)
1419 or else No
(Entity
(N
))
1426 -- If we are checking for a protected type, the discriminant may have
1427 -- been rewritten as the corresponding discriminal of the original type
1428 -- or of the corresponding concurrent record, depending on whether we
1429 -- are in the spec or body of the protected type.
1431 return Ekind
(E
) = E_Discriminant
1434 and then Ekind
(E
) = E_In_Parameter
1435 and then Present
(Discriminal_Link
(E
))
1437 (Is_Protected_Type
(Scope
(Discriminal_Link
(E
)))
1439 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
1441 end Denotes_Discriminant
;
1443 -----------------------------
1444 -- Depends_On_Discriminant --
1445 -----------------------------
1447 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
1452 Get_Index_Bounds
(N
, L
, H
);
1453 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
1454 end Depends_On_Discriminant
;
1456 -------------------------
1457 -- Designate_Same_Unit --
1458 -------------------------
1460 function Designate_Same_Unit
1462 Name2
: Node_Id
) return Boolean
1464 K1
: constant Node_Kind
:= Nkind
(Name1
);
1465 K2
: constant Node_Kind
:= Nkind
(Name2
);
1467 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
1468 -- Returns the parent unit name node of a defining program unit name
1469 -- or the prefix if N is a selected component or an expanded name.
1471 function Select_Node
(N
: Node_Id
) return Node_Id
;
1472 -- Returns the defining identifier node of a defining program unit
1473 -- name or the selector node if N is a selected component or an
1480 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
1482 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1494 function Select_Node
(N
: Node_Id
) return Node_Id
is
1496 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1497 return Defining_Identifier
(N
);
1500 return Selector_Name
(N
);
1504 -- Start of processing for Designate_Next_Unit
1507 if (K1
= N_Identifier
or else
1508 K1
= N_Defining_Identifier
)
1510 (K2
= N_Identifier
or else
1511 K2
= N_Defining_Identifier
)
1513 return Chars
(Name1
) = Chars
(Name2
);
1516 (K1
= N_Expanded_Name
or else
1517 K1
= N_Selected_Component
or else
1518 K1
= N_Defining_Program_Unit_Name
)
1520 (K2
= N_Expanded_Name
or else
1521 K2
= N_Selected_Component
or else
1522 K2
= N_Defining_Program_Unit_Name
)
1525 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
1527 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
1532 end Designate_Same_Unit
;
1534 ----------------------------
1535 -- Enclosing_Generic_Body --
1536 ----------------------------
1538 function Enclosing_Generic_Body
1539 (E
: Entity_Id
) return Node_Id
1548 while Present
(P
) loop
1549 if Nkind
(P
) = N_Package_Body
1550 or else Nkind
(P
) = N_Subprogram_Body
1552 Spec
:= Corresponding_Spec
(P
);
1554 if Present
(Spec
) then
1555 Decl
:= Unit_Declaration_Node
(Spec
);
1557 if Nkind
(Decl
) = N_Generic_Package_Declaration
1558 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
1569 end Enclosing_Generic_Body
;
1571 -------------------------------
1572 -- Enclosing_Lib_Unit_Entity --
1573 -------------------------------
1575 function Enclosing_Lib_Unit_Entity
return Entity_Id
is
1576 Unit_Entity
: Entity_Id
:= Current_Scope
;
1579 -- Look for enclosing library unit entity by following scope links.
1580 -- Equivalent to, but faster than indexing through the scope stack.
1582 while (Present
(Scope
(Unit_Entity
))
1583 and then Scope
(Unit_Entity
) /= Standard_Standard
)
1584 and not Is_Child_Unit
(Unit_Entity
)
1586 Unit_Entity
:= Scope
(Unit_Entity
);
1590 end Enclosing_Lib_Unit_Entity
;
1592 -----------------------------
1593 -- Enclosing_Lib_Unit_Node --
1594 -----------------------------
1596 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
1597 Current_Node
: Node_Id
:= N
;
1600 while Present
(Current_Node
)
1601 and then Nkind
(Current_Node
) /= N_Compilation_Unit
1603 Current_Node
:= Parent
(Current_Node
);
1606 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
1610 return Current_Node
;
1611 end Enclosing_Lib_Unit_Node
;
1613 --------------------------
1614 -- Enclosing_Subprogram --
1615 --------------------------
1617 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
1618 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
1621 if Dynamic_Scope
= Standard_Standard
then
1624 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
1625 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
1627 elsif Ekind
(Dynamic_Scope
) = E_Block
then
1628 return Enclosing_Subprogram
(Dynamic_Scope
);
1630 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
1631 return Get_Task_Body_Procedure
(Dynamic_Scope
);
1633 elsif Convention
(Dynamic_Scope
) = Convention_Protected
then
1634 return Protected_Body_Subprogram
(Dynamic_Scope
);
1637 return Dynamic_Scope
;
1639 end Enclosing_Subprogram
;
1641 ------------------------
1642 -- Ensure_Freeze_Node --
1643 ------------------------
1645 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
1649 if No
(Freeze_Node
(E
)) then
1650 FN
:= Make_Freeze_Entity
(Sloc
(E
));
1651 Set_Has_Delayed_Freeze
(E
);
1652 Set_Freeze_Node
(E
, FN
);
1653 Set_Access_Types_To_Process
(FN
, No_Elist
);
1654 Set_TSS_Elist
(FN
, No_Elist
);
1657 end Ensure_Freeze_Node
;
1663 procedure Enter_Name
(Def_Id
: Node_Id
) is
1664 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
1665 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
1666 S
: constant Entity_Id
:= Current_Scope
;
1668 function Is_Private_Component_Renaming
(N
: Node_Id
) return Boolean;
1669 -- Recognize a renaming declaration that is introduced for private
1670 -- components of a protected type. We treat these as weak declarations
1671 -- so that they are overridden by entities with the same name that
1672 -- come from source, such as formals or local variables of a given
1673 -- protected declaration.
1675 -----------------------------------
1676 -- Is_Private_Component_Renaming --
1677 -----------------------------------
1679 function Is_Private_Component_Renaming
(N
: Node_Id
) return Boolean is
1681 return not Comes_From_Source
(N
)
1682 and then not Comes_From_Source
(Current_Scope
)
1683 and then Nkind
(N
) = N_Object_Renaming_Declaration
;
1684 end Is_Private_Component_Renaming
;
1686 -- Start of processing for Enter_Name
1689 Generate_Definition
(Def_Id
);
1691 -- Add new name to current scope declarations. Check for duplicate
1692 -- declaration, which may or may not be a genuine error.
1696 -- Case of previous entity entered because of a missing declaration
1697 -- or else a bad subtype indication. Best is to use the new entity,
1698 -- and make the previous one invisible.
1700 if Etype
(E
) = Any_Type
then
1701 Set_Is_Immediately_Visible
(E
, False);
1703 -- Case of renaming declaration constructed for package instances.
1704 -- if there is an explicit declaration with the same identifier,
1705 -- the renaming is not immediately visible any longer, but remains
1706 -- visible through selected component notation.
1708 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
1709 and then not Comes_From_Source
(E
)
1711 Set_Is_Immediately_Visible
(E
, False);
1713 -- The new entity may be the package renaming, which has the same
1714 -- same name as a generic formal which has been seen already.
1716 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
1717 and then not Comes_From_Source
(Def_Id
)
1719 Set_Is_Immediately_Visible
(E
, False);
1721 -- For a fat pointer corresponding to a remote access to subprogram,
1722 -- we use the same identifier as the RAS type, so that the proper
1723 -- name appears in the stub. This type is only retrieved through
1724 -- the RAS type and never by visibility, and is not added to the
1725 -- visibility list (see below).
1727 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
1728 and then Present
(Corresponding_Remote_Type
(Def_Id
))
1732 -- A controller component for a type extension overrides the
1733 -- inherited component.
1735 elsif Chars
(E
) = Name_uController
then
1738 -- Case of an implicit operation or derived literal. The new entity
1739 -- hides the implicit one, which is removed from all visibility,
1740 -- i.e. the entity list of its scope, and homonym chain of its name.
1742 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
1743 or else Is_Internal
(E
)
1747 Prev_Vis
: Entity_Id
;
1748 Decl
: constant Node_Id
:= Parent
(E
);
1751 -- If E is an implicit declaration, it cannot be the first
1752 -- entity in the scope.
1754 Prev
:= First_Entity
(Current_Scope
);
1756 while Present
(Prev
)
1757 and then Next_Entity
(Prev
) /= E
1764 -- If E is not on the entity chain of the current scope,
1765 -- it is an implicit declaration in the generic formal
1766 -- part of a generic subprogram. When analyzing the body,
1767 -- the generic formals are visible but not on the entity
1768 -- chain of the subprogram. The new entity will become
1769 -- the visible one in the body.
1772 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
1776 Set_Next_Entity
(Prev
, Next_Entity
(E
));
1778 if No
(Next_Entity
(Prev
)) then
1779 Set_Last_Entity
(Current_Scope
, Prev
);
1782 if E
= Current_Entity
(E
) then
1786 Prev_Vis
:= Current_Entity
(E
);
1787 while Homonym
(Prev_Vis
) /= E
loop
1788 Prev_Vis
:= Homonym
(Prev_Vis
);
1792 if Present
(Prev_Vis
) then
1794 -- Skip E in the visibility chain
1796 Set_Homonym
(Prev_Vis
, Homonym
(E
));
1799 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
1804 -- This section of code could use a comment ???
1806 elsif Present
(Etype
(E
))
1807 and then Is_Concurrent_Type
(Etype
(E
))
1812 elsif Is_Private_Component_Renaming
(Parent
(Def_Id
)) then
1815 -- In the body or private part of an instance, a type extension
1816 -- may introduce a component with the same name as that of an
1817 -- actual. The legality rule is not enforced, but the semantics
1818 -- of the full type with two components of the same name are not
1819 -- clear at this point ???
1821 elsif In_Instance_Not_Visible
then
1824 -- When compiling a package body, some child units may have become
1825 -- visible. They cannot conflict with local entities that hide them.
1827 elsif Is_Child_Unit
(E
)
1828 and then In_Open_Scopes
(Scope
(E
))
1829 and then not Is_Immediately_Visible
(E
)
1833 -- Conversely, with front-end inlining we may compile the parent
1834 -- body first, and a child unit subsequently. The context is now
1835 -- the parent spec, and body entities are not visible.
1837 elsif Is_Child_Unit
(Def_Id
)
1838 and then Is_Package_Body_Entity
(E
)
1839 and then not In_Package_Body
(Current_Scope
)
1843 -- Case of genuine duplicate declaration
1846 Error_Msg_Sloc
:= Sloc
(E
);
1848 -- If the previous declaration is an incomplete type declaration
1849 -- this may be an attempt to complete it with a private type.
1850 -- The following avoids confusing cascaded errors.
1852 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
1853 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
1856 ("incomplete type cannot be completed" &
1857 " with a private declaration",
1859 Set_Is_Immediately_Visible
(E
, False);
1860 Set_Full_View
(E
, Def_Id
);
1862 elsif Ekind
(E
) = E_Discriminant
1863 and then Present
(Scope
(Def_Id
))
1864 and then Scope
(Def_Id
) /= Current_Scope
1866 -- An inherited component of a record conflicts with
1867 -- a new discriminant. The discriminant is inserted first
1868 -- in the scope, but the error should be posted on it, not
1869 -- on the component.
1871 Error_Msg_Sloc
:= Sloc
(Def_Id
);
1872 Error_Msg_N
("& conflicts with declaration#", E
);
1875 -- If the name of the unit appears in its own context clause,
1876 -- a dummy package with the name has already been created, and
1877 -- the error emitted. Try to continue quietly.
1879 elsif Error_Posted
(E
)
1880 and then Sloc
(E
) = No_Location
1881 and then Nkind
(Parent
(E
)) = N_Package_Specification
1882 and then Current_Scope
= Standard_Standard
1884 Set_Scope
(Def_Id
, Current_Scope
);
1888 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
1890 -- Avoid cascaded messages with duplicate components in
1893 if Ekind
(E
) = E_Component
1894 or else Ekind
(E
) = E_Discriminant
1900 if Nkind
(Parent
(Parent
(Def_Id
)))
1901 = N_Generic_Subprogram_Declaration
1903 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
1905 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
1908 -- If entity is in standard, then we are in trouble, because
1909 -- it means that we have a library package with a duplicated
1910 -- name. That's hard to recover from, so abort!
1912 if S
= Standard_Standard
then
1913 raise Unrecoverable_Error
;
1915 -- Otherwise we continue with the declaration. Having two
1916 -- identical declarations should not cause us too much trouble!
1924 -- If we fall through, declaration is OK , or OK enough to continue
1926 -- If Def_Id is a discriminant or a record component we are in the
1927 -- midst of inheriting components in a derived record definition.
1928 -- Preserve their Ekind and Etype.
1930 if Ekind
(Def_Id
) = E_Discriminant
1931 or else Ekind
(Def_Id
) = E_Component
1935 -- If a type is already set, leave it alone (happens whey a type
1936 -- declaration is reanalyzed following a call to the optimizer)
1938 elsif Present
(Etype
(Def_Id
)) then
1941 -- Otherwise, the kind E_Void insures that premature uses of the entity
1942 -- will be detected. Any_Type insures that no cascaded errors will occur
1945 Set_Ekind
(Def_Id
, E_Void
);
1946 Set_Etype
(Def_Id
, Any_Type
);
1949 -- Inherited discriminants and components in derived record types are
1950 -- immediately visible. Itypes are not.
1952 if Ekind
(Def_Id
) = E_Discriminant
1953 or else Ekind
(Def_Id
) = E_Component
1954 or else (No
(Corresponding_Remote_Type
(Def_Id
))
1955 and then not Is_Itype
(Def_Id
))
1957 Set_Is_Immediately_Visible
(Def_Id
);
1958 Set_Current_Entity
(Def_Id
);
1961 Set_Homonym
(Def_Id
, C
);
1962 Append_Entity
(Def_Id
, S
);
1963 Set_Public_Status
(Def_Id
);
1965 -- Warn if new entity hides an old one
1968 and then Present
(C
)
1969 and then Length_Of_Name
(Chars
(C
)) /= 1
1970 and then Comes_From_Source
(C
)
1971 and then Comes_From_Source
(Def_Id
)
1972 and then In_Extended_Main_Source_Unit
(Def_Id
)
1974 Error_Msg_Sloc
:= Sloc
(C
);
1975 Error_Msg_N
("declaration hides &#?", Def_Id
);
1979 --------------------------
1980 -- Explain_Limited_Type --
1981 --------------------------
1983 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
1987 -- For array, component type must be limited
1989 if Is_Array_Type
(T
) then
1990 Error_Msg_Node_2
:= T
;
1992 ("component type& of type& is limited", N
, Component_Type
(T
));
1993 Explain_Limited_Type
(Component_Type
(T
), N
);
1995 elsif Is_Record_Type
(T
) then
1997 -- No need for extra messages if explicit limited record
1999 if Is_Limited_Record
(Base_Type
(T
)) then
2003 -- Otherwise find a limited component. Check only components that
2004 -- come from source, or inherited components that appear in the
2005 -- source of the ancestor.
2007 C
:= First_Component
(T
);
2008 while Present
(C
) loop
2009 if Is_Limited_Type
(Etype
(C
))
2011 (Comes_From_Source
(C
)
2013 (Present
(Original_Record_Component
(C
))
2015 Comes_From_Source
(Original_Record_Component
(C
))))
2017 Error_Msg_Node_2
:= T
;
2018 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
2019 Explain_Limited_Type
(Etype
(C
), N
);
2026 -- The type may be declared explicitly limited, even if no component
2027 -- of it is limited, in which case we fall out of the loop.
2030 end Explain_Limited_Type
;
2032 -------------------------------------
2033 -- Find_Corresponding_Discriminant --
2034 -------------------------------------
2036 function Find_Corresponding_Discriminant
2038 Typ
: Entity_Id
) return Entity_Id
2040 Par_Disc
: Entity_Id
;
2041 Old_Disc
: Entity_Id
;
2042 New_Disc
: Entity_Id
;
2045 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
2047 -- The original type may currently be private, and the discriminant
2048 -- only appear on its full view.
2050 if Is_Private_Type
(Scope
(Par_Disc
))
2051 and then not Has_Discriminants
(Scope
(Par_Disc
))
2052 and then Present
(Full_View
(Scope
(Par_Disc
)))
2054 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
2056 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
2059 if Is_Class_Wide_Type
(Typ
) then
2060 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
2062 New_Disc
:= First_Discriminant
(Typ
);
2065 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
2066 if Old_Disc
= Par_Disc
then
2069 Next_Discriminant
(Old_Disc
);
2070 Next_Discriminant
(New_Disc
);
2074 -- Should always find it
2076 raise Program_Error
;
2077 end Find_Corresponding_Discriminant
;
2079 -----------------------------
2080 -- Find_Static_Alternative --
2081 -----------------------------
2083 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
2084 Expr
: constant Node_Id
:= Expression
(N
);
2085 Val
: constant Uint
:= Expr_Value
(Expr
);
2090 Alt
:= First
(Alternatives
(N
));
2093 if Nkind
(Alt
) /= N_Pragma
then
2094 Choice
:= First
(Discrete_Choices
(Alt
));
2096 while Present
(Choice
) loop
2098 -- Others choice, always matches
2100 if Nkind
(Choice
) = N_Others_Choice
then
2103 -- Range, check if value is in the range
2105 elsif Nkind
(Choice
) = N_Range
then
2107 Val
>= Expr_Value
(Low_Bound
(Choice
))
2109 Val
<= Expr_Value
(High_Bound
(Choice
));
2111 -- Choice is a subtype name. Note that we know it must
2112 -- be a static subtype, since otherwise it would have
2113 -- been diagnosed as illegal.
2115 elsif Is_Entity_Name
(Choice
)
2116 and then Is_Type
(Entity
(Choice
))
2118 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
));
2120 -- Choice is a subtype indication
2122 elsif Nkind
(Choice
) = N_Subtype_Indication
then
2124 C
: constant Node_Id
:= Constraint
(Choice
);
2125 R
: constant Node_Id
:= Range_Expression
(C
);
2129 Val
>= Expr_Value
(Low_Bound
(R
))
2131 Val
<= Expr_Value
(High_Bound
(R
));
2134 -- Choice is a simple expression
2137 exit Search
when Val
= Expr_Value
(Choice
);
2145 pragma Assert
(Present
(Alt
));
2148 -- The above loop *must* terminate by finding a match, since
2149 -- we know the case statement is valid, and the value of the
2150 -- expression is known at compile time. When we fall out of
2151 -- the loop, Alt points to the alternative that we know will
2152 -- be selected at run time.
2155 end Find_Static_Alternative
;
2161 function First_Actual
(Node
: Node_Id
) return Node_Id
is
2165 if No
(Parameter_Associations
(Node
)) then
2169 N
:= First
(Parameter_Associations
(Node
));
2171 if Nkind
(N
) = N_Parameter_Association
then
2172 return First_Named_Actual
(Node
);
2178 -------------------------
2179 -- Full_Qualified_Name --
2180 -------------------------
2182 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2184 pragma Warnings
(Off
, Res
);
2186 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
2187 -- Compute recursively the qualified name without NUL at the end
2189 ----------------------------------
2190 -- Internal_Full_Qualified_Name --
2191 ----------------------------------
2193 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2194 Ent
: Entity_Id
:= E
;
2195 Parent_Name
: String_Id
:= No_String
;
2198 -- Deals properly with child units
2200 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
2201 Ent
:= Defining_Identifier
(Ent
);
2204 -- Compute qualification recursively (only "Standard" has no scope)
2206 if Present
(Scope
(Scope
(Ent
))) then
2207 Parent_Name
:= Internal_Full_Qualified_Name
(Scope
(Ent
));
2210 -- Every entity should have a name except some expanded blocks
2211 -- don't bother about those.
2213 if Chars
(Ent
) = No_Name
then
2217 -- Add a period between Name and qualification
2219 if Parent_Name
/= No_String
then
2220 Start_String
(Parent_Name
);
2221 Store_String_Char
(Get_Char_Code
('.'));
2227 -- Generates the entity name in upper case
2229 Get_Decoded_Name_String
(Chars
(Ent
));
2231 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2233 end Internal_Full_Qualified_Name
;
2235 -- Start of processing for Full_Qualified_Name
2238 Res
:= Internal_Full_Qualified_Name
(E
);
2239 Store_String_Char
(Get_Char_Code
(ASCII
.nul
));
2241 end Full_Qualified_Name
;
2243 -----------------------
2244 -- Gather_Components --
2245 -----------------------
2247 procedure Gather_Components
2249 Comp_List
: Node_Id
;
2250 Governed_By
: List_Id
;
2252 Report_Errors
: out Boolean)
2256 Discrete_Choice
: Node_Id
;
2257 Comp_Item
: Node_Id
;
2259 Discrim
: Entity_Id
;
2260 Discrim_Name
: Node_Id
;
2261 Discrim_Value
: Node_Id
;
2264 Report_Errors
:= False;
2266 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
2269 elsif Present
(Component_Items
(Comp_List
)) then
2270 Comp_Item
:= First
(Component_Items
(Comp_List
));
2276 while Present
(Comp_Item
) loop
2278 -- Skip the tag of a tagged record, the interface tags, as well
2279 -- as all items that are not user components (anonymous types,
2280 -- rep clauses, Parent field, controller field).
2282 if Nkind
(Comp_Item
) = N_Component_Declaration
then
2284 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
2286 if not Is_Tag
(Comp
)
2287 and then Chars
(Comp
) /= Name_uParent
2288 and then Chars
(Comp
) /= Name_uController
2290 Append_Elmt
(Comp
, Into
);
2298 if No
(Variant_Part
(Comp_List
)) then
2301 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
2302 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
2305 -- Look for the discriminant that governs this variant part.
2306 -- The discriminant *must* be in the Governed_By List
2308 Assoc
:= First
(Governed_By
);
2309 Find_Constraint
: loop
2310 Discrim
:= First
(Choices
(Assoc
));
2311 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
2312 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
2314 Chars
(Corresponding_Discriminant
(Entity
(Discrim
)))
2315 = Chars
(Discrim_Name
))
2316 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
2317 = Chars
(Discrim_Name
);
2319 if No
(Next
(Assoc
)) then
2320 if not Is_Constrained
(Typ
)
2321 and then Is_Derived_Type
(Typ
)
2322 and then Present
(Stored_Constraint
(Typ
))
2325 -- If the type is a tagged type with inherited discriminants,
2326 -- use the stored constraint on the parent in order to find
2327 -- the values of discriminants that are otherwise hidden by an
2328 -- explicit constraint. Renamed discriminants are handled in
2331 -- If several parent discriminants are renamed by a single
2332 -- discriminant of the derived type, the call to obtain the
2333 -- Corresponding_Discriminant field only retrieves the last
2334 -- of them. We recover the constraint on the others from the
2335 -- Stored_Constraint as well.
2342 D
:= First_Discriminant
(Etype
(Typ
));
2343 C
:= First_Elmt
(Stored_Constraint
(Typ
));
2346 and then Present
(C
)
2348 if Chars
(Discrim_Name
) = Chars
(D
) then
2349 if Is_Entity_Name
(Node
(C
))
2350 and then Entity
(Node
(C
)) = Entity
(Discrim
)
2352 -- D is renamed by Discrim, whose value is
2359 Make_Component_Association
(Sloc
(Typ
),
2361 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
2362 Duplicate_Subexpr_No_Checks
(Node
(C
)));
2364 exit Find_Constraint
;
2367 D
:= Next_Discriminant
(D
);
2374 if No
(Next
(Assoc
)) then
2375 Error_Msg_NE
(" missing value for discriminant&",
2376 First
(Governed_By
), Discrim_Name
);
2377 Report_Errors
:= True;
2382 end loop Find_Constraint
;
2384 Discrim_Value
:= Expression
(Assoc
);
2386 if not Is_OK_Static_Expression
(Discrim_Value
) then
2388 ("value for discriminant & must be static!",
2389 Discrim_Value
, Discrim
);
2390 Why_Not_Static
(Discrim_Value
);
2391 Report_Errors
:= True;
2395 Search_For_Discriminant_Value
: declare
2401 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
2404 Find_Discrete_Value
: while Present
(Variant
) loop
2405 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
2406 while Present
(Discrete_Choice
) loop
2408 exit Find_Discrete_Value
when
2409 Nkind
(Discrete_Choice
) = N_Others_Choice
;
2411 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
2413 UI_Low
:= Expr_Value
(Low
);
2414 UI_High
:= Expr_Value
(High
);
2416 exit Find_Discrete_Value
when
2417 UI_Low
<= UI_Discrim_Value
2419 UI_High
>= UI_Discrim_Value
;
2421 Next
(Discrete_Choice
);
2424 Next_Non_Pragma
(Variant
);
2425 end loop Find_Discrete_Value
;
2426 end Search_For_Discriminant_Value
;
2428 if No
(Variant
) then
2430 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
2431 Report_Errors
:= True;
2435 -- If we have found the corresponding choice, recursively add its
2436 -- components to the Into list.
2438 Gather_Components
(Empty
,
2439 Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
2440 end Gather_Components
;
2442 ------------------------
2443 -- Get_Actual_Subtype --
2444 ------------------------
2446 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
2447 Typ
: constant Entity_Id
:= Etype
(N
);
2448 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
2453 if not Present
(Utyp
) then
2457 -- If what we have is an identifier that references a subprogram
2458 -- formal, or a variable or constant object, then we get the actual
2459 -- subtype from the referenced entity if one has been built.
2461 if Nkind
(N
) = N_Identifier
2463 (Is_Formal
(Entity
(N
))
2464 or else Ekind
(Entity
(N
)) = E_Constant
2465 or else Ekind
(Entity
(N
)) = E_Variable
)
2466 and then Present
(Actual_Subtype
(Entity
(N
)))
2468 return Actual_Subtype
(Entity
(N
));
2470 -- Actual subtype of unchecked union is always itself. We never need
2471 -- the "real" actual subtype. If we did, we couldn't get it anyway
2472 -- because the discriminant is not available. The restrictions on
2473 -- Unchecked_Union are designed to make sure that this is OK.
2475 elsif Is_Unchecked_Union
(Base_Type
(Utyp
)) then
2478 -- Here for the unconstrained case, we must find actual subtype
2479 -- No actual subtype is available, so we must build it on the fly.
2481 -- Checking the type, not the underlying type, for constrainedness
2482 -- seems to be necessary. Maybe all the tests should be on the type???
2484 elsif (not Is_Constrained
(Typ
))
2485 and then (Is_Array_Type
(Utyp
)
2486 or else (Is_Record_Type
(Utyp
)
2487 and then Has_Discriminants
(Utyp
)))
2488 and then not Has_Unknown_Discriminants
(Utyp
)
2489 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
2491 -- Nothing to do if in default expression
2493 if In_Default_Expression
then
2496 elsif Is_Private_Type
(Typ
)
2497 and then not Has_Discriminants
(Typ
)
2499 -- If the type has no discriminants, there is no subtype to
2500 -- build, even if the underlying type is discriminated.
2504 -- Else build the actual subtype
2507 Decl
:= Build_Actual_Subtype
(Typ
, N
);
2508 Atyp
:= Defining_Identifier
(Decl
);
2510 -- If Build_Actual_Subtype generated a new declaration then use it
2514 -- The actual subtype is an Itype, so analyze the declaration,
2515 -- but do not attach it to the tree, to get the type defined.
2517 Set_Parent
(Decl
, N
);
2518 Set_Is_Itype
(Atyp
);
2519 Analyze
(Decl
, Suppress
=> All_Checks
);
2520 Set_Associated_Node_For_Itype
(Atyp
, N
);
2521 Set_Has_Delayed_Freeze
(Atyp
, False);
2523 -- We need to freeze the actual subtype immediately. This is
2524 -- needed, because otherwise this Itype will not get frozen
2525 -- at all, and it is always safe to freeze on creation because
2526 -- any associated types must be frozen at this point.
2528 Freeze_Itype
(Atyp
, N
);
2531 -- Otherwise we did not build a declaration, so return original
2538 -- For all remaining cases, the actual subtype is the same as
2539 -- the nominal type.
2544 end Get_Actual_Subtype
;
2546 -------------------------------------
2547 -- Get_Actual_Subtype_If_Available --
2548 -------------------------------------
2550 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
2551 Typ
: constant Entity_Id
:= Etype
(N
);
2554 -- If what we have is an identifier that references a subprogram
2555 -- formal, or a variable or constant object, then we get the actual
2556 -- subtype from the referenced entity if one has been built.
2558 if Nkind
(N
) = N_Identifier
2560 (Is_Formal
(Entity
(N
))
2561 or else Ekind
(Entity
(N
)) = E_Constant
2562 or else Ekind
(Entity
(N
)) = E_Variable
)
2563 and then Present
(Actual_Subtype
(Entity
(N
)))
2565 return Actual_Subtype
(Entity
(N
));
2567 -- Otherwise the Etype of N is returned unchanged
2572 end Get_Actual_Subtype_If_Available
;
2574 -------------------------------
2575 -- Get_Default_External_Name --
2576 -------------------------------
2578 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
2580 Get_Decoded_Name_String
(Chars
(E
));
2582 if Opt
.External_Name_Imp_Casing
= Uppercase
then
2583 Set_Casing
(All_Upper_Case
);
2585 Set_Casing
(All_Lower_Case
);
2589 Make_String_Literal
(Sloc
(E
),
2590 Strval
=> String_From_Name_Buffer
);
2591 end Get_Default_External_Name
;
2593 ---------------------------
2594 -- Get_Enum_Lit_From_Pos --
2595 ---------------------------
2597 function Get_Enum_Lit_From_Pos
2600 Loc
: Source_Ptr
) return Node_Id
2605 -- In the case where the literal is of type Character, Wide_Character
2606 -- or Wide_Wide_Character or of a type derived from them, there needs
2607 -- to be some special handling since there is no explicit chain of
2608 -- literals to search. Instead, an N_Character_Literal node is created
2609 -- with the appropriate Char_Code and Chars fields.
2611 if Root_Type
(T
) = Standard_Character
2612 or else Root_Type
(T
) = Standard_Wide_Character
2613 or else Root_Type
(T
) = Standard_Wide_Wide_Character
2615 Set_Character_Literal_Name
(UI_To_CC
(Pos
));
2617 Make_Character_Literal
(Loc
,
2619 Char_Literal_Value
=> Pos
);
2621 -- For all other cases, we have a complete table of literals, and
2622 -- we simply iterate through the chain of literal until the one
2623 -- with the desired position value is found.
2627 Lit
:= First_Literal
(Base_Type
(T
));
2628 for J
in 1 .. UI_To_Int
(Pos
) loop
2632 return New_Occurrence_Of
(Lit
, Loc
);
2634 end Get_Enum_Lit_From_Pos
;
2636 ------------------------
2637 -- Get_Generic_Entity --
2638 ------------------------
2640 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
2641 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2643 if Present
(Renamed_Object
(Ent
)) then
2644 return Renamed_Object
(Ent
);
2648 end Get_Generic_Entity
;
2650 ----------------------
2651 -- Get_Index_Bounds --
2652 ----------------------
2654 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
2655 Kind
: constant Node_Kind
:= Nkind
(N
);
2659 if Kind
= N_Range
then
2661 H
:= High_Bound
(N
);
2663 elsif Kind
= N_Subtype_Indication
then
2664 R
:= Range_Expression
(Constraint
(N
));
2672 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
2673 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
2676 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
2677 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
2681 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
2682 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
2685 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
2686 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
2690 -- N is an expression, indicating a range with one value
2695 end Get_Index_Bounds
;
2697 ----------------------------------
2698 -- Get_Library_Unit_Name_string --
2699 ----------------------------------
2701 procedure Get_Library_Unit_Name_String
(Decl_Node
: Node_Id
) is
2702 Unit_Name_Id
: constant Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
2705 Get_Unit_Name_String
(Unit_Name_Id
);
2707 -- Remove seven last character (" (spec)" or " (body)")
2709 Name_Len
:= Name_Len
- 7;
2710 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
2711 end Get_Library_Unit_Name_String
;
2713 ------------------------
2714 -- Get_Name_Entity_Id --
2715 ------------------------
2717 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
2719 return Entity_Id
(Get_Name_Table_Info
(Id
));
2720 end Get_Name_Entity_Id
;
2722 ---------------------------
2723 -- Get_Referenced_Object --
2724 ---------------------------
2726 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
2730 while Is_Entity_Name
(R
)
2731 and then Present
(Renamed_Object
(Entity
(R
)))
2733 R
:= Renamed_Object
(Entity
(R
));
2737 end Get_Referenced_Object
;
2739 -------------------------
2740 -- Get_Subprogram_Body --
2741 -------------------------
2743 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
2747 Decl
:= Unit_Declaration_Node
(E
);
2749 if Nkind
(Decl
) = N_Subprogram_Body
then
2752 -- The below comment is bad, because it is possible for
2753 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
2755 else -- Nkind (Decl) = N_Subprogram_Declaration
2757 if Present
(Corresponding_Body
(Decl
)) then
2758 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2760 -- Imported subprogram case
2766 end Get_Subprogram_Body
;
2768 -----------------------------
2769 -- Get_Task_Body_Procedure --
2770 -----------------------------
2772 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
2774 -- Note: A task type may be the completion of a private type with
2775 -- discriminants. when performing elaboration checks on a task
2776 -- declaration, the current view of the type may be the private one,
2777 -- and the procedure that holds the body of the task is held in its
2780 return Task_Body_Procedure
(Underlying_Type
(Root_Type
(E
)));
2781 end Get_Task_Body_Procedure
;
2783 -----------------------
2784 -- Has_Access_Values --
2785 -----------------------
2787 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
2788 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
2791 -- Case of a private type which is not completed yet. This can only
2792 -- happen in the case of a generic format type appearing directly, or
2793 -- as a component of the type to which this function is being applied
2794 -- at the top level. Return False in this case, since we certainly do
2795 -- not know that the type contains access types.
2800 elsif Is_Access_Type
(Typ
) then
2803 elsif Is_Array_Type
(Typ
) then
2804 return Has_Access_Values
(Component_Type
(Typ
));
2806 elsif Is_Record_Type
(Typ
) then
2811 Comp
:= First_Entity
(Typ
);
2812 while Present
(Comp
) loop
2813 if (Ekind
(Comp
) = E_Component
2815 Ekind
(Comp
) = E_Discriminant
)
2816 and then Has_Access_Values
(Etype
(Comp
))
2830 end Has_Access_Values
;
2832 ----------------------
2833 -- Has_Declarations --
2834 ----------------------
2836 function Has_Declarations
(N
: Node_Id
) return Boolean is
2837 K
: constant Node_Kind
:= Nkind
(N
);
2839 return K
= N_Accept_Statement
2840 or else K
= N_Block_Statement
2841 or else K
= N_Compilation_Unit_Aux
2842 or else K
= N_Entry_Body
2843 or else K
= N_Package_Body
2844 or else K
= N_Protected_Body
2845 or else K
= N_Subprogram_Body
2846 or else K
= N_Task_Body
2847 or else K
= N_Package_Specification
;
2848 end Has_Declarations
;
2850 -------------------------------------------
2851 -- Has_Discriminant_Dependent_Constraint --
2852 -------------------------------------------
2854 function Has_Discriminant_Dependent_Constraint
2855 (Comp
: Entity_Id
) return Boolean
2857 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
2858 Subt_Indic
: constant Node_Id
:=
2859 Subtype_Indication
(Component_Definition
(Comp_Decl
));
2864 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
2865 Constr
:= Constraint
(Subt_Indic
);
2867 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
2868 Assn
:= First
(Constraints
(Constr
));
2869 while Present
(Assn
) loop
2870 case Nkind
(Assn
) is
2871 when N_Subtype_Indication |
2875 if Depends_On_Discriminant
(Assn
) then
2879 when N_Discriminant_Association
=>
2880 if Depends_On_Discriminant
(Expression
(Assn
)) then
2895 end Has_Discriminant_Dependent_Constraint
;
2897 --------------------
2898 -- Has_Infinities --
2899 --------------------
2901 function Has_Infinities
(E
: Entity_Id
) return Boolean is
2904 Is_Floating_Point_Type
(E
)
2905 and then Nkind
(Scalar_Range
(E
)) = N_Range
2906 and then Includes_Infinities
(Scalar_Range
(E
));
2909 ------------------------
2910 -- Has_Null_Extension --
2911 ------------------------
2913 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
2914 B
: constant Entity_Id
:= Base_Type
(T
);
2919 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
2920 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
2922 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
2924 if Present
(Ext
) then
2925 if Null_Present
(Ext
) then
2928 Comps
:= Component_List
(Ext
);
2930 -- The null component list is rewritten during analysis to
2931 -- include the parent component. Any other component indicates
2932 -- that the extension was not originally null.
2934 return Null_Present
(Comps
)
2935 or else No
(Next
(First
(Component_Items
(Comps
))));
2944 end Has_Null_Extension
;
2946 ---------------------------
2947 -- Has_Private_Component --
2948 ---------------------------
2950 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
2951 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
2952 Component
: Entity_Id
;
2955 if Error_Posted
(Type_Id
)
2956 or else Error_Posted
(Btype
)
2961 if Is_Class_Wide_Type
(Btype
) then
2962 Btype
:= Root_Type
(Btype
);
2965 if Is_Private_Type
(Btype
) then
2967 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
2971 if No
(Full_View
(Btype
)) then
2972 return not Is_Generic_Type
(Btype
)
2973 and then not Is_Generic_Type
(Root_Type
(Btype
));
2976 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
2980 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
2983 elsif Is_Array_Type
(Btype
) then
2984 return Has_Private_Component
(Component_Type
(Btype
));
2986 elsif Is_Record_Type
(Btype
) then
2988 Component
:= First_Component
(Btype
);
2989 while Present
(Component
) loop
2991 if Has_Private_Component
(Etype
(Component
)) then
2995 Next_Component
(Component
);
3000 elsif Is_Protected_Type
(Btype
)
3001 and then Present
(Corresponding_Record_Type
(Btype
))
3003 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
3008 end Has_Private_Component
;
3014 function Has_Stream
(T
: Entity_Id
) return Boolean is
3021 elsif Is_RTE
(Root_Type
(T
), RE_Root_Stream_Type
) then
3024 elsif Is_Array_Type
(T
) then
3025 return Has_Stream
(Component_Type
(T
));
3027 elsif Is_Record_Type
(T
) then
3028 E
:= First_Component
(T
);
3029 while Present
(E
) loop
3030 if Has_Stream
(Etype
(E
)) then
3039 elsif Is_Private_Type
(T
) then
3040 return Has_Stream
(Underlying_Type
(T
));
3047 --------------------------
3048 -- Has_Tagged_Component --
3049 --------------------------
3051 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
3055 if Is_Private_Type
(Typ
)
3056 and then Present
(Underlying_Type
(Typ
))
3058 return Has_Tagged_Component
(Underlying_Type
(Typ
));
3060 elsif Is_Array_Type
(Typ
) then
3061 return Has_Tagged_Component
(Component_Type
(Typ
));
3063 elsif Is_Tagged_Type
(Typ
) then
3066 elsif Is_Record_Type
(Typ
) then
3067 Comp
:= First_Component
(Typ
);
3069 while Present
(Comp
) loop
3070 if Has_Tagged_Component
(Etype
(Comp
)) then
3074 Comp
:= Next_Component
(Typ
);
3082 end Has_Tagged_Component
;
3088 function In_Instance
return Boolean is
3089 S
: Entity_Id
:= Current_Scope
;
3093 and then S
/= Standard_Standard
3095 if (Ekind
(S
) = E_Function
3096 or else Ekind
(S
) = E_Package
3097 or else Ekind
(S
) = E_Procedure
)
3098 and then Is_Generic_Instance
(S
)
3109 ----------------------
3110 -- In_Instance_Body --
3111 ----------------------
3113 function In_Instance_Body
return Boolean is
3114 S
: Entity_Id
:= Current_Scope
;
3118 and then S
/= Standard_Standard
3120 if (Ekind
(S
) = E_Function
3121 or else Ekind
(S
) = E_Procedure
)
3122 and then Is_Generic_Instance
(S
)
3126 elsif Ekind
(S
) = E_Package
3127 and then In_Package_Body
(S
)
3128 and then Is_Generic_Instance
(S
)
3137 end In_Instance_Body
;
3139 -----------------------------
3140 -- In_Instance_Not_Visible --
3141 -----------------------------
3143 function In_Instance_Not_Visible
return Boolean is
3144 S
: Entity_Id
:= Current_Scope
;
3148 and then S
/= Standard_Standard
3150 if (Ekind
(S
) = E_Function
3151 or else Ekind
(S
) = E_Procedure
)
3152 and then Is_Generic_Instance
(S
)
3156 elsif Ekind
(S
) = E_Package
3157 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
3158 and then Is_Generic_Instance
(S
)
3167 end In_Instance_Not_Visible
;
3169 ------------------------------
3170 -- In_Instance_Visible_Part --
3171 ------------------------------
3173 function In_Instance_Visible_Part
return Boolean is
3174 S
: Entity_Id
:= Current_Scope
;
3178 and then S
/= Standard_Standard
3180 if Ekind
(S
) = E_Package
3181 and then Is_Generic_Instance
(S
)
3182 and then not In_Package_Body
(S
)
3183 and then not In_Private_Part
(S
)
3192 end In_Instance_Visible_Part
;
3194 ----------------------
3195 -- In_Packiage_Body --
3196 ----------------------
3198 function In_Package_Body
return Boolean is
3199 S
: Entity_Id
:= Current_Scope
;
3203 and then S
/= Standard_Standard
3205 if Ekind
(S
) = E_Package
3206 and then In_Package_Body
(S
)
3215 end In_Package_Body
;
3217 --------------------------------------
3218 -- In_Subprogram_Or_Concurrent_Unit --
3219 --------------------------------------
3221 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
3226 -- Use scope chain to check successively outer scopes
3232 if K
in Subprogram_Kind
3233 or else K
in Concurrent_Kind
3234 or else K
in Generic_Subprogram_Kind
3238 elsif E
= Standard_Standard
then
3244 end In_Subprogram_Or_Concurrent_Unit
;
3246 ---------------------
3247 -- In_Visible_Part --
3248 ---------------------
3250 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
3253 Is_Package_Or_Generic_Package
(Scope_Id
)
3254 and then In_Open_Scopes
(Scope_Id
)
3255 and then not In_Package_Body
(Scope_Id
)
3256 and then not In_Private_Part
(Scope_Id
);
3257 end In_Visible_Part
;
3259 ---------------------------------
3260 -- Insert_Explicit_Dereference --
3261 ---------------------------------
3263 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
3264 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
3265 Ent
: Entity_Id
:= Empty
;
3272 Save_Interps
(N
, New_Prefix
);
3274 Make_Explicit_Dereference
(Sloc
(N
), Prefix
=> New_Prefix
));
3276 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
3278 if Is_Overloaded
(New_Prefix
) then
3280 -- The deference is also overloaded, and its interpretations are the
3281 -- designated types of the interpretations of the original node.
3283 Set_Etype
(N
, Any_Type
);
3284 Get_First_Interp
(New_Prefix
, I
, It
);
3286 while Present
(It
.Nam
) loop
3289 if Is_Access_Type
(T
) then
3290 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
3293 Get_Next_Interp
(I
, It
);
3299 -- Prefix is unambiguous: mark the original prefix (which might
3300 -- Come_From_Source) as a reference, since the new (relocated) one
3301 -- won't be taken into account.
3303 if Is_Entity_Name
(New_Prefix
) then
3304 Ent
:= Entity
(New_Prefix
);
3306 -- For a retrieval of a subcomponent of some composite object,
3307 -- retrieve the ultimate entity if there is one.
3309 elsif Nkind
(New_Prefix
) = N_Selected_Component
3310 or else Nkind
(New_Prefix
) = N_Indexed_Component
3312 Pref
:= Prefix
(New_Prefix
);
3314 while Present
(Pref
)
3316 (Nkind
(Pref
) = N_Selected_Component
3317 or else Nkind
(Pref
) = N_Indexed_Component
)
3319 Pref
:= Prefix
(Pref
);
3322 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
3323 Ent
:= Entity
(Pref
);
3327 if Present
(Ent
) then
3328 Generate_Reference
(Ent
, New_Prefix
);
3331 end Insert_Explicit_Dereference
;
3337 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
3339 pragma Assert
(Is_Type
(E
));
3341 return AAMP_On_Target
3342 and then Is_Floating_Point_Type
(E
)
3343 and then E
= Base_Type
(E
);
3346 -------------------------
3347 -- Is_Actual_Parameter --
3348 -------------------------
3350 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
3351 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3355 when N_Parameter_Association
=>
3356 return N
= Explicit_Actual_Parameter
(Parent
(N
));
3358 when N_Function_Call | N_Procedure_Call_Statement
=>
3359 return Is_List_Member
(N
)
3361 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
3366 end Is_Actual_Parameter
;
3368 ---------------------
3369 -- Is_Aliased_View --
3370 ---------------------
3372 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
3376 if Is_Entity_Name
(Obj
) then
3384 or else (Present
(Renamed_Object
(E
))
3385 and then Is_Aliased_View
(Renamed_Object
(E
)))))
3387 or else ((Is_Formal
(E
)
3388 or else Ekind
(E
) = E_Generic_In_Out_Parameter
3389 or else Ekind
(E
) = E_Generic_In_Parameter
)
3390 and then Is_Tagged_Type
(Etype
(E
)))
3392 or else ((Ekind
(E
) = E_Task_Type
3393 or else Ekind
(E
) = E_Protected_Type
)
3394 and then In_Open_Scopes
(E
))
3396 -- Current instance of type
3398 or else (Is_Type
(E
) and then E
= Current_Scope
)
3399 or else (Is_Incomplete_Or_Private_Type
(E
)
3400 and then Full_View
(E
) = Current_Scope
);
3402 elsif Nkind
(Obj
) = N_Selected_Component
then
3403 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
3405 elsif Nkind
(Obj
) = N_Indexed_Component
then
3406 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
3408 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
3410 Has_Aliased_Components
3411 (Designated_Type
(Etype
(Prefix
(Obj
)))));
3413 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
3414 or else Nkind
(Obj
) = N_Type_Conversion
3416 return Is_Tagged_Type
(Etype
(Obj
))
3417 and then Is_Aliased_View
(Expression
(Obj
));
3419 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
3420 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
3425 end Is_Aliased_View
;
3427 -------------------------
3428 -- Is_Ancestor_Package --
3429 -------------------------
3431 function Is_Ancestor_Package
3433 E2
: Entity_Id
) return Boolean
3440 and then Par
/= Standard_Standard
3450 end Is_Ancestor_Package
;
3452 ----------------------
3453 -- Is_Atomic_Object --
3454 ----------------------
3456 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
3458 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
3459 -- Determines if given object has atomic components
3461 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
3462 -- If prefix is an implicit dereference, examine designated type
3464 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
3466 if Is_Access_Type
(Etype
(N
)) then
3468 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
3470 return Object_Has_Atomic_Components
(N
);
3472 end Is_Atomic_Prefix
;
3474 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
3476 if Has_Atomic_Components
(Etype
(N
))
3477 or else Is_Atomic
(Etype
(N
))
3481 elsif Is_Entity_Name
(N
)
3482 and then (Has_Atomic_Components
(Entity
(N
))
3483 or else Is_Atomic
(Entity
(N
)))
3487 elsif Nkind
(N
) = N_Indexed_Component
3488 or else Nkind
(N
) = N_Selected_Component
3490 return Is_Atomic_Prefix
(Prefix
(N
));
3495 end Object_Has_Atomic_Components
;
3497 -- Start of processing for Is_Atomic_Object
3500 if Is_Atomic
(Etype
(N
))
3501 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
3505 elsif Nkind
(N
) = N_Indexed_Component
3506 or else Nkind
(N
) = N_Selected_Component
3508 return Is_Atomic_Prefix
(Prefix
(N
));
3513 end Is_Atomic_Object
;
3515 --------------------------------------
3516 -- Is_Controlling_Limited_Procedure --
3517 --------------------------------------
3519 function Is_Controlling_Limited_Procedure
3520 (Proc_Nam
: Entity_Id
) return Boolean
3522 Param_Typ
: Entity_Id
:= Empty
;
3525 if Ekind
(Proc_Nam
) = E_Procedure
3526 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
3528 Param_Typ
:= Etype
(Parameter_Type
(First
(
3529 Parameter_Specifications
(Parent
(Proc_Nam
)))));
3531 -- In this case where an Itype was created, the procedure call has been
3534 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
3535 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
3537 Present
(Parameter_Associations
3538 (Associated_Node_For_Itype
(Proc_Nam
)))
3541 Etype
(First
(Parameter_Associations
3542 (Associated_Node_For_Itype
(Proc_Nam
))));
3545 if Present
(Param_Typ
) then
3547 Is_Interface
(Param_Typ
)
3548 and then Is_Limited_Record
(Param_Typ
);
3552 end Is_Controlling_Limited_Procedure
;
3554 ----------------------------------------------
3555 -- Is_Dependent_Component_Of_Mutable_Object --
3556 ----------------------------------------------
3558 function Is_Dependent_Component_Of_Mutable_Object
3559 (Object
: Node_Id
) return Boolean
3562 Prefix_Type
: Entity_Id
;
3563 P_Aliased
: Boolean := False;
3566 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
3567 -- Returns True if and only if Comp is declared within a variant part
3569 --------------------------------
3570 -- Is_Declared_Within_Variant --
3571 --------------------------------
3573 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
3574 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3575 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
3577 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
3578 end Is_Declared_Within_Variant
;
3580 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
3583 if Is_Variable
(Object
) then
3585 if Nkind
(Object
) = N_Selected_Component
then
3586 P
:= Prefix
(Object
);
3587 Prefix_Type
:= Etype
(P
);
3589 if Is_Entity_Name
(P
) then
3591 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
3592 Prefix_Type
:= Base_Type
(Prefix_Type
);
3595 if Is_Aliased
(Entity
(P
)) then
3599 -- A discriminant check on a selected component may be
3600 -- expanded into a dereference when removing side-effects.
3601 -- Recover the original node and its type, which may be
3604 elsif Nkind
(P
) = N_Explicit_Dereference
3605 and then not (Comes_From_Source
(P
))
3607 P
:= Original_Node
(P
);
3608 Prefix_Type
:= Etype
(P
);
3611 -- Check for prefix being an aliased component ???
3616 -- A heap object is constrained by its initial value
3618 -- Ada 2005 AI-363:if the designated type is a type with a
3619 -- constrained partial view, the resulting heap object is not
3620 -- constrained, and a renaming of the component is now unsafe.
3622 if Is_Access_Type
(Prefix_Type
)
3624 not Has_Constrained_Partial_View
3625 (Designated_Type
(Prefix_Type
))
3629 elsif Nkind
(P
) = N_Explicit_Dereference
3630 and then not Has_Constrained_Partial_View
(Prefix_Type
)
3636 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
3638 -- As per AI-0017, the renaming is illegal in a generic body,
3639 -- even if the subtype is indefinite.
3641 if not Is_Constrained
(Prefix_Type
)
3642 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
3644 (Is_Generic_Type
(Prefix_Type
)
3645 and then Ekind
(Current_Scope
) = E_Generic_Package
3646 and then In_Package_Body
(Current_Scope
)))
3648 and then (Is_Declared_Within_Variant
(Comp
)
3649 or else Has_Discriminant_Dependent_Constraint
(Comp
))
3650 and then not P_Aliased
3656 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3660 elsif Nkind
(Object
) = N_Indexed_Component
3661 or else Nkind
(Object
) = N_Slice
3663 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3665 -- A type conversion that Is_Variable is a view conversion:
3666 -- go back to the denoted object.
3668 elsif Nkind
(Object
) = N_Type_Conversion
then
3670 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
3675 end Is_Dependent_Component_Of_Mutable_Object
;
3677 ---------------------
3678 -- Is_Dereferenced --
3679 ---------------------
3681 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
3682 P
: constant Node_Id
:= Parent
(N
);
3685 (Nkind
(P
) = N_Selected_Component
3687 Nkind
(P
) = N_Explicit_Dereference
3689 Nkind
(P
) = N_Indexed_Component
3691 Nkind
(P
) = N_Slice
)
3692 and then Prefix
(P
) = N
;
3693 end Is_Dereferenced
;
3695 ----------------------
3696 -- Is_Descendent_Of --
3697 ----------------------
3699 function Is_Descendent_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
3704 pragma Assert
(Nkind
(T1
) in N_Entity
);
3705 pragma Assert
(Nkind
(T2
) in N_Entity
);
3707 T
:= Base_Type
(T1
);
3709 -- Immediate return if the types match
3714 -- Comment needed here ???
3716 elsif Ekind
(T
) = E_Class_Wide_Type
then
3717 return Etype
(T
) = T2
;
3725 -- Done if we found the type we are looking for
3730 -- Done if no more derivations to check
3737 -- Following test catches error cases resulting from prev errors
3739 elsif No
(Etyp
) then
3742 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
3745 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
3749 T
:= Base_Type
(Etyp
);
3753 raise Program_Error
;
3754 end Is_Descendent_Of
;
3756 ------------------------------
3757 -- Is_Descendent_Of_Address --
3758 ------------------------------
3760 function Is_Descendent_Of_Address
(T1
: Entity_Id
) return Boolean is
3762 -- If Address has not been loaded, answer must be False
3764 if not RTU_Loaded
(System
) then
3767 -- Otherwise we can get the entity we are interested in without
3768 -- causing an unwanted dependency on System, and do the test.
3771 return Is_Descendent_Of
(T1
, Base_Type
(RTE
(RE_Address
)));
3773 end Is_Descendent_Of_Address
;
3779 function Is_False
(U
: Uint
) return Boolean is
3784 ---------------------------
3785 -- Is_Fixed_Model_Number --
3786 ---------------------------
3788 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
3789 S
: constant Ureal
:= Small_Value
(T
);
3790 M
: Urealp
.Save_Mark
;
3794 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
3797 end Is_Fixed_Model_Number
;
3799 -------------------------------
3800 -- Is_Fully_Initialized_Type --
3801 -------------------------------
3803 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
3805 if Is_Scalar_Type
(Typ
) then
3808 elsif Is_Access_Type
(Typ
) then
3811 elsif Is_Array_Type
(Typ
) then
3812 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
3816 -- An interesting case, if we have a constrained type one of whose
3817 -- bounds is known to be null, then there are no elements to be
3818 -- initialized, so all the elements are initialized!
3820 if Is_Constrained
(Typ
) then
3823 Indx_Typ
: Entity_Id
;
3827 Indx
:= First_Index
(Typ
);
3828 while Present
(Indx
) loop
3830 if Etype
(Indx
) = Any_Type
then
3833 -- If index is a range, use directly
3835 elsif Nkind
(Indx
) = N_Range
then
3836 Lbd
:= Low_Bound
(Indx
);
3837 Hbd
:= High_Bound
(Indx
);
3840 Indx_Typ
:= Etype
(Indx
);
3842 if Is_Private_Type
(Indx_Typ
) then
3843 Indx_Typ
:= Full_View
(Indx_Typ
);
3846 if No
(Indx_Typ
) then
3849 Lbd
:= Type_Low_Bound
(Indx_Typ
);
3850 Hbd
:= Type_High_Bound
(Indx_Typ
);
3854 if Compile_Time_Known_Value
(Lbd
)
3855 and then Compile_Time_Known_Value
(Hbd
)
3857 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
3867 -- If no null indexes, then type is not fully initialized
3873 elsif Is_Record_Type
(Typ
) then
3874 if Has_Discriminants
(Typ
)
3876 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
3877 and then Is_Fully_Initialized_Variant
(Typ
)
3882 -- Controlled records are considered to be fully initialized if
3883 -- there is a user defined Initialize routine. This may not be
3884 -- entirely correct, but as the spec notes, we are guessing here
3885 -- what is best from the point of view of issuing warnings.
3887 if Is_Controlled
(Typ
) then
3889 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3892 if Present
(Utyp
) then
3894 Init
: constant Entity_Id
:=
3896 (Underlying_Type
(Typ
), Name_Initialize
));
3900 and then Comes_From_Source
(Init
)
3902 Is_Predefined_File_Name
3903 (File_Name
(Get_Source_File_Index
(Sloc
(Init
))))
3907 elsif Has_Null_Extension
(Typ
)
3909 Is_Fully_Initialized_Type
3910 (Etype
(Base_Type
(Typ
)))
3919 -- Otherwise see if all record components are initialized
3925 Ent
:= First_Entity
(Typ
);
3927 while Present
(Ent
) loop
3928 if Chars
(Ent
) = Name_uController
then
3931 elsif Ekind
(Ent
) = E_Component
3932 and then (No
(Parent
(Ent
))
3933 or else No
(Expression
(Parent
(Ent
))))
3934 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
3943 -- No uninitialized components, so type is fully initialized.
3944 -- Note that this catches the case of no components as well.
3948 elsif Is_Concurrent_Type
(Typ
) then
3951 elsif Is_Private_Type
(Typ
) then
3953 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3959 return Is_Fully_Initialized_Type
(U
);
3966 end Is_Fully_Initialized_Type
;
3968 ----------------------------------
3969 -- Is_Fully_Initialized_Variant --
3970 ----------------------------------
3972 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
3973 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
3974 Constraints
: constant List_Id
:= New_List
;
3975 Components
: constant Elist_Id
:= New_Elmt_List
;
3976 Comp_Elmt
: Elmt_Id
;
3978 Comp_List
: Node_Id
;
3980 Discr_Val
: Node_Id
;
3981 Report_Errors
: Boolean;
3984 if Serious_Errors_Detected
> 0 then
3988 if Is_Record_Type
(Typ
)
3989 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
3990 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
3992 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
3993 Discr
:= First_Discriminant
(Typ
);
3995 while Present
(Discr
) loop
3996 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
3997 Discr_Val
:= Expression
(Parent
(Discr
));
3999 if Present
(Discr_Val
)
4000 and then Is_OK_Static_Expression
(Discr_Val
)
4002 Append_To
(Constraints
,
4003 Make_Component_Association
(Loc
,
4004 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
4005 Expression
=> New_Copy
(Discr_Val
)));
4013 Next_Discriminant
(Discr
);
4018 Comp_List
=> Comp_List
,
4019 Governed_By
=> Constraints
,
4021 Report_Errors
=> Report_Errors
);
4023 -- Check that each component present is fully initialized
4025 Comp_Elmt
:= First_Elmt
(Components
);
4027 while Present
(Comp_Elmt
) loop
4028 Comp_Id
:= Node
(Comp_Elmt
);
4030 if Ekind
(Comp_Id
) = E_Component
4031 and then (No
(Parent
(Comp_Id
))
4032 or else No
(Expression
(Parent
(Comp_Id
))))
4033 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
4038 Next_Elmt
(Comp_Elmt
);
4043 elsif Is_Private_Type
(Typ
) then
4045 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4051 return Is_Fully_Initialized_Variant
(U
);
4057 end Is_Fully_Initialized_Variant
;
4059 ----------------------------
4060 -- Is_Inherited_Operation --
4061 ----------------------------
4063 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
4064 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
4066 pragma Assert
(Is_Overloadable
(E
));
4067 return Kind
= N_Full_Type_Declaration
4068 or else Kind
= N_Private_Extension_Declaration
4069 or else Kind
= N_Subtype_Declaration
4070 or else (Ekind
(E
) = E_Enumeration_Literal
4071 and then Is_Derived_Type
(Etype
(E
)));
4072 end Is_Inherited_Operation
;
4074 -----------------------------
4075 -- Is_Library_Level_Entity --
4076 -----------------------------
4078 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
4080 -- The following is a small optimization, and it also handles
4081 -- properly discriminals, which in task bodies might appear in
4082 -- expressions before the corresponding procedure has been
4083 -- created, and which therefore do not have an assigned scope.
4085 if Ekind
(E
) in Formal_Kind
then
4089 -- Normal test is simply that the enclosing dynamic scope is Standard
4091 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
4092 end Is_Library_Level_Entity
;
4094 ---------------------------------
4095 -- Is_Local_Variable_Reference --
4096 ---------------------------------
4098 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
4100 if not Is_Entity_Name
(Expr
) then
4105 Ent
: constant Entity_Id
:= Entity
(Expr
);
4106 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
4108 if Ekind
(Ent
) /= E_Variable
4110 Ekind
(Ent
) /= E_In_Out_Parameter
4114 return Present
(Sub
) and then Sub
= Current_Subprogram
;
4118 end Is_Local_Variable_Reference
;
4124 function Is_Lvalue
(N
: Node_Id
) return Boolean is
4125 P
: constant Node_Id
:= Parent
(N
);
4130 -- Test left side of assignment
4132 when N_Assignment_Statement
=>
4133 return N
= Name
(P
);
4135 -- Test prefix of component or attribute
4137 when N_Attribute_Reference |
4139 N_Explicit_Dereference |
4140 N_Indexed_Component |
4142 N_Selected_Component |
4144 return N
= Prefix
(P
);
4146 -- Test subprogram parameter (we really should check the
4147 -- parameter mode, but it is not worth the trouble)
4149 when N_Function_Call |
4150 N_Procedure_Call_Statement |
4151 N_Accept_Statement |
4152 N_Parameter_Association
=>
4155 -- Test for appearing in a conversion that itself appears
4156 -- in an lvalue context, since this should be an lvalue.
4158 when N_Type_Conversion
=>
4159 return Is_Lvalue
(P
);
4161 -- Test for appearence in object renaming declaration
4163 when N_Object_Renaming_Declaration
=>
4166 -- All other references are definitely not Lvalues
4174 -------------------------
4175 -- Is_Object_Reference --
4176 -------------------------
4178 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
4180 if Is_Entity_Name
(N
) then
4181 return Is_Object
(Entity
(N
));
4185 when N_Indexed_Component | N_Slice
=>
4187 Is_Object_Reference
(Prefix
(N
))
4188 or else Is_Access_Type
(Etype
(Prefix
(N
)));
4190 -- In Ada95, a function call is a constant object; a procedure
4193 when N_Function_Call
=>
4194 return Etype
(N
) /= Standard_Void_Type
;
4196 -- A reference to the stream attribute Input is a function call
4198 when N_Attribute_Reference
=>
4199 return Attribute_Name
(N
) = Name_Input
;
4201 when N_Selected_Component
=>
4203 Is_Object_Reference
(Selector_Name
(N
))
4205 (Is_Object_Reference
(Prefix
(N
))
4206 or else Is_Access_Type
(Etype
(Prefix
(N
))));
4208 when N_Explicit_Dereference
=>
4211 -- A view conversion of a tagged object is an object reference
4213 when N_Type_Conversion
=>
4214 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
4215 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
4216 and then Is_Object_Reference
(Expression
(N
));
4218 -- An unchecked type conversion is considered to be an object if
4219 -- the operand is an object (this construction arises only as a
4220 -- result of expansion activities).
4222 when N_Unchecked_Type_Conversion
=>
4229 end Is_Object_Reference
;
4231 -----------------------------------
4232 -- Is_OK_Variable_For_Out_Formal --
4233 -----------------------------------
4235 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
4237 Note_Possible_Modification
(AV
);
4239 -- We must reject parenthesized variable names. The check for
4240 -- Comes_From_Source is present because there are currently
4241 -- cases where the compiler violates this rule (e.g. passing
4242 -- a task object to its controlled Initialize routine).
4244 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
4247 -- A variable is always allowed
4249 elsif Is_Variable
(AV
) then
4252 -- Unchecked conversions are allowed only if they come from the
4253 -- generated code, which sometimes uses unchecked conversions for out
4254 -- parameters in cases where code generation is unaffected. We tell
4255 -- source unchecked conversions by seeing if they are rewrites of an
4256 -- original Unchecked_Conversion function call, or of an explicit
4257 -- conversion of a function call.
4259 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
4260 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
4263 elsif Comes_From_Source
(AV
)
4264 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
4268 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
4269 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
4275 -- Normal type conversions are allowed if argument is a variable
4277 elsif Nkind
(AV
) = N_Type_Conversion
then
4278 if Is_Variable
(Expression
(AV
))
4279 and then Paren_Count
(Expression
(AV
)) = 0
4281 Note_Possible_Modification
(Expression
(AV
));
4284 -- We also allow a non-parenthesized expression that raises
4285 -- constraint error if it rewrites what used to be a variable
4287 elsif Raises_Constraint_Error
(Expression
(AV
))
4288 and then Paren_Count
(Expression
(AV
)) = 0
4289 and then Is_Variable
(Original_Node
(Expression
(AV
)))
4293 -- Type conversion of something other than a variable
4299 -- If this node is rewritten, then test the original form, if that is
4300 -- OK, then we consider the rewritten node OK (for example, if the
4301 -- original node is a conversion, then Is_Variable will not be true
4302 -- but we still want to allow the conversion if it converts a variable).
4304 elsif Original_Node
(AV
) /= AV
then
4305 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
4307 -- All other non-variables are rejected
4312 end Is_OK_Variable_For_Out_Formal
;
4314 -----------------------------------
4315 -- Is_Partially_Initialized_Type --
4316 -----------------------------------
4318 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
4320 if Is_Scalar_Type
(Typ
) then
4323 elsif Is_Access_Type
(Typ
) then
4326 elsif Is_Array_Type
(Typ
) then
4328 -- If component type is partially initialized, so is array type
4330 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
4333 -- Otherwise we are only partially initialized if we are fully
4334 -- initialized (this is the empty array case, no point in us
4335 -- duplicating that code here).
4338 return Is_Fully_Initialized_Type
(Typ
);
4341 elsif Is_Record_Type
(Typ
) then
4343 -- A discriminated type is always partially initialized
4345 if Has_Discriminants
(Typ
) then
4348 -- A tagged type is always partially initialized
4350 elsif Is_Tagged_Type
(Typ
) then
4353 -- Case of non-discriminated record
4359 Component_Present
: Boolean := False;
4360 -- Set True if at least one component is present. If no
4361 -- components are present, then record type is fully
4362 -- initialized (another odd case, like the null array).
4365 -- Loop through components
4367 Ent
:= First_Entity
(Typ
);
4368 while Present
(Ent
) loop
4369 if Ekind
(Ent
) = E_Component
then
4370 Component_Present
:= True;
4372 -- If a component has an initialization expression then
4373 -- the enclosing record type is partially initialized
4375 if Present
(Parent
(Ent
))
4376 and then Present
(Expression
(Parent
(Ent
)))
4380 -- If a component is of a type which is itself partially
4381 -- initialized, then the enclosing record type is also.
4383 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
4391 -- No initialized components found. If we found any components
4392 -- they were all uninitialized so the result is false.
4394 if Component_Present
then
4397 -- But if we found no components, then all the components are
4398 -- initialized so we consider the type to be initialized.
4406 -- Concurrent types are always fully initialized
4408 elsif Is_Concurrent_Type
(Typ
) then
4411 -- For a private type, go to underlying type. If there is no underlying
4412 -- type then just assume this partially initialized. Not clear if this
4413 -- can happen in a non-error case, but no harm in testing for this.
4415 elsif Is_Private_Type
(Typ
) then
4417 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4422 return Is_Partially_Initialized_Type
(U
);
4426 -- For any other type (are there any?) assume partially initialized
4431 end Is_Partially_Initialized_Type
;
4433 ------------------------------------
4434 -- Is_Potentially_Persistent_Type --
4435 ------------------------------------
4437 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
4442 -- For private type, test corrresponding full type
4444 if Is_Private_Type
(T
) then
4445 return Is_Potentially_Persistent_Type
(Full_View
(T
));
4447 -- Scalar types are potentially persistent
4449 elsif Is_Scalar_Type
(T
) then
4452 -- Record type is potentially persistent if not tagged and the types of
4453 -- all it components are potentially persistent, and no component has
4454 -- an initialization expression.
4456 elsif Is_Record_Type
(T
)
4457 and then not Is_Tagged_Type
(T
)
4458 and then not Is_Partially_Initialized_Type
(T
)
4460 Comp
:= First_Component
(T
);
4461 while Present
(Comp
) loop
4462 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
4471 -- Array type is potentially persistent if its component type is
4472 -- potentially persistent and if all its constraints are static.
4474 elsif Is_Array_Type
(T
) then
4475 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
4479 Indx
:= First_Index
(T
);
4480 while Present
(Indx
) loop
4481 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
4490 -- All other types are not potentially persistent
4495 end Is_Potentially_Persistent_Type
;
4497 -----------------------------
4498 -- Is_RCI_Pkg_Spec_Or_Body --
4499 -----------------------------
4501 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
4503 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
4504 -- Return True if the unit of Cunit is an RCI package declaration
4506 ---------------------------
4507 -- Is_RCI_Pkg_Decl_Cunit --
4508 ---------------------------
4510 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
4511 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
4514 if Nkind
(The_Unit
) /= N_Package_Declaration
then
4518 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
4519 end Is_RCI_Pkg_Decl_Cunit
;
4521 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
4524 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
4526 (Nkind
(Unit
(Cunit
)) = N_Package_Body
4527 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
4528 end Is_RCI_Pkg_Spec_Or_Body
;
4530 -----------------------------------------
4531 -- Is_Remote_Access_To_Class_Wide_Type --
4532 -----------------------------------------
4534 function Is_Remote_Access_To_Class_Wide_Type
4535 (E
: Entity_Id
) return Boolean
4539 function Comes_From_Limited_Private_Type_Declaration
4540 (E
: Entity_Id
) return Boolean;
4541 -- Check that the type is declared by a limited type declaration,
4542 -- or else is derived from a Remote_Type ancestor through private
4545 -------------------------------------------------
4546 -- Comes_From_Limited_Private_Type_Declaration --
4547 -------------------------------------------------
4549 function Comes_From_Limited_Private_Type_Declaration
4550 (E
: Entity_Id
) return Boolean
4552 N
: constant Node_Id
:= Declaration_Node
(E
);
4555 if Nkind
(N
) = N_Private_Type_Declaration
4556 and then Limited_Present
(N
)
4561 if Nkind
(N
) = N_Private_Extension_Declaration
then
4563 Comes_From_Limited_Private_Type_Declaration
(Etype
(E
))
4565 (Is_Remote_Types
(Etype
(E
))
4566 and then Is_Limited_Record
(Etype
(E
))
4567 and then Has_Private_Declaration
(Etype
(E
)));
4571 end Comes_From_Limited_Private_Type_Declaration
;
4573 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
4576 if not (Is_Remote_Call_Interface
(E
)
4577 or else Is_Remote_Types
(E
))
4578 or else Ekind
(E
) /= E_General_Access_Type
4583 D
:= Designated_Type
(E
);
4585 if Ekind
(D
) /= E_Class_Wide_Type
then
4589 return Comes_From_Limited_Private_Type_Declaration
4590 (Defining_Identifier
(Parent
(D
)));
4591 end Is_Remote_Access_To_Class_Wide_Type
;
4593 -----------------------------------------
4594 -- Is_Remote_Access_To_Subprogram_Type --
4595 -----------------------------------------
4597 function Is_Remote_Access_To_Subprogram_Type
4598 (E
: Entity_Id
) return Boolean
4601 return (Ekind
(E
) = E_Access_Subprogram_Type
4602 or else (Ekind
(E
) = E_Record_Type
4603 and then Present
(Corresponding_Remote_Type
(E
))))
4604 and then (Is_Remote_Call_Interface
(E
)
4605 or else Is_Remote_Types
(E
));
4606 end Is_Remote_Access_To_Subprogram_Type
;
4608 --------------------
4609 -- Is_Remote_Call --
4610 --------------------
4612 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
4614 if Nkind
(N
) /= N_Procedure_Call_Statement
4615 and then Nkind
(N
) /= N_Function_Call
4617 -- An entry call cannot be remote
4621 elsif Nkind
(Name
(N
)) in N_Has_Entity
4622 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
4624 -- A subprogram declared in the spec of a RCI package is remote
4628 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
4629 and then Is_Remote_Access_To_Subprogram_Type
4630 (Etype
(Prefix
(Name
(N
))))
4632 -- The dereference of a RAS is a remote call
4636 elsif Present
(Controlling_Argument
(N
))
4637 and then Is_Remote_Access_To_Class_Wide_Type
4638 (Etype
(Controlling_Argument
(N
)))
4640 -- Any primitive operation call with a controlling argument of
4641 -- a RACW type is a remote call.
4646 -- All other calls are local calls
4651 ----------------------
4652 -- Is_Renamed_Entry --
4653 ----------------------
4655 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
4656 Orig_Node
: Node_Id
:= Empty
;
4657 Subp_Decl
: Node_Id
:= Parent
(Parent
(Proc_Nam
));
4659 function Is_Entry
(Nam
: Node_Id
) return Boolean;
4660 -- Determine whether Nam is an entry. Traverse selectors
4661 -- if there are nested selected components.
4667 function Is_Entry
(Nam
: Node_Id
) return Boolean is
4669 if Nkind
(Nam
) = N_Selected_Component
then
4670 return Is_Entry
(Selector_Name
(Nam
));
4673 return Ekind
(Entity
(Nam
)) = E_Entry
;
4676 -- Start of processing for Is_Renamed_Entry
4679 if Present
(Alias
(Proc_Nam
)) then
4680 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
4683 -- Look for a rewritten subprogram renaming declaration
4685 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
4686 and then Present
(Original_Node
(Subp_Decl
))
4688 Orig_Node
:= Original_Node
(Subp_Decl
);
4691 -- The rewritten subprogram is actually an entry
4693 if Present
(Orig_Node
)
4694 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
4695 and then Is_Entry
(Name
(Orig_Node
))
4701 end Is_Renamed_Entry
;
4703 ----------------------
4704 -- Is_Selector_Name --
4705 ----------------------
4707 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
4709 if not Is_List_Member
(N
) then
4711 P
: constant Node_Id
:= Parent
(N
);
4712 K
: constant Node_Kind
:= Nkind
(P
);
4715 (K
= N_Expanded_Name
or else
4716 K
= N_Generic_Association
or else
4717 K
= N_Parameter_Association
or else
4718 K
= N_Selected_Component
)
4719 and then Selector_Name
(P
) = N
;
4724 L
: constant List_Id
:= List_Containing
(N
);
4725 P
: constant Node_Id
:= Parent
(L
);
4727 return (Nkind
(P
) = N_Discriminant_Association
4728 and then Selector_Names
(P
) = L
)
4730 (Nkind
(P
) = N_Component_Association
4731 and then Choices
(P
) = L
);
4734 end Is_Selector_Name
;
4740 function Is_Statement
(N
: Node_Id
) return Boolean is
4743 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
4744 or else Nkind
(N
) = N_Procedure_Call_Statement
;
4751 function Is_Transfer
(N
: Node_Id
) return Boolean is
4752 Kind
: constant Node_Kind
:= Nkind
(N
);
4755 if Kind
= N_Return_Statement
4757 Kind
= N_Goto_Statement
4759 Kind
= N_Raise_Statement
4761 Kind
= N_Requeue_Statement
4765 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
4766 and then No
(Condition
(N
))
4770 elsif Kind
= N_Procedure_Call_Statement
4771 and then Is_Entity_Name
(Name
(N
))
4772 and then Present
(Entity
(Name
(N
)))
4773 and then No_Return
(Entity
(Name
(N
)))
4777 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
4789 function Is_True
(U
: Uint
) return Boolean is
4798 function Is_Variable
(N
: Node_Id
) return Boolean is
4800 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
4801 -- We do the test on the original node, since this is basically a
4802 -- test of syntactic categories, so it must not be disturbed by
4803 -- whatever rewriting might have occurred. For example, an aggregate,
4804 -- which is certainly NOT a variable, could be turned into a variable
4807 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
4808 -- Within a protected function, the private components of the
4809 -- enclosing protected type are constants. A function nested within
4810 -- a (protected) procedure is not itself protected.
4812 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
4813 -- Prefixes can involve implicit dereferences, in which case we
4814 -- must test for the case of a reference of a constant access
4815 -- type, which can never be a variable.
4817 ---------------------------
4818 -- In_Protected_Function --
4819 ---------------------------
4821 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
4822 Prot
: constant Entity_Id
:= Scope
(E
);
4826 if not Is_Protected_Type
(Prot
) then
4830 while Present
(S
) and then S
/= Prot
loop
4831 if Ekind
(S
) = E_Function
4832 and then Scope
(S
) = Prot
4842 end In_Protected_Function
;
4844 ------------------------
4845 -- Is_Variable_Prefix --
4846 ------------------------
4848 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
4850 if Is_Access_Type
(Etype
(P
)) then
4851 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
4853 -- For the case of an indexed component whose prefix has a packed
4854 -- array type, the prefix has been rewritten into a type conversion.
4855 -- Determine variable-ness from the converted expression.
4857 elsif Nkind
(P
) = N_Type_Conversion
4858 and then not Comes_From_Source
(P
)
4859 and then Is_Array_Type
(Etype
(P
))
4860 and then Is_Packed
(Etype
(P
))
4862 return Is_Variable
(Expression
(P
));
4865 return Is_Variable
(P
);
4867 end Is_Variable_Prefix
;
4869 -- Start of processing for Is_Variable
4872 -- Definitely OK if Assignment_OK is set. Since this is something that
4873 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
4875 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
4878 -- Normally we go to the original node, but there is one exception
4879 -- where we use the rewritten node, namely when it is an explicit
4880 -- dereference. The generated code may rewrite a prefix which is an
4881 -- access type with an explicit dereference. The dereference is a
4882 -- variable, even though the original node may not be (since it could
4883 -- be a constant of the access type).
4885 elsif Nkind
(N
) = N_Explicit_Dereference
4886 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
4887 and then Is_Access_Type
(Etype
(Orig_Node
))
4889 return Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
4891 -- A function call is never a variable
4893 elsif Nkind
(N
) = N_Function_Call
then
4896 -- All remaining checks use the original node
4898 elsif Is_Entity_Name
(Orig_Node
) then
4900 E
: constant Entity_Id
:= Entity
(Orig_Node
);
4901 K
: constant Entity_Kind
:= Ekind
(E
);
4904 return (K
= E_Variable
4905 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
4906 or else (K
= E_Component
4907 and then not In_Protected_Function
(E
))
4908 or else K
= E_Out_Parameter
4909 or else K
= E_In_Out_Parameter
4910 or else K
= E_Generic_In_Out_Parameter
4912 -- Current instance of type:
4914 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
4915 or else (Is_Incomplete_Or_Private_Type
(E
)
4916 and then In_Open_Scopes
(Full_View
(E
)));
4920 case Nkind
(Orig_Node
) is
4921 when N_Indexed_Component | N_Slice
=>
4922 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
4924 when N_Selected_Component
=>
4925 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
4926 and then Is_Variable
(Selector_Name
(Orig_Node
));
4928 -- For an explicit dereference, the type of the prefix cannot
4929 -- be an access to constant or an access to subprogram.
4931 when N_Explicit_Dereference
=>
4933 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
4935 return Is_Access_Type
(Typ
)
4936 and then not Is_Access_Constant
(Root_Type
(Typ
))
4937 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
4940 -- The type conversion is the case where we do not deal with the
4941 -- context dependent special case of an actual parameter. Thus
4942 -- the type conversion is only considered a variable for the
4943 -- purposes of this routine if the target type is tagged. However,
4944 -- a type conversion is considered to be a variable if it does not
4945 -- come from source (this deals for example with the conversions
4946 -- of expressions to their actual subtypes).
4948 when N_Type_Conversion
=>
4949 return Is_Variable
(Expression
(Orig_Node
))
4951 (not Comes_From_Source
(Orig_Node
)
4953 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
4955 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
4957 -- GNAT allows an unchecked type conversion as a variable. This
4958 -- only affects the generation of internal expanded code, since
4959 -- calls to instantiations of Unchecked_Conversion are never
4960 -- considered variables (since they are function calls).
4961 -- This is also true for expression actions.
4963 when N_Unchecked_Type_Conversion
=>
4964 return Is_Variable
(Expression
(Orig_Node
));
4972 ------------------------
4973 -- Is_Volatile_Object --
4974 ------------------------
4976 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
4978 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
4979 -- Determines if given object has volatile components
4981 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
4982 -- If prefix is an implicit dereference, examine designated type
4984 ------------------------
4985 -- Is_Volatile_Prefix --
4986 ------------------------
4988 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
4989 Typ
: constant Entity_Id
:= Etype
(N
);
4992 if Is_Access_Type
(Typ
) then
4994 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
4997 return Is_Volatile
(Dtyp
)
4998 or else Has_Volatile_Components
(Dtyp
);
5002 return Object_Has_Volatile_Components
(N
);
5004 end Is_Volatile_Prefix
;
5006 ------------------------------------
5007 -- Object_Has_Volatile_Components --
5008 ------------------------------------
5010 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
5011 Typ
: constant Entity_Id
:= Etype
(N
);
5014 if Is_Volatile
(Typ
)
5015 or else Has_Volatile_Components
(Typ
)
5019 elsif Is_Entity_Name
(N
)
5020 and then (Has_Volatile_Components
(Entity
(N
))
5021 or else Is_Volatile
(Entity
(N
)))
5025 elsif Nkind
(N
) = N_Indexed_Component
5026 or else Nkind
(N
) = N_Selected_Component
5028 return Is_Volatile_Prefix
(Prefix
(N
));
5033 end Object_Has_Volatile_Components
;
5035 -- Start of processing for Is_Volatile_Object
5038 if Is_Volatile
(Etype
(N
))
5039 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
5043 elsif Nkind
(N
) = N_Indexed_Component
5044 or else Nkind
(N
) = N_Selected_Component
5046 return Is_Volatile_Prefix
(Prefix
(N
));
5051 end Is_Volatile_Object
;
5053 -------------------------
5054 -- Kill_Current_Values --
5055 -------------------------
5057 procedure Kill_Current_Values
is
5060 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
5061 -- Clear current value for entity E and all entities chained to E
5063 ------------------------------------------
5064 -- Kill_Current_Values_For_Entity_Chain --
5065 ------------------------------------------
5067 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
5072 while Present
(Ent
) loop
5073 if Is_Object
(Ent
) then
5074 Set_Current_Value
(Ent
, Empty
);
5076 if not Can_Never_Be_Null
(Ent
) then
5077 Set_Is_Known_Non_Null
(Ent
, False);
5083 end Kill_Current_Values_For_Entity_Chain
;
5085 -- Start of processing for Kill_Current_Values
5088 -- Kill all saved checks, a special case of killing saved values
5092 -- Loop through relevant scopes, which includes the current scope and
5093 -- any parent scopes if the current scope is a block or a package.
5098 -- Clear current values of all entities in current scope
5100 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
5102 -- If scope is a package, also clear current values of all
5103 -- private entities in the scope.
5105 if Ekind
(S
) = E_Package
5107 Ekind
(S
) = E_Generic_Package
5109 Is_Concurrent_Type
(S
)
5111 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
5114 -- If this is a block or nested package, deal with parent
5116 if Ekind
(S
) = E_Block
5117 or else (Ekind
(S
) = E_Package
5118 and then not Is_Library_Level_Entity
(S
))
5124 end loop Scope_Loop
;
5125 end Kill_Current_Values
;
5127 --------------------------
5128 -- Kill_Size_Check_Code --
5129 --------------------------
5131 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
5133 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
5134 and then Present
(Size_Check_Code
(E
))
5136 Remove
(Size_Check_Code
(E
));
5137 Set_Size_Check_Code
(E
, Empty
);
5139 end Kill_Size_Check_Code
;
5141 -------------------------
5142 -- New_External_Entity --
5143 -------------------------
5145 function New_External_Entity
5146 (Kind
: Entity_Kind
;
5147 Scope_Id
: Entity_Id
;
5148 Sloc_Value
: Source_Ptr
;
5149 Related_Id
: Entity_Id
;
5151 Suffix_Index
: Nat
:= 0;
5152 Prefix
: Character := ' ') return Entity_Id
5154 N
: constant Entity_Id
:=
5155 Make_Defining_Identifier
(Sloc_Value
,
5157 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
5160 Set_Ekind
(N
, Kind
);
5161 Set_Is_Internal
(N
, True);
5162 Append_Entity
(N
, Scope_Id
);
5163 Set_Public_Status
(N
);
5165 if Kind
in Type_Kind
then
5166 Init_Size_Align
(N
);
5170 end New_External_Entity
;
5172 -------------------------
5173 -- New_Internal_Entity --
5174 -------------------------
5176 function New_Internal_Entity
5177 (Kind
: Entity_Kind
;
5178 Scope_Id
: Entity_Id
;
5179 Sloc_Value
: Source_Ptr
;
5180 Id_Char
: Character) return Entity_Id
5182 N
: constant Entity_Id
:=
5183 Make_Defining_Identifier
(Sloc_Value
, New_Internal_Name
(Id_Char
));
5186 Set_Ekind
(N
, Kind
);
5187 Set_Is_Internal
(N
, True);
5188 Append_Entity
(N
, Scope_Id
);
5190 if Kind
in Type_Kind
then
5191 Init_Size_Align
(N
);
5195 end New_Internal_Entity
;
5201 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
5205 -- If we are pointing at a positional parameter, it is a member of
5206 -- a node list (the list of parameters), and the next parameter
5207 -- is the next node on the list, unless we hit a parameter
5208 -- association, in which case we shift to using the chain whose
5209 -- head is the First_Named_Actual in the parent, and then is
5210 -- threaded using the Next_Named_Actual of the Parameter_Association.
5211 -- All this fiddling is because the original node list is in the
5212 -- textual call order, and what we need is the declaration order.
5214 if Is_List_Member
(Actual_Id
) then
5215 N
:= Next
(Actual_Id
);
5217 if Nkind
(N
) = N_Parameter_Association
then
5218 return First_Named_Actual
(Parent
(Actual_Id
));
5224 return Next_Named_Actual
(Parent
(Actual_Id
));
5228 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
5230 Actual_Id
:= Next_Actual
(Actual_Id
);
5233 -----------------------
5234 -- Normalize_Actuals --
5235 -----------------------
5237 -- Chain actuals according to formals of subprogram. If there are no named
5238 -- associations, the chain is simply the list of Parameter Associations,
5239 -- since the order is the same as the declaration order. If there are named
5240 -- associations, then the First_Named_Actual field in the N_Function_Call
5241 -- or N_Procedure_Call_Statement node points to the Parameter_Association
5242 -- node for the parameter that comes first in declaration order. The
5243 -- remaining named parameters are then chained in declaration order using
5244 -- Next_Named_Actual.
5246 -- This routine also verifies that the number of actuals is compatible with
5247 -- the number and default values of formals, but performs no type checking
5248 -- (type checking is done by the caller).
5250 -- If the matching succeeds, Success is set to True and the caller proceeds
5251 -- with type-checking. If the match is unsuccessful, then Success is set to
5252 -- False, and the caller attempts a different interpretation, if there is
5255 -- If the flag Report is on, the call is not overloaded, and a failure to
5256 -- match can be reported here, rather than in the caller.
5258 procedure Normalize_Actuals
5262 Success
: out Boolean)
5264 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
5265 Actual
: Node_Id
:= Empty
;
5267 Last
: Node_Id
:= Empty
;
5268 First_Named
: Node_Id
:= Empty
;
5271 Formals_To_Match
: Integer := 0;
5272 Actuals_To_Match
: Integer := 0;
5274 procedure Chain
(A
: Node_Id
);
5275 -- Add named actual at the proper place in the list, using the
5276 -- Next_Named_Actual link.
5278 function Reporting
return Boolean;
5279 -- Determines if an error is to be reported. To report an error, we
5280 -- need Report to be True, and also we do not report errors caused
5281 -- by calls to init procs that occur within other init procs. Such
5282 -- errors must always be cascaded errors, since if all the types are
5283 -- declared correctly, the compiler will certainly build decent calls!
5289 procedure Chain
(A
: Node_Id
) is
5293 -- Call node points to first actual in list
5295 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
5298 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
5302 Set_Next_Named_Actual
(Last
, Empty
);
5309 function Reporting
return Boolean is
5314 elsif not Within_Init_Proc
then
5317 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
5325 -- Start of processing for Normalize_Actuals
5328 if Is_Access_Type
(S
) then
5330 -- The name in the call is a function call that returns an access
5331 -- to subprogram. The designated type has the list of formals.
5333 Formal
:= First_Formal
(Designated_Type
(S
));
5335 Formal
:= First_Formal
(S
);
5338 while Present
(Formal
) loop
5339 Formals_To_Match
:= Formals_To_Match
+ 1;
5340 Next_Formal
(Formal
);
5343 -- Find if there is a named association, and verify that no positional
5344 -- associations appear after named ones.
5346 if Present
(Actuals
) then
5347 Actual
:= First
(Actuals
);
5350 while Present
(Actual
)
5351 and then Nkind
(Actual
) /= N_Parameter_Association
5353 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5357 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
5359 -- Most common case: positional notation, no defaults
5364 elsif Actuals_To_Match
> Formals_To_Match
then
5366 -- Too many actuals: will not work
5369 if Is_Entity_Name
(Name
(N
)) then
5370 Error_Msg_N
("too many arguments in call to&", Name
(N
));
5372 Error_Msg_N
("too many arguments in call", N
);
5380 First_Named
:= Actual
;
5382 while Present
(Actual
) loop
5383 if Nkind
(Actual
) /= N_Parameter_Association
then
5385 ("positional parameters not allowed after named ones", Actual
);
5390 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5396 if Present
(Actuals
) then
5397 Actual
:= First
(Actuals
);
5400 Formal
:= First_Formal
(S
);
5401 while Present
(Formal
) loop
5403 -- Match the formals in order. If the corresponding actual
5404 -- is positional, nothing to do. Else scan the list of named
5405 -- actuals to find the one with the right name.
5408 and then Nkind
(Actual
) /= N_Parameter_Association
5411 Actuals_To_Match
:= Actuals_To_Match
- 1;
5412 Formals_To_Match
:= Formals_To_Match
- 1;
5415 -- For named parameters, search the list of actuals to find
5416 -- one that matches the next formal name.
5418 Actual
:= First_Named
;
5421 while Present
(Actual
) loop
5422 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
5425 Actuals_To_Match
:= Actuals_To_Match
- 1;
5426 Formals_To_Match
:= Formals_To_Match
- 1;
5434 if Ekind
(Formal
) /= E_In_Parameter
5435 or else No
(Default_Value
(Formal
))
5438 if (Comes_From_Source
(S
)
5439 or else Sloc
(S
) = Standard_Location
)
5440 and then Is_Overloadable
(S
)
5444 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
5446 (Nkind
(Parent
(N
)) = N_Function_Call
5448 Nkind
(Parent
(N
)) = N_Parameter_Association
))
5449 and then Ekind
(S
) /= E_Function
5451 Set_Etype
(N
, Etype
(S
));
5453 Error_Msg_Name_1
:= Chars
(S
);
5454 Error_Msg_Sloc
:= Sloc
(S
);
5456 ("missing argument for parameter & " &
5457 "in call to % declared #", N
, Formal
);
5460 elsif Is_Overloadable
(S
) then
5461 Error_Msg_Name_1
:= Chars
(S
);
5463 -- Point to type derivation that generated the
5466 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
5469 ("missing argument for parameter & " &
5470 "in call to % (inherited) #", N
, Formal
);
5474 ("missing argument for parameter &", N
, Formal
);
5482 Formals_To_Match
:= Formals_To_Match
- 1;
5487 Next_Formal
(Formal
);
5490 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
5497 -- Find some superfluous named actual that did not get
5498 -- attached to the list of associations.
5500 Actual
:= First
(Actuals
);
5502 while Present
(Actual
) loop
5503 if Nkind
(Actual
) = N_Parameter_Association
5504 and then Actual
/= Last
5505 and then No
(Next_Named_Actual
(Actual
))
5507 Error_Msg_N
("unmatched actual & in call",
5508 Selector_Name
(Actual
));
5519 end Normalize_Actuals
;
5521 --------------------------------
5522 -- Note_Possible_Modification --
5523 --------------------------------
5525 procedure Note_Possible_Modification
(N
: Node_Id
) is
5526 Modification_Comes_From_Source
: constant Boolean :=
5527 Comes_From_Source
(Parent
(N
));
5533 -- Loop to find referenced entity, if there is one
5540 if Is_Entity_Name
(Exp
) then
5541 Ent
:= Entity
(Exp
);
5543 -- If the entity is missing, it is an undeclared identifier,
5544 -- and there is nothing to annotate.
5550 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
5552 P
: constant Node_Id
:= Prefix
(Exp
);
5555 if Nkind
(P
) = N_Selected_Component
5557 Entry_Formal
(Entity
(Selector_Name
(P
))))
5559 -- Case of a reference to an entry formal
5561 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
5563 elsif Nkind
(P
) = N_Identifier
5564 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
5565 and then Present
(Expression
(Parent
(Entity
(P
))))
5566 and then Nkind
(Expression
(Parent
(Entity
(P
))))
5569 -- Case of a reference to a value on which
5570 -- side effects have been removed.
5572 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
5580 elsif Nkind
(Exp
) = N_Type_Conversion
5581 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
5583 Exp
:= Expression
(Exp
);
5585 elsif Nkind
(Exp
) = N_Slice
5586 or else Nkind
(Exp
) = N_Indexed_Component
5587 or else Nkind
(Exp
) = N_Selected_Component
5589 Exp
:= Prefix
(Exp
);
5596 -- Now look for entity being referenced
5598 if Present
(Ent
) then
5600 if Is_Object
(Ent
) then
5601 if Comes_From_Source
(Exp
)
5602 or else Modification_Comes_From_Source
5604 Set_Never_Set_In_Source
(Ent
, False);
5607 Set_Is_True_Constant
(Ent
, False);
5608 Set_Current_Value
(Ent
, Empty
);
5610 if not Can_Never_Be_Null
(Ent
) then
5611 Set_Is_Known_Non_Null
(Ent
, False);
5614 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
5615 and then Present
(Renamed_Object
(Ent
))
5617 Exp
:= Renamed_Object
(Ent
);
5621 -- Generate a reference only if the assignment comes from
5622 -- source. This excludes, for example, calls to a dispatching
5623 -- assignment operation when the left-hand side is tagged.
5625 if Modification_Comes_From_Source
then
5626 Generate_Reference
(Ent
, Exp
, 'm');
5634 end Note_Possible_Modification
;
5636 -------------------------
5637 -- Object_Access_Level --
5638 -------------------------
5640 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
5643 -- Returns the static accessibility level of the view denoted
5644 -- by Obj. Note that the value returned is the result of a
5645 -- call to Scope_Depth. Only scope depths associated with
5646 -- dynamic scopes can actually be returned. Since only
5647 -- relative levels matter for accessibility checking, the fact
5648 -- that the distance between successive levels of accessibility
5649 -- is not always one is immaterial (invariant: if level(E2) is
5650 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
5653 if Is_Entity_Name
(Obj
) then
5656 -- If E is a type then it denotes a current instance.
5657 -- For this case we add one to the normal accessibility
5658 -- level of the type to ensure that current instances
5659 -- are treated as always being deeper than than the level
5660 -- of any visible named access type (see 3.10.2(21)).
5663 return Type_Access_Level
(E
) + 1;
5665 elsif Present
(Renamed_Object
(E
)) then
5666 return Object_Access_Level
(Renamed_Object
(E
));
5668 -- Similarly, if E is a component of the current instance of a
5669 -- protected type, any instance of it is assumed to be at a deeper
5670 -- level than the type. For a protected object (whose type is an
5671 -- anonymous protected type) its components are at the same level
5672 -- as the type itself.
5674 elsif not Is_Overloadable
(E
)
5675 and then Ekind
(Scope
(E
)) = E_Protected_Type
5676 and then Comes_From_Source
(Scope
(E
))
5678 return Type_Access_Level
(Scope
(E
)) + 1;
5681 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
5684 elsif Nkind
(Obj
) = N_Selected_Component
then
5685 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5686 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5688 return Object_Access_Level
(Prefix
(Obj
));
5691 elsif Nkind
(Obj
) = N_Indexed_Component
then
5692 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5693 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5695 return Object_Access_Level
(Prefix
(Obj
));
5698 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
5700 -- If the prefix is a selected access discriminant then
5701 -- we make a recursive call on the prefix, which will
5702 -- in turn check the level of the prefix object of
5703 -- the selected discriminant.
5705 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
5706 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
5708 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
5710 return Object_Access_Level
(Prefix
(Obj
));
5712 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5715 elsif Nkind
(Obj
) = N_Type_Conversion
5716 or else Nkind
(Obj
) = N_Unchecked_Type_Conversion
5718 return Object_Access_Level
(Expression
(Obj
));
5720 -- Function results are objects, so we get either the access level
5721 -- of the function or, in the case of an indirect call, the level of
5722 -- of the access-to-subprogram type.
5724 elsif Nkind
(Obj
) = N_Function_Call
then
5725 if Is_Entity_Name
(Name
(Obj
)) then
5726 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
5728 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
5731 -- For convenience we handle qualified expressions, even though
5732 -- they aren't technically object names.
5734 elsif Nkind
(Obj
) = N_Qualified_Expression
then
5735 return Object_Access_Level
(Expression
(Obj
));
5737 -- Otherwise return the scope level of Standard.
5738 -- (If there are cases that fall through
5739 -- to this point they will be treated as
5740 -- having global accessibility for now. ???)
5743 return Scope_Depth
(Standard_Standard
);
5745 end Object_Access_Level
;
5747 -----------------------
5748 -- Private_Component --
5749 -----------------------
5751 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
5752 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
5754 function Trace_Components
5756 Check
: Boolean) return Entity_Id
;
5757 -- Recursive function that does the work, and checks against circular
5758 -- definition for each subcomponent type.
5760 ----------------------
5761 -- Trace_Components --
5762 ----------------------
5764 function Trace_Components
5766 Check
: Boolean) return Entity_Id
5768 Btype
: constant Entity_Id
:= Base_Type
(T
);
5769 Component
: Entity_Id
;
5771 Candidate
: Entity_Id
:= Empty
;
5774 if Check
and then Btype
= Ancestor
then
5775 Error_Msg_N
("circular type definition", Type_Id
);
5779 if Is_Private_Type
(Btype
)
5780 and then not Is_Generic_Type
(Btype
)
5782 if Present
(Full_View
(Btype
))
5783 and then Is_Record_Type
(Full_View
(Btype
))
5784 and then not Is_Frozen
(Btype
)
5786 -- To indicate that the ancestor depends on a private type,
5787 -- the current Btype is sufficient. However, to check for
5788 -- circular definition we must recurse on the full view.
5790 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
5792 if Candidate
= Any_Type
then
5802 elsif Is_Array_Type
(Btype
) then
5803 return Trace_Components
(Component_Type
(Btype
), True);
5805 elsif Is_Record_Type
(Btype
) then
5806 Component
:= First_Entity
(Btype
);
5807 while Present
(Component
) loop
5809 -- Skip anonymous types generated by constrained components
5811 if not Is_Type
(Component
) then
5812 P
:= Trace_Components
(Etype
(Component
), True);
5815 if P
= Any_Type
then
5823 Next_Entity
(Component
);
5831 end Trace_Components
;
5833 -- Start of processing for Private_Component
5836 return Trace_Components
(Type_Id
, False);
5837 end Private_Component
;
5839 -----------------------
5840 -- Process_End_Label --
5841 -----------------------
5843 procedure Process_End_Label
5851 Label_Ref
: Boolean;
5852 -- Set True if reference to end label itself is required
5855 -- Gets set to the operator symbol or identifier that references
5856 -- the entity Ent. For the child unit case, this is the identifier
5857 -- from the designator. For other cases, this is simply Endl.
5859 procedure Generate_Parent_Ref
(N
: Node_Id
);
5860 -- N is an identifier node that appears as a parent unit reference
5861 -- in the case where Ent is a child unit. This procedure generates
5862 -- an appropriate cross-reference entry.
5864 -------------------------
5865 -- Generate_Parent_Ref --
5866 -------------------------
5868 procedure Generate_Parent_Ref
(N
: Node_Id
) is
5869 Parent_Ent
: Entity_Id
;
5872 -- Search up scope stack. The reason we do this is that normal
5873 -- visibility analysis would not work for two reasons. First in
5874 -- some subunit cases, the entry for the parent unit may not be
5875 -- visible, and in any case there can be a local entity that
5876 -- hides the scope entity.
5878 Parent_Ent
:= Current_Scope
;
5879 while Present
(Parent_Ent
) loop
5880 if Chars
(Parent_Ent
) = Chars
(N
) then
5882 -- Generate the reference. We do NOT consider this as a
5883 -- reference for unreferenced symbol purposes, but we do
5884 -- force a cross-reference even if the end line does not
5885 -- come from source (the caller already generated the
5886 -- appropriate Typ for this situation).
5889 (Parent_Ent
, N
, 'r', Set_Ref
=> False, Force
=> True);
5890 Style
.Check_Identifier
(N
, Parent_Ent
);
5894 Parent_Ent
:= Scope
(Parent_Ent
);
5897 -- Fall through means entity was not found -- that's odd, but
5898 -- the appropriate thing is simply to ignore and not generate
5899 -- any cross-reference for this entry.
5902 end Generate_Parent_Ref
;
5904 -- Start of processing for Process_End_Label
5907 -- If no node, ignore. This happens in some error situations,
5908 -- and also for some internally generated structures where no
5909 -- end label references are required in any case.
5915 -- Nothing to do if no End_Label, happens for internally generated
5916 -- constructs where we don't want an end label reference anyway.
5917 -- Also nothing to do if Endl is a string literal, which means
5918 -- there was some prior error (bad operator symbol)
5920 Endl
:= End_Label
(N
);
5922 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
5926 -- Reference node is not in extended main source unit
5928 if not In_Extended_Main_Source_Unit
(N
) then
5930 -- Generally we do not collect references except for the
5931 -- extended main source unit. The one exception is the 'e'
5932 -- entry for a package spec, where it is useful for a client
5933 -- to have the ending information to define scopes.
5941 -- For this case, we can ignore any parent references,
5942 -- but we need the package name itself for the 'e' entry.
5944 if Nkind
(Endl
) = N_Designator
then
5945 Endl
:= Identifier
(Endl
);
5949 -- Reference is in extended main source unit
5954 -- For designator, generate references for the parent entries
5956 if Nkind
(Endl
) = N_Designator
then
5958 -- Generate references for the prefix if the END line comes
5959 -- from source (otherwise we do not need these references)
5961 if Comes_From_Source
(Endl
) then
5963 while Nkind
(Nam
) = N_Selected_Component
loop
5964 Generate_Parent_Ref
(Selector_Name
(Nam
));
5965 Nam
:= Prefix
(Nam
);
5968 Generate_Parent_Ref
(Nam
);
5971 Endl
:= Identifier
(Endl
);
5975 -- If the end label is not for the given entity, then either we have
5976 -- some previous error, or this is a generic instantiation for which
5977 -- we do not need to make a cross-reference in this case anyway. In
5978 -- either case we simply ignore the call.
5980 if Chars
(Ent
) /= Chars
(Endl
) then
5984 -- If label was really there, then generate a normal reference
5985 -- and then adjust the location in the end label to point past
5986 -- the name (which should almost always be the semicolon).
5990 if Comes_From_Source
(Endl
) then
5992 -- If a label reference is required, then do the style check
5993 -- and generate an l-type cross-reference entry for the label
5997 Style
.Check_Identifier
(Endl
, Ent
);
5999 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
6002 -- Set the location to point past the label (normally this will
6003 -- mean the semicolon immediately following the label). This is
6004 -- done for the sake of the 'e' or 't' entry generated below.
6006 Get_Decoded_Name_String
(Chars
(Endl
));
6007 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
6010 -- Now generate the e/t reference
6012 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
6014 -- Restore Sloc, in case modified above, since we have an identifier
6015 -- and the normal Sloc should be left set in the tree.
6017 Set_Sloc
(Endl
, Loc
);
6018 end Process_End_Label
;
6024 -- We do the conversion to get the value of the real string by using
6025 -- the scanner, see Sinput for details on use of the internal source
6026 -- buffer for scanning internal strings.
6028 function Real_Convert
(S
: String) return Node_Id
is
6029 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
6033 Source
:= Internal_Source_Ptr
;
6036 for J
in S
'Range loop
6037 Source
(Source_Ptr
(J
)) := S
(J
);
6040 Source
(S
'Length + 1) := EOF
;
6042 if Source
(Scan_Ptr
) = '-' then
6044 Scan_Ptr
:= Scan_Ptr
+ 1;
6052 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
6059 ---------------------
6060 -- Rep_To_Pos_Flag --
6061 ---------------------
6063 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
6065 return New_Occurrence_Of
6066 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
6067 end Rep_To_Pos_Flag
;
6069 --------------------
6070 -- Require_Entity --
6071 --------------------
6073 procedure Require_Entity
(N
: Node_Id
) is
6075 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
6076 if Total_Errors_Detected
/= 0 then
6077 Set_Entity
(N
, Any_Id
);
6079 raise Program_Error
;
6084 ------------------------------
6085 -- Requires_Transient_Scope --
6086 ------------------------------
6088 -- A transient scope is required when variable-sized temporaries are
6089 -- allocated in the primary or secondary stack, or when finalization
6090 -- actions must be generated before the next instruction.
6092 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
6093 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
6095 -- Start of processing for Requires_Transient_Scope
6098 -- This is a private type which is not completed yet. This can only
6099 -- happen in a default expression (of a formal parameter or of a
6100 -- record component). Do not expand transient scope in this case
6105 -- Do not expand transient scope for non-existent procedure return
6107 elsif Typ
= Standard_Void_Type
then
6110 -- Elementary types do not require a transient scope
6112 elsif Is_Elementary_Type
(Typ
) then
6115 -- Generally, indefinite subtypes require a transient scope, since the
6116 -- back end cannot generate temporaries, since this is not a valid type
6117 -- for declaring an object. It might be possible to relax this in the
6118 -- future, e.g. by declaring the maximum possible space for the type.
6120 elsif Is_Indefinite_Subtype
(Typ
) then
6123 -- Functions returning tagged types may dispatch on result so their
6124 -- returned value is allocated on the secondary stack. Controlled
6125 -- type temporaries need finalization.
6127 elsif Is_Tagged_Type
(Typ
)
6128 or else Has_Controlled_Component
(Typ
)
6134 elsif Is_Record_Type
(Typ
) then
6136 -- In GCC 2, discriminated records always require a transient
6137 -- scope because the back end otherwise tries to allocate a
6138 -- variable length temporary for the particular variant.
6140 if Opt
.GCC_Version
= 2
6141 and then Has_Discriminants
(Typ
)
6145 -- For GCC 3, or for a non-discriminated record in GCC 2, we are
6146 -- OK if none of the component types requires a transient scope.
6147 -- Note that we already know that this is a definite type (i.e.
6148 -- has discriminant defaults if it is a discriminated record).
6154 Comp
:= First_Entity
(Typ
);
6155 while Present
(Comp
) loop
6156 if Ekind
(Comp
) = E_Component
6157 and then Requires_Transient_Scope
(Etype
(Comp
))
6169 -- String literal types never require transient scope
6171 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
6174 -- Array type. Note that we already know that this is a constrained
6175 -- array, since unconstrained arrays will fail the indefinite test.
6177 elsif Is_Array_Type
(Typ
) then
6179 -- If component type requires a transient scope, the array does too
6181 if Requires_Transient_Scope
(Component_Type
(Typ
)) then
6184 -- Otherwise, we only need a transient scope if the size is not
6185 -- known at compile time.
6188 return not Size_Known_At_Compile_Time
(Typ
);
6191 -- All other cases do not require a transient scope
6196 end Requires_Transient_Scope
;
6198 --------------------------
6199 -- Reset_Analyzed_Flags --
6200 --------------------------
6202 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
6204 function Clear_Analyzed
6205 (N
: Node_Id
) return Traverse_Result
;
6206 -- Function used to reset Analyzed flags in tree. Note that we do
6207 -- not reset Analyzed flags in entities, since there is no need to
6208 -- renalalyze entities, and indeed, it is wrong to do so, since it
6209 -- can result in generating auxiliary stuff more than once.
6211 --------------------
6212 -- Clear_Analyzed --
6213 --------------------
6215 function Clear_Analyzed
6216 (N
: Node_Id
) return Traverse_Result
6219 if not Has_Extension
(N
) then
6220 Set_Analyzed
(N
, False);
6226 function Reset_Analyzed
is
6227 new Traverse_Func
(Clear_Analyzed
);
6229 Discard
: Traverse_Result
;
6230 pragma Warnings
(Off
, Discard
);
6232 -- Start of processing for Reset_Analyzed_Flags
6235 Discard
:= Reset_Analyzed
(N
);
6236 end Reset_Analyzed_Flags
;
6238 ---------------------------
6239 -- Safe_To_Capture_Value --
6240 ---------------------------
6242 function Safe_To_Capture_Value
6244 Ent
: Entity_Id
) return Boolean
6247 -- The only entities for which we track constant values are variables,
6248 -- out parameters and in out parameters, so check if we have this case.
6250 if Ekind
(Ent
) /= E_Variable
6252 Ekind
(Ent
) /= E_Out_Parameter
6254 Ekind
(Ent
) /= E_In_Out_Parameter
6259 -- Skip volatile and aliased variables, since funny things might
6260 -- be going on in these cases which we cannot necessarily track.
6261 -- Also skip any variable for which an address clause is given.
6263 -- Should we have a flag Has_Address_Clause ???
6265 if Treat_As_Volatile
(Ent
)
6266 or else Is_Aliased
(Ent
)
6267 or else Present
(Address_Clause
(Ent
))
6272 -- OK, all above conditions are met. We also require that the scope
6273 -- of the reference be the same as the scope of the entity, not
6274 -- counting packages and blocks.
6277 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
6278 R_Scope
: Entity_Id
;
6281 R_Scope
:= Current_Scope
;
6282 while R_Scope
/= Standard_Standard
loop
6283 exit when R_Scope
= E_Scope
;
6285 if Ekind
(R_Scope
) /= E_Package
6287 Ekind
(R_Scope
) /= E_Block
6291 R_Scope
:= Scope
(R_Scope
);
6296 -- We also require that the reference does not appear in a context
6297 -- where it is not sure to be executed (i.e. a conditional context
6298 -- or an exception handler).
6307 while Present
(P
) loop
6308 if Nkind
(P
) = N_If_Statement
6309 or else Nkind
(P
) = N_Case_Statement
6310 or else (Nkind
(P
) = N_And_Then
and then Desc
= Right_Opnd
(P
))
6311 or else (Nkind
(P
) = N_Or_Else
and then Desc
= Right_Opnd
(P
))
6312 or else Nkind
(P
) = N_Exception_Handler
6313 or else Nkind
(P
) = N_Selective_Accept
6314 or else Nkind
(P
) = N_Conditional_Entry_Call
6315 or else Nkind
(P
) = N_Timed_Entry_Call
6316 or else Nkind
(P
) = N_Asynchronous_Select
6326 -- OK, looks safe to set value
6329 end Safe_To_Capture_Value
;
6335 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
6336 K1
: constant Node_Kind
:= Nkind
(N1
);
6337 K2
: constant Node_Kind
:= Nkind
(N2
);
6340 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
6341 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
6343 return Chars
(N1
) = Chars
(N2
);
6345 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
6346 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
6348 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
6349 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
6360 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
6365 elsif not Is_Constrained
(T1
)
6366 and then not Is_Constrained
(T2
)
6367 and then Base_Type
(T1
) = Base_Type
(T2
)
6371 -- For now don't bother with case of identical constraints, to be
6372 -- fiddled with later on perhaps (this is only used for optimization
6373 -- purposes, so it is not critical to do a best possible job)
6380 ------------------------
6381 -- Scope_Is_Transient --
6382 ------------------------
6384 function Scope_Is_Transient
return Boolean is
6386 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
6387 end Scope_Is_Transient
;
6393 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6398 while Scop
/= Standard_Standard
loop
6399 Scop
:= Scope
(Scop
);
6401 if Scop
= Scope2
then
6409 --------------------------
6410 -- Scope_Within_Or_Same --
6411 --------------------------
6413 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6418 while Scop
/= Standard_Standard
loop
6419 if Scop
= Scope2
then
6422 Scop
:= Scope
(Scop
);
6427 end Scope_Within_Or_Same
;
6429 ------------------------
6430 -- Set_Current_Entity --
6431 ------------------------
6433 -- The given entity is to be set as the currently visible definition
6434 -- of its associated name (i.e. the Node_Id associated with its name).
6435 -- All we have to do is to get the name from the identifier, and
6436 -- then set the associated Node_Id to point to the given entity.
6438 procedure Set_Current_Entity
(E
: Entity_Id
) is
6440 Set_Name_Entity_Id
(Chars
(E
), E
);
6441 end Set_Current_Entity
;
6443 ---------------------------------
6444 -- Set_Entity_With_Style_Check --
6445 ---------------------------------
6447 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
6448 Val_Actual
: Entity_Id
;
6452 Set_Entity
(N
, Val
);
6455 and then not Suppress_Style_Checks
(Val
)
6456 and then not In_Instance
6458 if Nkind
(N
) = N_Identifier
then
6461 elsif Nkind
(N
) = N_Expanded_Name
then
6462 Nod
:= Selector_Name
(N
);
6468 -- A special situation arises for derived operations, where we want
6469 -- to do the check against the parent (since the Sloc of the derived
6470 -- operation points to the derived type declaration itself).
6473 while not Comes_From_Source
(Val_Actual
)
6474 and then Nkind
(Val_Actual
) in N_Entity
6475 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
6476 or else Is_Subprogram
(Val_Actual
)
6477 or else Is_Generic_Subprogram
(Val_Actual
))
6478 and then Present
(Alias
(Val_Actual
))
6480 Val_Actual
:= Alias
(Val_Actual
);
6483 -- Renaming declarations for generic actuals do not come from source,
6484 -- and have a different name from that of the entity they rename, so
6485 -- there is no style check to perform here.
6487 if Chars
(Nod
) = Chars
(Val_Actual
) then
6488 Style
.Check_Identifier
(Nod
, Val_Actual
);
6492 Set_Entity
(N
, Val
);
6493 end Set_Entity_With_Style_Check
;
6495 ------------------------
6496 -- Set_Name_Entity_Id --
6497 ------------------------
6499 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
6501 Set_Name_Table_Info
(Id
, Int
(Val
));
6502 end Set_Name_Entity_Id
;
6504 ---------------------
6505 -- Set_Next_Actual --
6506 ---------------------
6508 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
6510 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
6511 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
6513 end Set_Next_Actual
;
6515 -----------------------
6516 -- Set_Public_Status --
6517 -----------------------
6519 procedure Set_Public_Status
(Id
: Entity_Id
) is
6520 S
: constant Entity_Id
:= Current_Scope
;
6523 -- Everything in the scope of Standard is public
6525 if S
= Standard_Standard
then
6528 -- Entity is definitely not public if enclosing scope is not public
6530 elsif not Is_Public
(S
) then
6533 -- An object declaration that occurs in a handled sequence of statements
6534 -- is the declaration for a temporary object generated by the expander.
6535 -- It never needs to be made public and furthermore, making it public
6536 -- can cause back end problems if it is of variable size.
6538 elsif Nkind
(Parent
(Id
)) = N_Object_Declaration
6540 Nkind
(Parent
(Parent
(Id
))) = N_Handled_Sequence_Of_Statements
6544 -- Entities in public packages or records are public
6546 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
6549 -- The bounds of an entry family declaration can generate object
6550 -- declarations that are visible to the back-end, e.g. in the
6551 -- the declaration of a composite type that contains tasks.
6553 elsif Is_Concurrent_Type
(S
)
6554 and then not Has_Completion
(S
)
6555 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
6559 end Set_Public_Status
;
6561 ----------------------------
6562 -- Set_Scope_Is_Transient --
6563 ----------------------------
6565 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
6567 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
6568 end Set_Scope_Is_Transient
;
6574 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
6576 -- We copy Esize, but not RM_Size, since in general RM_Size is
6577 -- subtype specific and does not get inherited by all subtypes.
6579 Set_Esize
(T1
, Esize
(T2
));
6580 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
6582 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
6584 Is_Discrete_Or_Fixed_Point_Type
(T2
)
6586 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
6588 Set_Alignment
(T1
, Alignment
(T2
));
6591 --------------------
6592 -- Static_Integer --
6593 --------------------
6595 function Static_Integer
(N
: Node_Id
) return Uint
is
6597 Analyze_And_Resolve
(N
, Any_Integer
);
6600 or else Error_Posted
(N
)
6601 or else Etype
(N
) = Any_Type
6606 if Is_Static_Expression
(N
) then
6607 if not Raises_Constraint_Error
(N
) then
6608 return Expr_Value
(N
);
6613 elsif Etype
(N
) = Any_Type
then
6617 Flag_Non_Static_Expr
6618 ("static integer expression required here", N
);
6623 --------------------------
6624 -- Statically_Different --
6625 --------------------------
6627 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
6628 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
6629 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
6631 return Is_Entity_Name
(R1
)
6632 and then Is_Entity_Name
(R2
)
6633 and then Entity
(R1
) /= Entity
(R2
)
6634 and then not Is_Formal
(Entity
(R1
))
6635 and then not Is_Formal
(Entity
(R2
));
6636 end Statically_Different
;
6638 -----------------------------
6639 -- Subprogram_Access_Level --
6640 -----------------------------
6642 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
6644 if Present
(Alias
(Subp
)) then
6645 return Subprogram_Access_Level
(Alias
(Subp
));
6647 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
6649 end Subprogram_Access_Level
;
6655 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
6657 if Debug_Flag_W
then
6658 for J
in 0 .. Scope_Stack
.Last
loop
6663 Write_Name
(Chars
(E
));
6664 Write_Str
(" line ");
6665 Write_Int
(Int
(Get_Logical_Line_Number
(Sloc
(N
))));
6670 -----------------------
6671 -- Transfer_Entities --
6672 -----------------------
6674 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
6675 Ent
: Entity_Id
:= First_Entity
(From
);
6682 if (Last_Entity
(To
)) = Empty
then
6683 Set_First_Entity
(To
, Ent
);
6685 Set_Next_Entity
(Last_Entity
(To
), Ent
);
6688 Set_Last_Entity
(To
, Last_Entity
(From
));
6690 while Present
(Ent
) loop
6691 Set_Scope
(Ent
, To
);
6693 if not Is_Public
(Ent
) then
6694 Set_Public_Status
(Ent
);
6697 and then Ekind
(Ent
) = E_Record_Subtype
6700 -- The components of the propagated Itype must be public
6707 Comp
:= First_Entity
(Ent
);
6708 while Present
(Comp
) loop
6709 Set_Is_Public
(Comp
);
6719 Set_First_Entity
(From
, Empty
);
6720 Set_Last_Entity
(From
, Empty
);
6721 end Transfer_Entities
;
6723 -----------------------
6724 -- Type_Access_Level --
6725 -----------------------
6727 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
6731 -- If the type is an anonymous access type we treat it as being
6732 -- declared at the library level to ensure that names such as
6733 -- X.all'access don't fail static accessibility checks.
6735 -- Ada 2005 (AI-230): In case of anonymous access types that are
6736 -- component_definition or discriminants of a nonlimited type,
6737 -- the level is the same as that of the enclosing component type.
6739 Btyp
:= Base_Type
(Typ
);
6741 if Ekind
(Btyp
) in Access_Kind
then
6742 if Ekind
(Btyp
) = E_Anonymous_Access_Type
6743 and then not Is_Local_Anonymous_Access
(Typ
) -- Ada 2005 (AI-230)
6745 return Scope_Depth
(Standard_Standard
);
6748 Btyp
:= Root_Type
(Btyp
);
6751 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
6752 end Type_Access_Level
;
6754 --------------------------
6755 -- Unit_Declaration_Node --
6756 --------------------------
6758 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
6759 N
: Node_Id
:= Parent
(Unit_Id
);
6762 -- Predefined operators do not have a full function declaration
6764 if Ekind
(Unit_Id
) = E_Operator
then
6768 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
6769 and then Nkind
(N
) /= N_Formal_Package_Declaration
6770 and then Nkind
(N
) /= N_Function_Instantiation
6771 and then Nkind
(N
) /= N_Generic_Package_Declaration
6772 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
6773 and then Nkind
(N
) /= N_Package_Declaration
6774 and then Nkind
(N
) /= N_Package_Body
6775 and then Nkind
(N
) /= N_Package_Instantiation
6776 and then Nkind
(N
) /= N_Package_Renaming_Declaration
6777 and then Nkind
(N
) /= N_Procedure_Instantiation
6778 and then Nkind
(N
) /= N_Protected_Body
6779 and then Nkind
(N
) /= N_Subprogram_Declaration
6780 and then Nkind
(N
) /= N_Subprogram_Body
6781 and then Nkind
(N
) /= N_Subprogram_Body_Stub
6782 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
6783 and then Nkind
(N
) /= N_Task_Body
6784 and then Nkind
(N
) /= N_Task_Type_Declaration
6785 and then Nkind
(N
) not in N_Formal_Subprogram_Declaration
6786 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
6789 pragma Assert
(Present
(N
));
6793 end Unit_Declaration_Node
;
6795 ------------------------------
6796 -- Universal_Interpretation --
6797 ------------------------------
6799 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
6800 Index
: Interp_Index
;
6804 -- The argument may be a formal parameter of an operator or subprogram
6805 -- with multiple interpretations, or else an expression for an actual.
6807 if Nkind
(Opnd
) = N_Defining_Identifier
6808 or else not Is_Overloaded
(Opnd
)
6810 if Etype
(Opnd
) = Universal_Integer
6811 or else Etype
(Opnd
) = Universal_Real
6813 return Etype
(Opnd
);
6819 Get_First_Interp
(Opnd
, Index
, It
);
6820 while Present
(It
.Typ
) loop
6821 if It
.Typ
= Universal_Integer
6822 or else It
.Typ
= Universal_Real
6827 Get_Next_Interp
(Index
, It
);
6832 end Universal_Interpretation
;
6834 ----------------------
6835 -- Within_Init_Proc --
6836 ----------------------
6838 function Within_Init_Proc
return Boolean is
6843 while not Is_Overloadable
(S
) loop
6844 if S
= Standard_Standard
then
6851 return Is_Init_Proc
(S
);
6852 end Within_Init_Proc
;
6858 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
6859 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
6860 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
6862 function Has_One_Matching_Field
return Boolean;
6863 -- Determines if Expec_Type is a record type with a single component or
6864 -- discriminant whose type matches the found type or is one dimensional
6865 -- array whose component type matches the found type.
6867 ----------------------------
6868 -- Has_One_Matching_Field --
6869 ----------------------------
6871 function Has_One_Matching_Field
return Boolean is
6875 if Is_Array_Type
(Expec_Type
)
6876 and then Number_Dimensions
(Expec_Type
) = 1
6878 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
6882 elsif not Is_Record_Type
(Expec_Type
) then
6886 E
:= First_Entity
(Expec_Type
);
6891 elsif (Ekind
(E
) /= E_Discriminant
6892 and then Ekind
(E
) /= E_Component
)
6893 or else (Chars
(E
) = Name_uTag
6894 or else Chars
(E
) = Name_uParent
)
6903 if not Covers
(Etype
(E
), Found_Type
) then
6906 elsif Present
(Next_Entity
(E
)) then
6913 end Has_One_Matching_Field
;
6915 -- Start of processing for Wrong_Type
6918 -- Don't output message if either type is Any_Type, or if a message
6919 -- has already been posted for this node. We need to do the latter
6920 -- check explicitly (it is ordinarily done in Errout), because we
6921 -- are using ! to force the output of the error messages.
6923 if Expec_Type
= Any_Type
6924 or else Found_Type
= Any_Type
6925 or else Error_Posted
(Expr
)
6929 -- In an instance, there is an ongoing problem with completion of
6930 -- type derived from private types. Their structure is what Gigi
6931 -- expects, but the Etype is the parent type rather than the
6932 -- derived private type itself. Do not flag error in this case. The
6933 -- private completion is an entity without a parent, like an Itype.
6934 -- Similarly, full and partial views may be incorrect in the instance.
6935 -- There is no simple way to insure that it is consistent ???
6937 elsif In_Instance
then
6939 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
6941 (Has_Private_Declaration
(Expected_Type
)
6942 or else Has_Private_Declaration
(Etype
(Expr
)))
6943 and then No
(Parent
(Expected_Type
))
6949 -- An interesting special check. If the expression is parenthesized
6950 -- and its type corresponds to the type of the sole component of the
6951 -- expected record type, or to the component type of the expected one
6952 -- dimensional array type, then assume we have a bad aggregate attempt.
6954 if Nkind
(Expr
) in N_Subexpr
6955 and then Paren_Count
(Expr
) /= 0
6956 and then Has_One_Matching_Field
6958 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
6960 -- Another special check, if we are looking for a pool-specific access
6961 -- type and we found an E_Access_Attribute_Type, then we have the case
6962 -- of an Access attribute being used in a context which needs a pool-
6963 -- specific type, which is never allowed. The one extra check we make
6964 -- is that the expected designated type covers the Found_Type.
6966 elsif Is_Access_Type
(Expec_Type
)
6967 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
6968 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
6969 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
6971 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
6973 Error_Msg_N
("result must be general access type!", Expr
);
6974 Error_Msg_NE
("add ALL to }!", Expr
, Expec_Type
);
6976 -- If the expected type is an anonymous access type, as for access
6977 -- parameters and discriminants, the error is on the designated types.
6979 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
6980 if Comes_From_Source
(Expec_Type
) then
6981 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
6984 ("expected an access type with designated}",
6985 Expr
, Designated_Type
(Expec_Type
));
6988 if Is_Access_Type
(Found_Type
)
6989 and then not Comes_From_Source
(Found_Type
)
6992 ("found an access type with designated}!",
6993 Expr
, Designated_Type
(Found_Type
));
6995 if From_With_Type
(Found_Type
) then
6996 Error_Msg_NE
("found incomplete}!", Expr
, Found_Type
);
6998 ("\possibly missing with_clause on&", Expr
,
6999 Scope
(Found_Type
));
7001 Error_Msg_NE
("found}!", Expr
, Found_Type
);
7005 -- Normal case of one type found, some other type expected
7008 -- If the names of the two types are the same, see if some
7009 -- number of levels of qualification will help. Don't try
7010 -- more than three levels, and if we get to standard, it's
7011 -- no use (and probably represents an error in the compiler)
7012 -- Also do not bother with internal scope names.
7015 Expec_Scope
: Entity_Id
;
7016 Found_Scope
: Entity_Id
;
7019 Expec_Scope
:= Expec_Type
;
7020 Found_Scope
:= Found_Type
;
7022 for Levels
in Int
range 0 .. 3 loop
7023 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
7024 Error_Msg_Qual_Level
:= Levels
;
7028 Expec_Scope
:= Scope
(Expec_Scope
);
7029 Found_Scope
:= Scope
(Found_Scope
);
7031 exit when Expec_Scope
= Standard_Standard
7032 or else Found_Scope
= Standard_Standard
7033 or else not Comes_From_Source
(Expec_Scope
)
7034 or else not Comes_From_Source
(Found_Scope
);
7038 if Is_Record_Type
(Expec_Type
)
7039 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
7041 Error_Msg_NE
("expected}!", Expr
,
7042 Corresponding_Remote_Type
(Expec_Type
));
7044 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
7047 if Is_Entity_Name
(Expr
)
7048 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
7050 Error_Msg_N
("found package name!", Expr
);
7052 elsif Is_Entity_Name
(Expr
)
7054 (Ekind
(Entity
(Expr
)) = E_Procedure
7056 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
7058 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
7060 ("found procedure name, possibly missing Access attribute!",
7063 Error_Msg_N
("found procedure name instead of function!", Expr
);
7066 elsif Nkind
(Expr
) = N_Function_Call
7067 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
7068 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
7069 and then No
(Parameter_Associations
(Expr
))
7072 ("found function name, possibly missing Access attribute!",
7075 -- Catch common error: a prefix or infix operator which is not
7076 -- directly visible because the type isn't.
7078 elsif Nkind
(Expr
) in N_Op
7079 and then Is_Overloaded
(Expr
)
7080 and then not Is_Immediately_Visible
(Expec_Type
)
7081 and then not Is_Potentially_Use_Visible
(Expec_Type
)
7082 and then not In_Use
(Expec_Type
)
7083 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
7086 ("operator of the type is not directly visible!", Expr
);
7088 elsif Ekind
(Found_Type
) = E_Void
7089 and then Present
(Parent
(Found_Type
))
7090 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
7092 Error_Msg_NE
("found premature usage of}!", Expr
, Found_Type
);
7095 Error_Msg_NE
("found}!", Expr
, Found_Type
);
7098 Error_Msg_Qual_Level
:= 0;