1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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);
1111 -- A static constraint error in an instance body is not a fatal error.
1112 -- we choose to inhibit the message altogether, because there is no
1113 -- obvious node (for now) on which to post it. On the other hand the
1114 -- offending node must be replaced with a constraint_error in any case.
1116 -- No messages are generated if we already posted an error on this node
1118 if not Error_Posted
(N
) then
1119 if Loc
/= No_Location
then
1125 -- Make all such messages unconditional
1127 Msgc
(1 .. Msg
'Length) := Msg
;
1128 Msgc
(Msg
'Length + 1) := '!';
1129 Msgl
:= Msg
'Length + 1;
1131 -- Message is a warning, even in Ada 95 case
1133 if Msg
(Msg
'Length) = '?' then
1136 -- In Ada 83, all messages are warnings. In the private part and
1137 -- the body of an instance, constraint_checks are only warnings.
1138 -- We also make this a warning if the Warn parameter is set.
1141 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
1147 elsif In_Instance_Not_Visible
then
1152 -- Otherwise we have a real error message (Ada 95 static case)
1158 -- Should we generate a warning? The answer is not quite yes. The
1159 -- very annoying exception occurs in the case of a short circuit
1160 -- operator where the left operand is static and decisive. Climb
1161 -- parents to see if that is the case we have here. Conditional
1162 -- expressions with decisive conditions are a similar situation.
1170 -- And then with False as left operand
1172 if Nkind
(P
) = N_And_Then
1173 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1174 and then Is_False
(Expr_Value
(Left_Opnd
(P
)))
1179 -- OR ELSE with True as left operand
1181 elsif Nkind
(P
) = N_Or_Else
1182 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1183 and then Is_True
(Expr_Value
(Left_Opnd
(P
)))
1188 -- Conditional expression
1190 elsif Nkind
(P
) = N_Conditional_Expression
then
1192 Cond
: constant Node_Id
:= First
(Expressions
(P
));
1193 Texp
: constant Node_Id
:= Next
(Cond
);
1194 Fexp
: constant Node_Id
:= Next
(Texp
);
1197 if Compile_Time_Known_Value
(Cond
) then
1199 -- Condition is True and we are in the right operand
1201 if Is_True
(Expr_Value
(Cond
))
1202 and then OldP
= Fexp
1207 -- Condition is False and we are in the left operand
1209 elsif Is_False
(Expr_Value
(Cond
))
1210 and then OldP
= Texp
1218 -- Special case for component association in aggregates, where
1219 -- we want to keep climbing up to the parent aggregate.
1221 elsif Nkind
(P
) = N_Component_Association
1222 and then Nkind
(Parent
(P
)) = N_Aggregate
1226 -- Keep going if within subexpression
1229 exit when Nkind
(P
) not in N_Subexpr
;
1234 if Present
(Ent
) then
1235 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
1237 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
1241 if Inside_Init_Proc
then
1243 ("\?& will be raised for objects of this type",
1244 N
, Standard_Constraint_Error
, Eloc
);
1247 ("\?& will be raised at run time",
1248 N
, Standard_Constraint_Error
, Eloc
);
1252 ("\static expression raises&!",
1253 N
, Standard_Constraint_Error
, Eloc
);
1259 end Compile_Time_Constraint_Error
;
1261 -----------------------
1262 -- Conditional_Delay --
1263 -----------------------
1265 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
1267 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
1268 Set_Has_Delayed_Freeze
(New_Ent
);
1270 end Conditional_Delay
;
1272 --------------------
1273 -- Current_Entity --
1274 --------------------
1276 -- The currently visible definition for a given identifier is the
1277 -- one most chained at the start of the visibility chain, i.e. the
1278 -- one that is referenced by the Node_Id value of the name of the
1279 -- given identifier.
1281 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
1283 return Get_Name_Entity_Id
(Chars
(N
));
1286 -----------------------------
1287 -- Current_Entity_In_Scope --
1288 -----------------------------
1290 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
1292 CS
: constant Entity_Id
:= Current_Scope
;
1294 Transient_Case
: constant Boolean := Scope_Is_Transient
;
1297 E
:= Get_Name_Entity_Id
(Chars
(N
));
1300 and then Scope
(E
) /= CS
1301 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
1307 end Current_Entity_In_Scope
;
1313 function Current_Scope
return Entity_Id
is
1315 if Scope_Stack
.Last
= -1 then
1316 return Standard_Standard
;
1319 C
: constant Entity_Id
:=
1320 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
1325 return Standard_Standard
;
1331 ------------------------
1332 -- Current_Subprogram --
1333 ------------------------
1335 function Current_Subprogram
return Entity_Id
is
1336 Scop
: constant Entity_Id
:= Current_Scope
;
1339 if Is_Subprogram
(Scop
) or else Is_Generic_Subprogram
(Scop
) then
1342 return Enclosing_Subprogram
(Scop
);
1344 end Current_Subprogram
;
1346 ---------------------
1347 -- Defining_Entity --
1348 ---------------------
1350 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
1351 K
: constant Node_Kind
:= Nkind
(N
);
1352 Err
: Entity_Id
:= Empty
;
1357 N_Subprogram_Declaration |
1358 N_Abstract_Subprogram_Declaration |
1360 N_Package_Declaration |
1361 N_Subprogram_Renaming_Declaration |
1362 N_Subprogram_Body_Stub |
1363 N_Generic_Subprogram_Declaration |
1364 N_Generic_Package_Declaration |
1365 N_Formal_Subprogram_Declaration
1367 return Defining_Entity
(Specification
(N
));
1370 N_Component_Declaration |
1371 N_Defining_Program_Unit_Name |
1372 N_Discriminant_Specification |
1374 N_Entry_Declaration |
1375 N_Entry_Index_Specification |
1376 N_Exception_Declaration |
1377 N_Exception_Renaming_Declaration |
1378 N_Formal_Object_Declaration |
1379 N_Formal_Package_Declaration |
1380 N_Formal_Type_Declaration |
1381 N_Full_Type_Declaration |
1382 N_Implicit_Label_Declaration |
1383 N_Incomplete_Type_Declaration |
1384 N_Loop_Parameter_Specification |
1385 N_Number_Declaration |
1386 N_Object_Declaration |
1387 N_Object_Renaming_Declaration |
1388 N_Package_Body_Stub |
1389 N_Parameter_Specification |
1390 N_Private_Extension_Declaration |
1391 N_Private_Type_Declaration |
1393 N_Protected_Body_Stub |
1394 N_Protected_Type_Declaration |
1395 N_Single_Protected_Declaration |
1396 N_Single_Task_Declaration |
1397 N_Subtype_Declaration |
1400 N_Task_Type_Declaration
1402 return Defining_Identifier
(N
);
1405 return Defining_Entity
(Proper_Body
(N
));
1408 N_Function_Instantiation |
1409 N_Function_Specification |
1410 N_Generic_Function_Renaming_Declaration |
1411 N_Generic_Package_Renaming_Declaration |
1412 N_Generic_Procedure_Renaming_Declaration |
1414 N_Package_Instantiation |
1415 N_Package_Renaming_Declaration |
1416 N_Package_Specification |
1417 N_Procedure_Instantiation |
1418 N_Procedure_Specification
1421 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
1424 if Nkind
(Nam
) in N_Entity
then
1427 -- For Error, make up a name and attach to declaration
1428 -- so we can continue semantic analysis
1430 elsif Nam
= Error
then
1432 Make_Defining_Identifier
(Sloc
(N
),
1433 Chars
=> New_Internal_Name
('T'));
1434 Set_Defining_Unit_Name
(N
, Err
);
1437 -- If not an entity, get defining identifier
1440 return Defining_Identifier
(Nam
);
1444 when N_Block_Statement
=>
1445 return Entity
(Identifier
(N
));
1448 raise Program_Error
;
1451 end Defining_Entity
;
1453 --------------------------
1454 -- Denotes_Discriminant --
1455 --------------------------
1457 function Denotes_Discriminant
1459 Check_Protected
: Boolean := False) return Boolean
1463 if not Is_Entity_Name
(N
)
1464 or else No
(Entity
(N
))
1471 -- If we are checking for a protected type, the discriminant may have
1472 -- been rewritten as the corresponding discriminal of the original type
1473 -- or of the corresponding concurrent record, depending on whether we
1474 -- are in the spec or body of the protected type.
1476 return Ekind
(E
) = E_Discriminant
1479 and then Ekind
(E
) = E_In_Parameter
1480 and then Present
(Discriminal_Link
(E
))
1482 (Is_Protected_Type
(Scope
(Discriminal_Link
(E
)))
1484 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
1486 end Denotes_Discriminant
;
1488 -----------------------------
1489 -- Depends_On_Discriminant --
1490 -----------------------------
1492 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
1497 Get_Index_Bounds
(N
, L
, H
);
1498 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
1499 end Depends_On_Discriminant
;
1501 -------------------------
1502 -- Designate_Same_Unit --
1503 -------------------------
1505 function Designate_Same_Unit
1507 Name2
: Node_Id
) return Boolean
1509 K1
: constant Node_Kind
:= Nkind
(Name1
);
1510 K2
: constant Node_Kind
:= Nkind
(Name2
);
1512 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
1513 -- Returns the parent unit name node of a defining program unit name
1514 -- or the prefix if N is a selected component or an expanded name.
1516 function Select_Node
(N
: Node_Id
) return Node_Id
;
1517 -- Returns the defining identifier node of a defining program unit
1518 -- name or the selector node if N is a selected component or an
1525 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
1527 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1539 function Select_Node
(N
: Node_Id
) return Node_Id
is
1541 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1542 return Defining_Identifier
(N
);
1545 return Selector_Name
(N
);
1549 -- Start of processing for Designate_Next_Unit
1552 if (K1
= N_Identifier
or else
1553 K1
= N_Defining_Identifier
)
1555 (K2
= N_Identifier
or else
1556 K2
= N_Defining_Identifier
)
1558 return Chars
(Name1
) = Chars
(Name2
);
1561 (K1
= N_Expanded_Name
or else
1562 K1
= N_Selected_Component
or else
1563 K1
= N_Defining_Program_Unit_Name
)
1565 (K2
= N_Expanded_Name
or else
1566 K2
= N_Selected_Component
or else
1567 K2
= N_Defining_Program_Unit_Name
)
1570 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
1572 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
1577 end Designate_Same_Unit
;
1579 ----------------------------
1580 -- Enclosing_Generic_Body --
1581 ----------------------------
1583 function Enclosing_Generic_Body
1584 (N
: Node_Id
) return Node_Id
1592 while Present
(P
) loop
1593 if Nkind
(P
) = N_Package_Body
1594 or else Nkind
(P
) = N_Subprogram_Body
1596 Spec
:= Corresponding_Spec
(P
);
1598 if Present
(Spec
) then
1599 Decl
:= Unit_Declaration_Node
(Spec
);
1601 if Nkind
(Decl
) = N_Generic_Package_Declaration
1602 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
1613 end Enclosing_Generic_Body
;
1615 ----------------------------
1616 -- Enclosing_Generic_Unit --
1617 ----------------------------
1619 function Enclosing_Generic_Unit
1620 (N
: Node_Id
) return Node_Id
1628 while Present
(P
) loop
1629 if Nkind
(P
) = N_Generic_Package_Declaration
1630 or else Nkind
(P
) = N_Generic_Subprogram_Declaration
1634 elsif Nkind
(P
) = N_Package_Body
1635 or else Nkind
(P
) = N_Subprogram_Body
1637 Spec
:= Corresponding_Spec
(P
);
1639 if Present
(Spec
) then
1640 Decl
:= Unit_Declaration_Node
(Spec
);
1642 if Nkind
(Decl
) = N_Generic_Package_Declaration
1643 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
1654 end Enclosing_Generic_Unit
;
1656 -------------------------------
1657 -- Enclosing_Lib_Unit_Entity --
1658 -------------------------------
1660 function Enclosing_Lib_Unit_Entity
return Entity_Id
is
1661 Unit_Entity
: Entity_Id
:= Current_Scope
;
1664 -- Look for enclosing library unit entity by following scope links.
1665 -- Equivalent to, but faster than indexing through the scope stack.
1667 while (Present
(Scope
(Unit_Entity
))
1668 and then Scope
(Unit_Entity
) /= Standard_Standard
)
1669 and not Is_Child_Unit
(Unit_Entity
)
1671 Unit_Entity
:= Scope
(Unit_Entity
);
1675 end Enclosing_Lib_Unit_Entity
;
1677 -----------------------------
1678 -- Enclosing_Lib_Unit_Node --
1679 -----------------------------
1681 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
1682 Current_Node
: Node_Id
:= N
;
1685 while Present
(Current_Node
)
1686 and then Nkind
(Current_Node
) /= N_Compilation_Unit
1688 Current_Node
:= Parent
(Current_Node
);
1691 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
1695 return Current_Node
;
1696 end Enclosing_Lib_Unit_Node
;
1698 --------------------------
1699 -- Enclosing_Subprogram --
1700 --------------------------
1702 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
1703 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
1706 if Dynamic_Scope
= Standard_Standard
then
1709 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
1710 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
1712 elsif Ekind
(Dynamic_Scope
) = E_Block
then
1713 return Enclosing_Subprogram
(Dynamic_Scope
);
1715 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
1716 return Get_Task_Body_Procedure
(Dynamic_Scope
);
1718 elsif Convention
(Dynamic_Scope
) = Convention_Protected
then
1719 return Protected_Body_Subprogram
(Dynamic_Scope
);
1722 return Dynamic_Scope
;
1724 end Enclosing_Subprogram
;
1726 ------------------------
1727 -- Ensure_Freeze_Node --
1728 ------------------------
1730 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
1734 if No
(Freeze_Node
(E
)) then
1735 FN
:= Make_Freeze_Entity
(Sloc
(E
));
1736 Set_Has_Delayed_Freeze
(E
);
1737 Set_Freeze_Node
(E
, FN
);
1738 Set_Access_Types_To_Process
(FN
, No_Elist
);
1739 Set_TSS_Elist
(FN
, No_Elist
);
1742 end Ensure_Freeze_Node
;
1748 procedure Enter_Name
(Def_Id
: Entity_Id
) is
1749 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
1750 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
1751 S
: constant Entity_Id
:= Current_Scope
;
1753 function Is_Private_Component_Renaming
(N
: Node_Id
) return Boolean;
1754 -- Recognize a renaming declaration that is introduced for private
1755 -- components of a protected type. We treat these as weak declarations
1756 -- so that they are overridden by entities with the same name that
1757 -- come from source, such as formals or local variables of a given
1758 -- protected declaration.
1760 -----------------------------------
1761 -- Is_Private_Component_Renaming --
1762 -----------------------------------
1764 function Is_Private_Component_Renaming
(N
: Node_Id
) return Boolean is
1766 return not Comes_From_Source
(N
)
1767 and then not Comes_From_Source
(Current_Scope
)
1768 and then Nkind
(N
) = N_Object_Renaming_Declaration
;
1769 end Is_Private_Component_Renaming
;
1771 -- Start of processing for Enter_Name
1774 Generate_Definition
(Def_Id
);
1776 -- Add new name to current scope declarations. Check for duplicate
1777 -- declaration, which may or may not be a genuine error.
1781 -- Case of previous entity entered because of a missing declaration
1782 -- or else a bad subtype indication. Best is to use the new entity,
1783 -- and make the previous one invisible.
1785 if Etype
(E
) = Any_Type
then
1786 Set_Is_Immediately_Visible
(E
, False);
1788 -- Case of renaming declaration constructed for package instances.
1789 -- if there is an explicit declaration with the same identifier,
1790 -- the renaming is not immediately visible any longer, but remains
1791 -- visible through selected component notation.
1793 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
1794 and then not Comes_From_Source
(E
)
1796 Set_Is_Immediately_Visible
(E
, False);
1798 -- The new entity may be the package renaming, which has the same
1799 -- same name as a generic formal which has been seen already.
1801 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
1802 and then not Comes_From_Source
(Def_Id
)
1804 Set_Is_Immediately_Visible
(E
, False);
1806 -- For a fat pointer corresponding to a remote access to subprogram,
1807 -- we use the same identifier as the RAS type, so that the proper
1808 -- name appears in the stub. This type is only retrieved through
1809 -- the RAS type and never by visibility, and is not added to the
1810 -- visibility list (see below).
1812 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
1813 and then Present
(Corresponding_Remote_Type
(Def_Id
))
1817 -- A controller component for a type extension overrides the
1818 -- inherited component.
1820 elsif Chars
(E
) = Name_uController
then
1823 -- Case of an implicit operation or derived literal. The new entity
1824 -- hides the implicit one, which is removed from all visibility,
1825 -- i.e. the entity list of its scope, and homonym chain of its name.
1827 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
1828 or else Is_Internal
(E
)
1832 Prev_Vis
: Entity_Id
;
1833 Decl
: constant Node_Id
:= Parent
(E
);
1836 -- If E is an implicit declaration, it cannot be the first
1837 -- entity in the scope.
1839 Prev
:= First_Entity
(Current_Scope
);
1841 while Present
(Prev
)
1842 and then Next_Entity
(Prev
) /= E
1849 -- If E is not on the entity chain of the current scope,
1850 -- it is an implicit declaration in the generic formal
1851 -- part of a generic subprogram. When analyzing the body,
1852 -- the generic formals are visible but not on the entity
1853 -- chain of the subprogram. The new entity will become
1854 -- the visible one in the body.
1857 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
1861 Set_Next_Entity
(Prev
, Next_Entity
(E
));
1863 if No
(Next_Entity
(Prev
)) then
1864 Set_Last_Entity
(Current_Scope
, Prev
);
1867 if E
= Current_Entity
(E
) then
1871 Prev_Vis
:= Current_Entity
(E
);
1872 while Homonym
(Prev_Vis
) /= E
loop
1873 Prev_Vis
:= Homonym
(Prev_Vis
);
1877 if Present
(Prev_Vis
) then
1879 -- Skip E in the visibility chain
1881 Set_Homonym
(Prev_Vis
, Homonym
(E
));
1884 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
1889 -- This section of code could use a comment ???
1891 elsif Present
(Etype
(E
))
1892 and then Is_Concurrent_Type
(Etype
(E
))
1897 elsif Is_Private_Component_Renaming
(Parent
(Def_Id
)) then
1900 -- In the body or private part of an instance, a type extension
1901 -- may introduce a component with the same name as that of an
1902 -- actual. The legality rule is not enforced, but the semantics
1903 -- of the full type with two components of the same name are not
1904 -- clear at this point ???
1906 elsif In_Instance_Not_Visible
then
1909 -- When compiling a package body, some child units may have become
1910 -- visible. They cannot conflict with local entities that hide them.
1912 elsif Is_Child_Unit
(E
)
1913 and then In_Open_Scopes
(Scope
(E
))
1914 and then not Is_Immediately_Visible
(E
)
1918 -- Conversely, with front-end inlining we may compile the parent
1919 -- body first, and a child unit subsequently. The context is now
1920 -- the parent spec, and body entities are not visible.
1922 elsif Is_Child_Unit
(Def_Id
)
1923 and then Is_Package_Body_Entity
(E
)
1924 and then not In_Package_Body
(Current_Scope
)
1928 -- Case of genuine duplicate declaration
1931 Error_Msg_Sloc
:= Sloc
(E
);
1933 -- If the previous declaration is an incomplete type declaration
1934 -- this may be an attempt to complete it with a private type.
1935 -- The following avoids confusing cascaded errors.
1937 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
1938 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
1941 ("incomplete type cannot be completed" &
1942 " with a private declaration",
1944 Set_Is_Immediately_Visible
(E
, False);
1945 Set_Full_View
(E
, Def_Id
);
1947 elsif Ekind
(E
) = E_Discriminant
1948 and then Present
(Scope
(Def_Id
))
1949 and then Scope
(Def_Id
) /= Current_Scope
1951 -- An inherited component of a record conflicts with
1952 -- a new discriminant. The discriminant is inserted first
1953 -- in the scope, but the error should be posted on it, not
1954 -- on the component.
1956 Error_Msg_Sloc
:= Sloc
(Def_Id
);
1957 Error_Msg_N
("& conflicts with declaration#", E
);
1960 -- If the name of the unit appears in its own context clause,
1961 -- a dummy package with the name has already been created, and
1962 -- the error emitted. Try to continue quietly.
1964 elsif Error_Posted
(E
)
1965 and then Sloc
(E
) = No_Location
1966 and then Nkind
(Parent
(E
)) = N_Package_Specification
1967 and then Current_Scope
= Standard_Standard
1969 Set_Scope
(Def_Id
, Current_Scope
);
1973 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
1975 -- Avoid cascaded messages with duplicate components in
1978 if Ekind
(E
) = E_Component
1979 or else Ekind
(E
) = E_Discriminant
1985 if Nkind
(Parent
(Parent
(Def_Id
)))
1986 = N_Generic_Subprogram_Declaration
1988 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
1990 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
1993 -- If entity is in standard, then we are in trouble, because
1994 -- it means that we have a library package with a duplicated
1995 -- name. That's hard to recover from, so abort!
1997 if S
= Standard_Standard
then
1998 raise Unrecoverable_Error
;
2000 -- Otherwise we continue with the declaration. Having two
2001 -- identical declarations should not cause us too much trouble!
2009 -- If we fall through, declaration is OK , or OK enough to continue
2011 -- If Def_Id is a discriminant or a record component we are in the
2012 -- midst of inheriting components in a derived record definition.
2013 -- Preserve their Ekind and Etype.
2015 if Ekind
(Def_Id
) = E_Discriminant
2016 or else Ekind
(Def_Id
) = E_Component
2020 -- If a type is already set, leave it alone (happens whey a type
2021 -- declaration is reanalyzed following a call to the optimizer)
2023 elsif Present
(Etype
(Def_Id
)) then
2026 -- Otherwise, the kind E_Void insures that premature uses of the entity
2027 -- will be detected. Any_Type insures that no cascaded errors will occur
2030 Set_Ekind
(Def_Id
, E_Void
);
2031 Set_Etype
(Def_Id
, Any_Type
);
2034 -- Inherited discriminants and components in derived record types are
2035 -- immediately visible. Itypes are not.
2037 if Ekind
(Def_Id
) = E_Discriminant
2038 or else Ekind
(Def_Id
) = E_Component
2039 or else (No
(Corresponding_Remote_Type
(Def_Id
))
2040 and then not Is_Itype
(Def_Id
))
2042 Set_Is_Immediately_Visible
(Def_Id
);
2043 Set_Current_Entity
(Def_Id
);
2046 Set_Homonym
(Def_Id
, C
);
2047 Append_Entity
(Def_Id
, S
);
2048 Set_Public_Status
(Def_Id
);
2050 -- Warn if new entity hides an old one
2053 and then Present
(C
)
2054 and then Length_Of_Name
(Chars
(C
)) /= 1
2055 and then Comes_From_Source
(C
)
2056 and then Comes_From_Source
(Def_Id
)
2057 and then In_Extended_Main_Source_Unit
(Def_Id
)
2059 Error_Msg_Sloc
:= Sloc
(C
);
2060 Error_Msg_N
("declaration hides &#?", Def_Id
);
2064 --------------------------
2065 -- Explain_Limited_Type --
2066 --------------------------
2068 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
2072 -- For array, component type must be limited
2074 if Is_Array_Type
(T
) then
2075 Error_Msg_Node_2
:= T
;
2077 ("component type& of type& is limited", N
, Component_Type
(T
));
2078 Explain_Limited_Type
(Component_Type
(T
), N
);
2080 elsif Is_Record_Type
(T
) then
2082 -- No need for extra messages if explicit limited record
2084 if Is_Limited_Record
(Base_Type
(T
)) then
2088 -- Otherwise find a limited component. Check only components that
2089 -- come from source, or inherited components that appear in the
2090 -- source of the ancestor.
2092 C
:= First_Component
(T
);
2093 while Present
(C
) loop
2094 if Is_Limited_Type
(Etype
(C
))
2096 (Comes_From_Source
(C
)
2098 (Present
(Original_Record_Component
(C
))
2100 Comes_From_Source
(Original_Record_Component
(C
))))
2102 Error_Msg_Node_2
:= T
;
2103 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
2104 Explain_Limited_Type
(Etype
(C
), N
);
2111 -- The type may be declared explicitly limited, even if no component
2112 -- of it is limited, in which case we fall out of the loop.
2115 end Explain_Limited_Type
;
2117 -------------------------------------
2118 -- Find_Corresponding_Discriminant --
2119 -------------------------------------
2121 function Find_Corresponding_Discriminant
2123 Typ
: Entity_Id
) return Entity_Id
2125 Par_Disc
: Entity_Id
;
2126 Old_Disc
: Entity_Id
;
2127 New_Disc
: Entity_Id
;
2130 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
2132 -- The original type may currently be private, and the discriminant
2133 -- only appear on its full view.
2135 if Is_Private_Type
(Scope
(Par_Disc
))
2136 and then not Has_Discriminants
(Scope
(Par_Disc
))
2137 and then Present
(Full_View
(Scope
(Par_Disc
)))
2139 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
2141 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
2144 if Is_Class_Wide_Type
(Typ
) then
2145 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
2147 New_Disc
:= First_Discriminant
(Typ
);
2150 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
2151 if Old_Disc
= Par_Disc
then
2154 Next_Discriminant
(Old_Disc
);
2155 Next_Discriminant
(New_Disc
);
2159 -- Should always find it
2161 raise Program_Error
;
2162 end Find_Corresponding_Discriminant
;
2164 -----------------------------
2165 -- Find_Static_Alternative --
2166 -----------------------------
2168 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
2169 Expr
: constant Node_Id
:= Expression
(N
);
2170 Val
: constant Uint
:= Expr_Value
(Expr
);
2175 Alt
:= First
(Alternatives
(N
));
2178 if Nkind
(Alt
) /= N_Pragma
then
2179 Choice
:= First
(Discrete_Choices
(Alt
));
2181 while Present
(Choice
) loop
2183 -- Others choice, always matches
2185 if Nkind
(Choice
) = N_Others_Choice
then
2188 -- Range, check if value is in the range
2190 elsif Nkind
(Choice
) = N_Range
then
2192 Val
>= Expr_Value
(Low_Bound
(Choice
))
2194 Val
<= Expr_Value
(High_Bound
(Choice
));
2196 -- Choice is a subtype name. Note that we know it must
2197 -- be a static subtype, since otherwise it would have
2198 -- been diagnosed as illegal.
2200 elsif Is_Entity_Name
(Choice
)
2201 and then Is_Type
(Entity
(Choice
))
2203 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
));
2205 -- Choice is a subtype indication
2207 elsif Nkind
(Choice
) = N_Subtype_Indication
then
2209 C
: constant Node_Id
:= Constraint
(Choice
);
2210 R
: constant Node_Id
:= Range_Expression
(C
);
2214 Val
>= Expr_Value
(Low_Bound
(R
))
2216 Val
<= Expr_Value
(High_Bound
(R
));
2219 -- Choice is a simple expression
2222 exit Search
when Val
= Expr_Value
(Choice
);
2230 pragma Assert
(Present
(Alt
));
2233 -- The above loop *must* terminate by finding a match, since
2234 -- we know the case statement is valid, and the value of the
2235 -- expression is known at compile time. When we fall out of
2236 -- the loop, Alt points to the alternative that we know will
2237 -- be selected at run time.
2240 end Find_Static_Alternative
;
2246 function First_Actual
(Node
: Node_Id
) return Node_Id
is
2250 if No
(Parameter_Associations
(Node
)) then
2254 N
:= First
(Parameter_Associations
(Node
));
2256 if Nkind
(N
) = N_Parameter_Association
then
2257 return First_Named_Actual
(Node
);
2263 -------------------------
2264 -- Full_Qualified_Name --
2265 -------------------------
2267 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2269 pragma Warnings
(Off
, Res
);
2271 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
2272 -- Compute recursively the qualified name without NUL at the end
2274 ----------------------------------
2275 -- Internal_Full_Qualified_Name --
2276 ----------------------------------
2278 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
2279 Ent
: Entity_Id
:= E
;
2280 Parent_Name
: String_Id
:= No_String
;
2283 -- Deals properly with child units
2285 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
2286 Ent
:= Defining_Identifier
(Ent
);
2289 -- Compute qualification recursively (only "Standard" has no scope)
2291 if Present
(Scope
(Scope
(Ent
))) then
2292 Parent_Name
:= Internal_Full_Qualified_Name
(Scope
(Ent
));
2295 -- Every entity should have a name except some expanded blocks
2296 -- don't bother about those.
2298 if Chars
(Ent
) = No_Name
then
2302 -- Add a period between Name and qualification
2304 if Parent_Name
/= No_String
then
2305 Start_String
(Parent_Name
);
2306 Store_String_Char
(Get_Char_Code
('.'));
2312 -- Generates the entity name in upper case
2314 Get_Decoded_Name_String
(Chars
(Ent
));
2316 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2318 end Internal_Full_Qualified_Name
;
2320 -- Start of processing for Full_Qualified_Name
2323 Res
:= Internal_Full_Qualified_Name
(E
);
2324 Store_String_Char
(Get_Char_Code
(ASCII
.nul
));
2326 end Full_Qualified_Name
;
2328 -----------------------
2329 -- Gather_Components --
2330 -----------------------
2332 procedure Gather_Components
2334 Comp_List
: Node_Id
;
2335 Governed_By
: List_Id
;
2337 Report_Errors
: out Boolean)
2341 Discrete_Choice
: Node_Id
;
2342 Comp_Item
: Node_Id
;
2344 Discrim
: Entity_Id
;
2345 Discrim_Name
: Node_Id
;
2346 Discrim_Value
: Node_Id
;
2349 Report_Errors
:= False;
2351 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
2354 elsif Present
(Component_Items
(Comp_List
)) then
2355 Comp_Item
:= First
(Component_Items
(Comp_List
));
2361 while Present
(Comp_Item
) loop
2363 -- Skip the tag of a tagged record, the interface tags, as well
2364 -- as all items that are not user components (anonymous types,
2365 -- rep clauses, Parent field, controller field).
2367 if Nkind
(Comp_Item
) = N_Component_Declaration
then
2369 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
2371 if not Is_Tag
(Comp
)
2372 and then Chars
(Comp
) /= Name_uParent
2373 and then Chars
(Comp
) /= Name_uController
2375 Append_Elmt
(Comp
, Into
);
2383 if No
(Variant_Part
(Comp_List
)) then
2386 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
2387 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
2390 -- Look for the discriminant that governs this variant part.
2391 -- The discriminant *must* be in the Governed_By List
2393 Assoc
:= First
(Governed_By
);
2394 Find_Constraint
: loop
2395 Discrim
:= First
(Choices
(Assoc
));
2396 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
2397 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
2399 Chars
(Corresponding_Discriminant
(Entity
(Discrim
)))
2400 = Chars
(Discrim_Name
))
2401 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
2402 = Chars
(Discrim_Name
);
2404 if No
(Next
(Assoc
)) then
2405 if not Is_Constrained
(Typ
)
2406 and then Is_Derived_Type
(Typ
)
2407 and then Present
(Stored_Constraint
(Typ
))
2410 -- If the type is a tagged type with inherited discriminants,
2411 -- use the stored constraint on the parent in order to find
2412 -- the values of discriminants that are otherwise hidden by an
2413 -- explicit constraint. Renamed discriminants are handled in
2416 -- If several parent discriminants are renamed by a single
2417 -- discriminant of the derived type, the call to obtain the
2418 -- Corresponding_Discriminant field only retrieves the last
2419 -- of them. We recover the constraint on the others from the
2420 -- Stored_Constraint as well.
2427 D
:= First_Discriminant
(Etype
(Typ
));
2428 C
:= First_Elmt
(Stored_Constraint
(Typ
));
2431 and then Present
(C
)
2433 if Chars
(Discrim_Name
) = Chars
(D
) then
2434 if Is_Entity_Name
(Node
(C
))
2435 and then Entity
(Node
(C
)) = Entity
(Discrim
)
2437 -- D is renamed by Discrim, whose value is
2444 Make_Component_Association
(Sloc
(Typ
),
2446 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
2447 Duplicate_Subexpr_No_Checks
(Node
(C
)));
2449 exit Find_Constraint
;
2452 D
:= Next_Discriminant
(D
);
2459 if No
(Next
(Assoc
)) then
2460 Error_Msg_NE
(" missing value for discriminant&",
2461 First
(Governed_By
), Discrim_Name
);
2462 Report_Errors
:= True;
2467 end loop Find_Constraint
;
2469 Discrim_Value
:= Expression
(Assoc
);
2471 if not Is_OK_Static_Expression
(Discrim_Value
) then
2473 ("value for discriminant & must be static!",
2474 Discrim_Value
, Discrim
);
2475 Why_Not_Static
(Discrim_Value
);
2476 Report_Errors
:= True;
2480 Search_For_Discriminant_Value
: declare
2486 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
2489 Find_Discrete_Value
: while Present
(Variant
) loop
2490 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
2491 while Present
(Discrete_Choice
) loop
2493 exit Find_Discrete_Value
when
2494 Nkind
(Discrete_Choice
) = N_Others_Choice
;
2496 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
2498 UI_Low
:= Expr_Value
(Low
);
2499 UI_High
:= Expr_Value
(High
);
2501 exit Find_Discrete_Value
when
2502 UI_Low
<= UI_Discrim_Value
2504 UI_High
>= UI_Discrim_Value
;
2506 Next
(Discrete_Choice
);
2509 Next_Non_Pragma
(Variant
);
2510 end loop Find_Discrete_Value
;
2511 end Search_For_Discriminant_Value
;
2513 if No
(Variant
) then
2515 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
2516 Report_Errors
:= True;
2520 -- If we have found the corresponding choice, recursively add its
2521 -- components to the Into list.
2523 Gather_Components
(Empty
,
2524 Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
2525 end Gather_Components
;
2527 ------------------------
2528 -- Get_Actual_Subtype --
2529 ------------------------
2531 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
2532 Typ
: constant Entity_Id
:= Etype
(N
);
2533 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
2542 -- If what we have is an identifier that references a subprogram
2543 -- formal, or a variable or constant object, then we get the actual
2544 -- subtype from the referenced entity if one has been built.
2546 if Nkind
(N
) = N_Identifier
2548 (Is_Formal
(Entity
(N
))
2549 or else Ekind
(Entity
(N
)) = E_Constant
2550 or else Ekind
(Entity
(N
)) = E_Variable
)
2551 and then Present
(Actual_Subtype
(Entity
(N
)))
2553 return Actual_Subtype
(Entity
(N
));
2555 -- Actual subtype of unchecked union is always itself. We never need
2556 -- the "real" actual subtype. If we did, we couldn't get it anyway
2557 -- because the discriminant is not available. The restrictions on
2558 -- Unchecked_Union are designed to make sure that this is OK.
2560 elsif Is_Unchecked_Union
(Base_Type
(Utyp
)) then
2563 -- Here for the unconstrained case, we must find actual subtype
2564 -- No actual subtype is available, so we must build it on the fly.
2566 -- Checking the type, not the underlying type, for constrainedness
2567 -- seems to be necessary. Maybe all the tests should be on the type???
2569 elsif (not Is_Constrained
(Typ
))
2570 and then (Is_Array_Type
(Utyp
)
2571 or else (Is_Record_Type
(Utyp
)
2572 and then Has_Discriminants
(Utyp
)))
2573 and then not Has_Unknown_Discriminants
(Utyp
)
2574 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
2576 -- Nothing to do if in default expression
2578 if In_Default_Expression
then
2581 elsif Is_Private_Type
(Typ
)
2582 and then not Has_Discriminants
(Typ
)
2584 -- If the type has no discriminants, there is no subtype to
2585 -- build, even if the underlying type is discriminated.
2589 -- Else build the actual subtype
2592 Decl
:= Build_Actual_Subtype
(Typ
, N
);
2593 Atyp
:= Defining_Identifier
(Decl
);
2595 -- If Build_Actual_Subtype generated a new declaration then use it
2599 -- The actual subtype is an Itype, so analyze the declaration,
2600 -- but do not attach it to the tree, to get the type defined.
2602 Set_Parent
(Decl
, N
);
2603 Set_Is_Itype
(Atyp
);
2604 Analyze
(Decl
, Suppress
=> All_Checks
);
2605 Set_Associated_Node_For_Itype
(Atyp
, N
);
2606 Set_Has_Delayed_Freeze
(Atyp
, False);
2608 -- We need to freeze the actual subtype immediately. This is
2609 -- needed, because otherwise this Itype will not get frozen
2610 -- at all, and it is always safe to freeze on creation because
2611 -- any associated types must be frozen at this point.
2613 Freeze_Itype
(Atyp
, N
);
2616 -- Otherwise we did not build a declaration, so return original
2623 -- For all remaining cases, the actual subtype is the same as
2624 -- the nominal type.
2629 end Get_Actual_Subtype
;
2631 -------------------------------------
2632 -- Get_Actual_Subtype_If_Available --
2633 -------------------------------------
2635 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
2636 Typ
: constant Entity_Id
:= Etype
(N
);
2639 -- If what we have is an identifier that references a subprogram
2640 -- formal, or a variable or constant object, then we get the actual
2641 -- subtype from the referenced entity if one has been built.
2643 if Nkind
(N
) = N_Identifier
2645 (Is_Formal
(Entity
(N
))
2646 or else Ekind
(Entity
(N
)) = E_Constant
2647 or else Ekind
(Entity
(N
)) = E_Variable
)
2648 and then Present
(Actual_Subtype
(Entity
(N
)))
2650 return Actual_Subtype
(Entity
(N
));
2652 -- Otherwise the Etype of N is returned unchanged
2657 end Get_Actual_Subtype_If_Available
;
2659 -------------------------------
2660 -- Get_Default_External_Name --
2661 -------------------------------
2663 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
2665 Get_Decoded_Name_String
(Chars
(E
));
2667 if Opt
.External_Name_Imp_Casing
= Uppercase
then
2668 Set_Casing
(All_Upper_Case
);
2670 Set_Casing
(All_Lower_Case
);
2674 Make_String_Literal
(Sloc
(E
),
2675 Strval
=> String_From_Name_Buffer
);
2676 end Get_Default_External_Name
;
2678 ---------------------------
2679 -- Get_Enum_Lit_From_Pos --
2680 ---------------------------
2682 function Get_Enum_Lit_From_Pos
2685 Loc
: Source_Ptr
) return Node_Id
2690 -- In the case where the literal is of type Character, Wide_Character
2691 -- or Wide_Wide_Character or of a type derived from them, there needs
2692 -- to be some special handling since there is no explicit chain of
2693 -- literals to search. Instead, an N_Character_Literal node is created
2694 -- with the appropriate Char_Code and Chars fields.
2696 if Root_Type
(T
) = Standard_Character
2697 or else Root_Type
(T
) = Standard_Wide_Character
2698 or else Root_Type
(T
) = Standard_Wide_Wide_Character
2700 Set_Character_Literal_Name
(UI_To_CC
(Pos
));
2702 Make_Character_Literal
(Loc
,
2704 Char_Literal_Value
=> Pos
);
2706 -- For all other cases, we have a complete table of literals, and
2707 -- we simply iterate through the chain of literal until the one
2708 -- with the desired position value is found.
2712 Lit
:= First_Literal
(Base_Type
(T
));
2713 for J
in 1 .. UI_To_Int
(Pos
) loop
2717 return New_Occurrence_Of
(Lit
, Loc
);
2719 end Get_Enum_Lit_From_Pos
;
2721 ------------------------
2722 -- Get_Generic_Entity --
2723 ------------------------
2725 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
2726 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2728 if Present
(Renamed_Object
(Ent
)) then
2729 return Renamed_Object
(Ent
);
2733 end Get_Generic_Entity
;
2735 ----------------------
2736 -- Get_Index_Bounds --
2737 ----------------------
2739 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
2740 Kind
: constant Node_Kind
:= Nkind
(N
);
2744 if Kind
= N_Range
then
2746 H
:= High_Bound
(N
);
2748 elsif Kind
= N_Subtype_Indication
then
2749 R
:= Range_Expression
(Constraint
(N
));
2757 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
2758 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
2761 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
2762 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
2766 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
2767 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
2770 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
2771 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
2775 -- N is an expression, indicating a range with one value
2780 end Get_Index_Bounds
;
2782 ----------------------------------
2783 -- Get_Library_Unit_Name_string --
2784 ----------------------------------
2786 procedure Get_Library_Unit_Name_String
(Decl_Node
: Node_Id
) is
2787 Unit_Name_Id
: constant Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
2790 Get_Unit_Name_String
(Unit_Name_Id
);
2792 -- Remove seven last character (" (spec)" or " (body)")
2794 Name_Len
:= Name_Len
- 7;
2795 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
2796 end Get_Library_Unit_Name_String
;
2798 ------------------------
2799 -- Get_Name_Entity_Id --
2800 ------------------------
2802 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
2804 return Entity_Id
(Get_Name_Table_Info
(Id
));
2805 end Get_Name_Entity_Id
;
2807 ---------------------------
2808 -- Get_Referenced_Object --
2809 ---------------------------
2811 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
2815 while Is_Entity_Name
(R
)
2816 and then Present
(Renamed_Object
(Entity
(R
)))
2818 R
:= Renamed_Object
(Entity
(R
));
2822 end Get_Referenced_Object
;
2824 -------------------------
2825 -- Get_Subprogram_Body --
2826 -------------------------
2828 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
2832 Decl
:= Unit_Declaration_Node
(E
);
2834 if Nkind
(Decl
) = N_Subprogram_Body
then
2837 -- The below comment is bad, because it is possible for
2838 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
2840 else -- Nkind (Decl) = N_Subprogram_Declaration
2842 if Present
(Corresponding_Body
(Decl
)) then
2843 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2845 -- Imported subprogram case
2851 end Get_Subprogram_Body
;
2853 -----------------------------
2854 -- Get_Task_Body_Procedure --
2855 -----------------------------
2857 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
2859 -- Note: A task type may be the completion of a private type with
2860 -- discriminants. when performing elaboration checks on a task
2861 -- declaration, the current view of the type may be the private one,
2862 -- and the procedure that holds the body of the task is held in its
2865 return Task_Body_Procedure
(Underlying_Type
(Root_Type
(E
)));
2866 end Get_Task_Body_Procedure
;
2868 -----------------------
2869 -- Has_Access_Values --
2870 -----------------------
2872 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
2873 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
2876 -- Case of a private type which is not completed yet. This can only
2877 -- happen in the case of a generic format type appearing directly, or
2878 -- as a component of the type to which this function is being applied
2879 -- at the top level. Return False in this case, since we certainly do
2880 -- not know that the type contains access types.
2885 elsif Is_Access_Type
(Typ
) then
2888 elsif Is_Array_Type
(Typ
) then
2889 return Has_Access_Values
(Component_Type
(Typ
));
2891 elsif Is_Record_Type
(Typ
) then
2896 Comp
:= First_Entity
(Typ
);
2897 while Present
(Comp
) loop
2898 if (Ekind
(Comp
) = E_Component
2900 Ekind
(Comp
) = E_Discriminant
)
2901 and then Has_Access_Values
(Etype
(Comp
))
2915 end Has_Access_Values
;
2917 ----------------------
2918 -- Has_Declarations --
2919 ----------------------
2921 function Has_Declarations
(N
: Node_Id
) return Boolean is
2922 K
: constant Node_Kind
:= Nkind
(N
);
2924 return K
= N_Accept_Statement
2925 or else K
= N_Block_Statement
2926 or else K
= N_Compilation_Unit_Aux
2927 or else K
= N_Entry_Body
2928 or else K
= N_Package_Body
2929 or else K
= N_Protected_Body
2930 or else K
= N_Subprogram_Body
2931 or else K
= N_Task_Body
2932 or else K
= N_Package_Specification
;
2933 end Has_Declarations
;
2935 -------------------------------------------
2936 -- Has_Discriminant_Dependent_Constraint --
2937 -------------------------------------------
2939 function Has_Discriminant_Dependent_Constraint
2940 (Comp
: Entity_Id
) return Boolean
2942 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
2943 Subt_Indic
: constant Node_Id
:=
2944 Subtype_Indication
(Component_Definition
(Comp_Decl
));
2949 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
2950 Constr
:= Constraint
(Subt_Indic
);
2952 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
2953 Assn
:= First
(Constraints
(Constr
));
2954 while Present
(Assn
) loop
2955 case Nkind
(Assn
) is
2956 when N_Subtype_Indication |
2960 if Depends_On_Discriminant
(Assn
) then
2964 when N_Discriminant_Association
=>
2965 if Depends_On_Discriminant
(Expression
(Assn
)) then
2980 end Has_Discriminant_Dependent_Constraint
;
2982 --------------------
2983 -- Has_Infinities --
2984 --------------------
2986 function Has_Infinities
(E
: Entity_Id
) return Boolean is
2989 Is_Floating_Point_Type
(E
)
2990 and then Nkind
(Scalar_Range
(E
)) = N_Range
2991 and then Includes_Infinities
(Scalar_Range
(E
));
2994 ------------------------
2995 -- Has_Null_Extension --
2996 ------------------------
2998 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
2999 B
: constant Entity_Id
:= Base_Type
(T
);
3004 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
3005 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
3007 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
3009 if Present
(Ext
) then
3010 if Null_Present
(Ext
) then
3013 Comps
:= Component_List
(Ext
);
3015 -- The null component list is rewritten during analysis to
3016 -- include the parent component. Any other component indicates
3017 -- that the extension was not originally null.
3019 return Null_Present
(Comps
)
3020 or else No
(Next
(First
(Component_Items
(Comps
))));
3029 end Has_Null_Extension
;
3031 ---------------------------
3032 -- Has_Private_Component --
3033 ---------------------------
3035 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
3036 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
3037 Component
: Entity_Id
;
3040 if Error_Posted
(Type_Id
)
3041 or else Error_Posted
(Btype
)
3046 if Is_Class_Wide_Type
(Btype
) then
3047 Btype
:= Root_Type
(Btype
);
3050 if Is_Private_Type
(Btype
) then
3052 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
3056 if No
(Full_View
(Btype
)) then
3057 return not Is_Generic_Type
(Btype
)
3058 and then not Is_Generic_Type
(Root_Type
(Btype
));
3061 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
3065 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
3068 elsif Is_Array_Type
(Btype
) then
3069 return Has_Private_Component
(Component_Type
(Btype
));
3071 elsif Is_Record_Type
(Btype
) then
3073 Component
:= First_Component
(Btype
);
3074 while Present
(Component
) loop
3076 if Has_Private_Component
(Etype
(Component
)) then
3080 Next_Component
(Component
);
3085 elsif Is_Protected_Type
(Btype
)
3086 and then Present
(Corresponding_Record_Type
(Btype
))
3088 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
3093 end Has_Private_Component
;
3099 function Has_Stream
(T
: Entity_Id
) return Boolean is
3106 elsif Is_RTE
(Root_Type
(T
), RE_Root_Stream_Type
) then
3109 elsif Is_Array_Type
(T
) then
3110 return Has_Stream
(Component_Type
(T
));
3112 elsif Is_Record_Type
(T
) then
3113 E
:= First_Component
(T
);
3114 while Present
(E
) loop
3115 if Has_Stream
(Etype
(E
)) then
3124 elsif Is_Private_Type
(T
) then
3125 return Has_Stream
(Underlying_Type
(T
));
3132 --------------------------
3133 -- Has_Tagged_Component --
3134 --------------------------
3136 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
3140 if Is_Private_Type
(Typ
)
3141 and then Present
(Underlying_Type
(Typ
))
3143 return Has_Tagged_Component
(Underlying_Type
(Typ
));
3145 elsif Is_Array_Type
(Typ
) then
3146 return Has_Tagged_Component
(Component_Type
(Typ
));
3148 elsif Is_Tagged_Type
(Typ
) then
3151 elsif Is_Record_Type
(Typ
) then
3152 Comp
:= First_Component
(Typ
);
3154 while Present
(Comp
) loop
3155 if Has_Tagged_Component
(Etype
(Comp
)) then
3159 Comp
:= Next_Component
(Typ
);
3167 end Has_Tagged_Component
;
3173 function In_Instance
return Boolean is
3174 S
: Entity_Id
:= Current_Scope
;
3178 and then S
/= Standard_Standard
3180 if (Ekind
(S
) = E_Function
3181 or else Ekind
(S
) = E_Package
3182 or else Ekind
(S
) = E_Procedure
)
3183 and then Is_Generic_Instance
(S
)
3194 ----------------------
3195 -- In_Instance_Body --
3196 ----------------------
3198 function In_Instance_Body
return Boolean is
3199 S
: Entity_Id
:= Current_Scope
;
3203 and then S
/= Standard_Standard
3205 if (Ekind
(S
) = E_Function
3206 or else Ekind
(S
) = E_Procedure
)
3207 and then Is_Generic_Instance
(S
)
3211 elsif Ekind
(S
) = E_Package
3212 and then In_Package_Body
(S
)
3213 and then Is_Generic_Instance
(S
)
3222 end In_Instance_Body
;
3224 -----------------------------
3225 -- In_Instance_Not_Visible --
3226 -----------------------------
3228 function In_Instance_Not_Visible
return Boolean is
3229 S
: Entity_Id
:= Current_Scope
;
3233 and then S
/= Standard_Standard
3235 if (Ekind
(S
) = E_Function
3236 or else Ekind
(S
) = E_Procedure
)
3237 and then Is_Generic_Instance
(S
)
3241 elsif Ekind
(S
) = E_Package
3242 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
3243 and then Is_Generic_Instance
(S
)
3252 end In_Instance_Not_Visible
;
3254 ------------------------------
3255 -- In_Instance_Visible_Part --
3256 ------------------------------
3258 function In_Instance_Visible_Part
return Boolean is
3259 S
: Entity_Id
:= Current_Scope
;
3263 and then S
/= Standard_Standard
3265 if Ekind
(S
) = E_Package
3266 and then Is_Generic_Instance
(S
)
3267 and then not In_Package_Body
(S
)
3268 and then not In_Private_Part
(S
)
3277 end In_Instance_Visible_Part
;
3279 ----------------------
3280 -- In_Packiage_Body --
3281 ----------------------
3283 function In_Package_Body
return Boolean is
3284 S
: Entity_Id
:= Current_Scope
;
3288 and then S
/= Standard_Standard
3290 if Ekind
(S
) = E_Package
3291 and then In_Package_Body
(S
)
3300 end In_Package_Body
;
3302 --------------------------------------
3303 -- In_Subprogram_Or_Concurrent_Unit --
3304 --------------------------------------
3306 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
3311 -- Use scope chain to check successively outer scopes
3317 if K
in Subprogram_Kind
3318 or else K
in Concurrent_Kind
3319 or else K
in Generic_Subprogram_Kind
3323 elsif E
= Standard_Standard
then
3329 end In_Subprogram_Or_Concurrent_Unit
;
3331 ---------------------
3332 -- In_Visible_Part --
3333 ---------------------
3335 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
3338 Is_Package_Or_Generic_Package
(Scope_Id
)
3339 and then In_Open_Scopes
(Scope_Id
)
3340 and then not In_Package_Body
(Scope_Id
)
3341 and then not In_Private_Part
(Scope_Id
);
3342 end In_Visible_Part
;
3344 ---------------------------------
3345 -- Insert_Explicit_Dereference --
3346 ---------------------------------
3348 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
3349 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
3350 Ent
: Entity_Id
:= Empty
;
3357 Save_Interps
(N
, New_Prefix
);
3359 Make_Explicit_Dereference
(Sloc
(N
), Prefix
=> New_Prefix
));
3361 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
3363 if Is_Overloaded
(New_Prefix
) then
3365 -- The deference is also overloaded, and its interpretations are the
3366 -- designated types of the interpretations of the original node.
3368 Set_Etype
(N
, Any_Type
);
3369 Get_First_Interp
(New_Prefix
, I
, It
);
3371 while Present
(It
.Nam
) loop
3374 if Is_Access_Type
(T
) then
3375 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
3378 Get_Next_Interp
(I
, It
);
3384 -- Prefix is unambiguous: mark the original prefix (which might
3385 -- Come_From_Source) as a reference, since the new (relocated) one
3386 -- won't be taken into account.
3388 if Is_Entity_Name
(New_Prefix
) then
3389 Ent
:= Entity
(New_Prefix
);
3391 -- For a retrieval of a subcomponent of some composite object,
3392 -- retrieve the ultimate entity if there is one.
3394 elsif Nkind
(New_Prefix
) = N_Selected_Component
3395 or else Nkind
(New_Prefix
) = N_Indexed_Component
3397 Pref
:= Prefix
(New_Prefix
);
3399 while Present
(Pref
)
3401 (Nkind
(Pref
) = N_Selected_Component
3402 or else Nkind
(Pref
) = N_Indexed_Component
)
3404 Pref
:= Prefix
(Pref
);
3407 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
3408 Ent
:= Entity
(Pref
);
3412 if Present
(Ent
) then
3413 Generate_Reference
(Ent
, New_Prefix
);
3416 end Insert_Explicit_Dereference
;
3422 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
3424 pragma Assert
(Is_Type
(E
));
3426 return AAMP_On_Target
3427 and then Is_Floating_Point_Type
(E
)
3428 and then E
= Base_Type
(E
);
3431 -------------------------
3432 -- Is_Actual_Parameter --
3433 -------------------------
3435 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
3436 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3440 when N_Parameter_Association
=>
3441 return N
= Explicit_Actual_Parameter
(Parent
(N
));
3443 when N_Function_Call | N_Procedure_Call_Statement
=>
3444 return Is_List_Member
(N
)
3446 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
3451 end Is_Actual_Parameter
;
3453 ---------------------
3454 -- Is_Aliased_View --
3455 ---------------------
3457 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
3461 if Is_Entity_Name
(Obj
) then
3469 or else (Present
(Renamed_Object
(E
))
3470 and then Is_Aliased_View
(Renamed_Object
(E
)))))
3472 or else ((Is_Formal
(E
)
3473 or else Ekind
(E
) = E_Generic_In_Out_Parameter
3474 or else Ekind
(E
) = E_Generic_In_Parameter
)
3475 and then Is_Tagged_Type
(Etype
(E
)))
3477 or else ((Ekind
(E
) = E_Task_Type
3478 or else Ekind
(E
) = E_Protected_Type
)
3479 and then In_Open_Scopes
(E
))
3481 -- Current instance of type
3483 or else (Is_Type
(E
) and then E
= Current_Scope
)
3484 or else (Is_Incomplete_Or_Private_Type
(E
)
3485 and then Full_View
(E
) = Current_Scope
);
3487 elsif Nkind
(Obj
) = N_Selected_Component
then
3488 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
3490 elsif Nkind
(Obj
) = N_Indexed_Component
then
3491 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
3493 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
3495 Has_Aliased_Components
3496 (Designated_Type
(Etype
(Prefix
(Obj
)))));
3498 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
3499 or else Nkind
(Obj
) = N_Type_Conversion
3501 return Is_Tagged_Type
(Etype
(Obj
))
3502 and then Is_Aliased_View
(Expression
(Obj
));
3504 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
3505 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
3510 end Is_Aliased_View
;
3512 -------------------------
3513 -- Is_Ancestor_Package --
3514 -------------------------
3516 function Is_Ancestor_Package
3518 E2
: Entity_Id
) return Boolean
3525 and then Par
/= Standard_Standard
3535 end Is_Ancestor_Package
;
3537 ----------------------
3538 -- Is_Atomic_Object --
3539 ----------------------
3541 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
3543 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
3544 -- Determines if given object has atomic components
3546 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
3547 -- If prefix is an implicit dereference, examine designated type
3549 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
3551 if Is_Access_Type
(Etype
(N
)) then
3553 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
3555 return Object_Has_Atomic_Components
(N
);
3557 end Is_Atomic_Prefix
;
3559 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
3561 if Has_Atomic_Components
(Etype
(N
))
3562 or else Is_Atomic
(Etype
(N
))
3566 elsif Is_Entity_Name
(N
)
3567 and then (Has_Atomic_Components
(Entity
(N
))
3568 or else Is_Atomic
(Entity
(N
)))
3572 elsif Nkind
(N
) = N_Indexed_Component
3573 or else Nkind
(N
) = N_Selected_Component
3575 return Is_Atomic_Prefix
(Prefix
(N
));
3580 end Object_Has_Atomic_Components
;
3582 -- Start of processing for Is_Atomic_Object
3585 if Is_Atomic
(Etype
(N
))
3586 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
3590 elsif Nkind
(N
) = N_Indexed_Component
3591 or else Nkind
(N
) = N_Selected_Component
3593 return Is_Atomic_Prefix
(Prefix
(N
));
3598 end Is_Atomic_Object
;
3600 --------------------------------------
3601 -- Is_Controlling_Limited_Procedure --
3602 --------------------------------------
3604 function Is_Controlling_Limited_Procedure
3605 (Proc_Nam
: Entity_Id
) return Boolean
3607 Param_Typ
: Entity_Id
:= Empty
;
3610 if Ekind
(Proc_Nam
) = E_Procedure
3611 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
3613 Param_Typ
:= Etype
(Parameter_Type
(First
(
3614 Parameter_Specifications
(Parent
(Proc_Nam
)))));
3616 -- In this case where an Itype was created, the procedure call has been
3619 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
3620 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
3622 Present
(Parameter_Associations
3623 (Associated_Node_For_Itype
(Proc_Nam
)))
3626 Etype
(First
(Parameter_Associations
3627 (Associated_Node_For_Itype
(Proc_Nam
))));
3630 if Present
(Param_Typ
) then
3632 Is_Interface
(Param_Typ
)
3633 and then Is_Limited_Record
(Param_Typ
);
3637 end Is_Controlling_Limited_Procedure
;
3639 ----------------------------------------------
3640 -- Is_Dependent_Component_Of_Mutable_Object --
3641 ----------------------------------------------
3643 function Is_Dependent_Component_Of_Mutable_Object
3644 (Object
: Node_Id
) return Boolean
3647 Prefix_Type
: Entity_Id
;
3648 P_Aliased
: Boolean := False;
3651 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
3652 -- Returns True if and only if Comp is declared within a variant part
3654 --------------------------------
3655 -- Is_Declared_Within_Variant --
3656 --------------------------------
3658 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
3659 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
3660 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
3662 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
3663 end Is_Declared_Within_Variant
;
3665 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
3668 if Is_Variable
(Object
) then
3670 if Nkind
(Object
) = N_Selected_Component
then
3671 P
:= Prefix
(Object
);
3672 Prefix_Type
:= Etype
(P
);
3674 if Is_Entity_Name
(P
) then
3676 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
3677 Prefix_Type
:= Base_Type
(Prefix_Type
);
3680 if Is_Aliased
(Entity
(P
)) then
3684 -- A discriminant check on a selected component may be
3685 -- expanded into a dereference when removing side-effects.
3686 -- Recover the original node and its type, which may be
3689 elsif Nkind
(P
) = N_Explicit_Dereference
3690 and then not (Comes_From_Source
(P
))
3692 P
:= Original_Node
(P
);
3693 Prefix_Type
:= Etype
(P
);
3696 -- Check for prefix being an aliased component ???
3701 -- A heap object is constrained by its initial value
3703 -- Ada 2005 AI-363:if the designated type is a type with a
3704 -- constrained partial view, the resulting heap object is not
3705 -- constrained, and a renaming of the component is now unsafe.
3707 if Is_Access_Type
(Prefix_Type
)
3709 not Has_Constrained_Partial_View
3710 (Designated_Type
(Prefix_Type
))
3714 elsif Nkind
(P
) = N_Explicit_Dereference
3715 and then not Has_Constrained_Partial_View
(Prefix_Type
)
3721 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
3723 -- As per AI-0017, the renaming is illegal in a generic body,
3724 -- even if the subtype is indefinite.
3726 if not Is_Constrained
(Prefix_Type
)
3727 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
3729 (Is_Generic_Type
(Prefix_Type
)
3730 and then Ekind
(Current_Scope
) = E_Generic_Package
3731 and then In_Package_Body
(Current_Scope
)))
3733 and then (Is_Declared_Within_Variant
(Comp
)
3734 or else Has_Discriminant_Dependent_Constraint
(Comp
))
3735 and then not P_Aliased
3741 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3745 elsif Nkind
(Object
) = N_Indexed_Component
3746 or else Nkind
(Object
) = N_Slice
3748 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3750 -- A type conversion that Is_Variable is a view conversion:
3751 -- go back to the denoted object.
3753 elsif Nkind
(Object
) = N_Type_Conversion
then
3755 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
3760 end Is_Dependent_Component_Of_Mutable_Object
;
3762 ---------------------
3763 -- Is_Dereferenced --
3764 ---------------------
3766 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
3767 P
: constant Node_Id
:= Parent
(N
);
3770 (Nkind
(P
) = N_Selected_Component
3772 Nkind
(P
) = N_Explicit_Dereference
3774 Nkind
(P
) = N_Indexed_Component
3776 Nkind
(P
) = N_Slice
)
3777 and then Prefix
(P
) = N
;
3778 end Is_Dereferenced
;
3780 ----------------------
3781 -- Is_Descendent_Of --
3782 ----------------------
3784 function Is_Descendent_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
3789 pragma Assert
(Nkind
(T1
) in N_Entity
);
3790 pragma Assert
(Nkind
(T2
) in N_Entity
);
3792 T
:= Base_Type
(T1
);
3794 -- Immediate return if the types match
3799 -- Comment needed here ???
3801 elsif Ekind
(T
) = E_Class_Wide_Type
then
3802 return Etype
(T
) = T2
;
3810 -- Done if we found the type we are looking for
3815 -- Done if no more derivations to check
3822 -- Following test catches error cases resulting from prev errors
3824 elsif No
(Etyp
) then
3827 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
3830 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
3834 T
:= Base_Type
(Etyp
);
3838 raise Program_Error
;
3839 end Is_Descendent_Of
;
3841 ------------------------------
3842 -- Is_Descendent_Of_Address --
3843 ------------------------------
3845 function Is_Descendent_Of_Address
(T1
: Entity_Id
) return Boolean is
3847 -- If Address has not been loaded, answer must be False
3849 if not RTU_Loaded
(System
) then
3852 -- Otherwise we can get the entity we are interested in without
3853 -- causing an unwanted dependency on System, and do the test.
3856 return Is_Descendent_Of
(T1
, Base_Type
(RTE
(RE_Address
)));
3858 end Is_Descendent_Of_Address
;
3864 function Is_False
(U
: Uint
) return Boolean is
3869 ---------------------------
3870 -- Is_Fixed_Model_Number --
3871 ---------------------------
3873 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
3874 S
: constant Ureal
:= Small_Value
(T
);
3875 M
: Urealp
.Save_Mark
;
3879 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
3882 end Is_Fixed_Model_Number
;
3884 -------------------------------
3885 -- Is_Fully_Initialized_Type --
3886 -------------------------------
3888 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
3890 if Is_Scalar_Type
(Typ
) then
3893 elsif Is_Access_Type
(Typ
) then
3896 elsif Is_Array_Type
(Typ
) then
3897 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
3901 -- An interesting case, if we have a constrained type one of whose
3902 -- bounds is known to be null, then there are no elements to be
3903 -- initialized, so all the elements are initialized!
3905 if Is_Constrained
(Typ
) then
3908 Indx_Typ
: Entity_Id
;
3912 Indx
:= First_Index
(Typ
);
3913 while Present
(Indx
) loop
3915 if Etype
(Indx
) = Any_Type
then
3918 -- If index is a range, use directly
3920 elsif Nkind
(Indx
) = N_Range
then
3921 Lbd
:= Low_Bound
(Indx
);
3922 Hbd
:= High_Bound
(Indx
);
3925 Indx_Typ
:= Etype
(Indx
);
3927 if Is_Private_Type
(Indx_Typ
) then
3928 Indx_Typ
:= Full_View
(Indx_Typ
);
3931 if No
(Indx_Typ
) then
3934 Lbd
:= Type_Low_Bound
(Indx_Typ
);
3935 Hbd
:= Type_High_Bound
(Indx_Typ
);
3939 if Compile_Time_Known_Value
(Lbd
)
3940 and then Compile_Time_Known_Value
(Hbd
)
3942 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
3952 -- If no null indexes, then type is not fully initialized
3958 elsif Is_Record_Type
(Typ
) then
3959 if Has_Discriminants
(Typ
)
3961 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
3962 and then Is_Fully_Initialized_Variant
(Typ
)
3967 -- Controlled records are considered to be fully initialized if
3968 -- there is a user defined Initialize routine. This may not be
3969 -- entirely correct, but as the spec notes, we are guessing here
3970 -- what is best from the point of view of issuing warnings.
3972 if Is_Controlled
(Typ
) then
3974 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
3977 if Present
(Utyp
) then
3979 Init
: constant Entity_Id
:=
3981 (Underlying_Type
(Typ
), Name_Initialize
));
3985 and then Comes_From_Source
(Init
)
3987 Is_Predefined_File_Name
3988 (File_Name
(Get_Source_File_Index
(Sloc
(Init
))))
3992 elsif Has_Null_Extension
(Typ
)
3994 Is_Fully_Initialized_Type
3995 (Etype
(Base_Type
(Typ
)))
4004 -- Otherwise see if all record components are initialized
4010 Ent
:= First_Entity
(Typ
);
4012 while Present
(Ent
) loop
4013 if Chars
(Ent
) = Name_uController
then
4016 elsif Ekind
(Ent
) = E_Component
4017 and then (No
(Parent
(Ent
))
4018 or else No
(Expression
(Parent
(Ent
))))
4019 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
4028 -- No uninitialized components, so type is fully initialized.
4029 -- Note that this catches the case of no components as well.
4033 elsif Is_Concurrent_Type
(Typ
) then
4036 elsif Is_Private_Type
(Typ
) then
4038 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4044 return Is_Fully_Initialized_Type
(U
);
4051 end Is_Fully_Initialized_Type
;
4053 ----------------------------------
4054 -- Is_Fully_Initialized_Variant --
4055 ----------------------------------
4057 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
4058 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
4059 Constraints
: constant List_Id
:= New_List
;
4060 Components
: constant Elist_Id
:= New_Elmt_List
;
4061 Comp_Elmt
: Elmt_Id
;
4063 Comp_List
: Node_Id
;
4065 Discr_Val
: Node_Id
;
4066 Report_Errors
: Boolean;
4069 if Serious_Errors_Detected
> 0 then
4073 if Is_Record_Type
(Typ
)
4074 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
4075 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
4077 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
4078 Discr
:= First_Discriminant
(Typ
);
4080 while Present
(Discr
) loop
4081 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
4082 Discr_Val
:= Expression
(Parent
(Discr
));
4084 if Present
(Discr_Val
)
4085 and then Is_OK_Static_Expression
(Discr_Val
)
4087 Append_To
(Constraints
,
4088 Make_Component_Association
(Loc
,
4089 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
4090 Expression
=> New_Copy
(Discr_Val
)));
4098 Next_Discriminant
(Discr
);
4103 Comp_List
=> Comp_List
,
4104 Governed_By
=> Constraints
,
4106 Report_Errors
=> Report_Errors
);
4108 -- Check that each component present is fully initialized
4110 Comp_Elmt
:= First_Elmt
(Components
);
4112 while Present
(Comp_Elmt
) loop
4113 Comp_Id
:= Node
(Comp_Elmt
);
4115 if Ekind
(Comp_Id
) = E_Component
4116 and then (No
(Parent
(Comp_Id
))
4117 or else No
(Expression
(Parent
(Comp_Id
))))
4118 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
4123 Next_Elmt
(Comp_Elmt
);
4128 elsif Is_Private_Type
(Typ
) then
4130 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4136 return Is_Fully_Initialized_Variant
(U
);
4142 end Is_Fully_Initialized_Variant
;
4144 ----------------------------
4145 -- Is_Inherited_Operation --
4146 ----------------------------
4148 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
4149 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
4151 pragma Assert
(Is_Overloadable
(E
));
4152 return Kind
= N_Full_Type_Declaration
4153 or else Kind
= N_Private_Extension_Declaration
4154 or else Kind
= N_Subtype_Declaration
4155 or else (Ekind
(E
) = E_Enumeration_Literal
4156 and then Is_Derived_Type
(Etype
(E
)));
4157 end Is_Inherited_Operation
;
4159 -----------------------------
4160 -- Is_Library_Level_Entity --
4161 -----------------------------
4163 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
4165 -- The following is a small optimization, and it also handles
4166 -- properly discriminals, which in task bodies might appear in
4167 -- expressions before the corresponding procedure has been
4168 -- created, and which therefore do not have an assigned scope.
4170 if Ekind
(E
) in Formal_Kind
then
4174 -- Normal test is simply that the enclosing dynamic scope is Standard
4176 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
4177 end Is_Library_Level_Entity
;
4179 ---------------------------------
4180 -- Is_Local_Variable_Reference --
4181 ---------------------------------
4183 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
4185 if not Is_Entity_Name
(Expr
) then
4190 Ent
: constant Entity_Id
:= Entity
(Expr
);
4191 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
4193 if Ekind
(Ent
) /= E_Variable
4195 Ekind
(Ent
) /= E_In_Out_Parameter
4199 return Present
(Sub
) and then Sub
= Current_Subprogram
;
4203 end Is_Local_Variable_Reference
;
4209 function Is_Lvalue
(N
: Node_Id
) return Boolean is
4210 P
: constant Node_Id
:= Parent
(N
);
4215 -- Test left side of assignment
4217 when N_Assignment_Statement
=>
4218 return N
= Name
(P
);
4220 -- Test prefix of component or attribute
4222 when N_Attribute_Reference |
4224 N_Explicit_Dereference |
4225 N_Indexed_Component |
4227 N_Selected_Component |
4229 return N
= Prefix
(P
);
4231 -- Test subprogram parameter (we really should check the
4232 -- parameter mode, but it is not worth the trouble)
4234 when N_Function_Call |
4235 N_Procedure_Call_Statement |
4236 N_Accept_Statement |
4237 N_Parameter_Association
=>
4240 -- Test for appearing in a conversion that itself appears
4241 -- in an lvalue context, since this should be an lvalue.
4243 when N_Type_Conversion
=>
4244 return Is_Lvalue
(P
);
4246 -- Test for appearence in object renaming declaration
4248 when N_Object_Renaming_Declaration
=>
4251 -- All other references are definitely not Lvalues
4259 -------------------------
4260 -- Is_Object_Reference --
4261 -------------------------
4263 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
4265 if Is_Entity_Name
(N
) then
4266 return Is_Object
(Entity
(N
));
4270 when N_Indexed_Component | N_Slice
=>
4272 Is_Object_Reference
(Prefix
(N
))
4273 or else Is_Access_Type
(Etype
(Prefix
(N
)));
4275 -- In Ada95, a function call is a constant object; a procedure
4278 when N_Function_Call
=>
4279 return Etype
(N
) /= Standard_Void_Type
;
4281 -- A reference to the stream attribute Input is a function call
4283 when N_Attribute_Reference
=>
4284 return Attribute_Name
(N
) = Name_Input
;
4286 when N_Selected_Component
=>
4288 Is_Object_Reference
(Selector_Name
(N
))
4290 (Is_Object_Reference
(Prefix
(N
))
4291 or else Is_Access_Type
(Etype
(Prefix
(N
))));
4293 when N_Explicit_Dereference
=>
4296 -- A view conversion of a tagged object is an object reference
4298 when N_Type_Conversion
=>
4299 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
4300 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
4301 and then Is_Object_Reference
(Expression
(N
));
4303 -- An unchecked type conversion is considered to be an object if
4304 -- the operand is an object (this construction arises only as a
4305 -- result of expansion activities).
4307 when N_Unchecked_Type_Conversion
=>
4314 end Is_Object_Reference
;
4316 -----------------------------------
4317 -- Is_OK_Variable_For_Out_Formal --
4318 -----------------------------------
4320 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
4322 Note_Possible_Modification
(AV
);
4324 -- We must reject parenthesized variable names. The check for
4325 -- Comes_From_Source is present because there are currently
4326 -- cases where the compiler violates this rule (e.g. passing
4327 -- a task object to its controlled Initialize routine).
4329 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
4332 -- A variable is always allowed
4334 elsif Is_Variable
(AV
) then
4337 -- Unchecked conversions are allowed only if they come from the
4338 -- generated code, which sometimes uses unchecked conversions for out
4339 -- parameters in cases where code generation is unaffected. We tell
4340 -- source unchecked conversions by seeing if they are rewrites of an
4341 -- original Unchecked_Conversion function call, or of an explicit
4342 -- conversion of a function call.
4344 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
4345 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
4348 elsif Comes_From_Source
(AV
)
4349 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
4353 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
4354 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
4360 -- Normal type conversions are allowed if argument is a variable
4362 elsif Nkind
(AV
) = N_Type_Conversion
then
4363 if Is_Variable
(Expression
(AV
))
4364 and then Paren_Count
(Expression
(AV
)) = 0
4366 Note_Possible_Modification
(Expression
(AV
));
4369 -- We also allow a non-parenthesized expression that raises
4370 -- constraint error if it rewrites what used to be a variable
4372 elsif Raises_Constraint_Error
(Expression
(AV
))
4373 and then Paren_Count
(Expression
(AV
)) = 0
4374 and then Is_Variable
(Original_Node
(Expression
(AV
)))
4378 -- Type conversion of something other than a variable
4384 -- If this node is rewritten, then test the original form, if that is
4385 -- OK, then we consider the rewritten node OK (for example, if the
4386 -- original node is a conversion, then Is_Variable will not be true
4387 -- but we still want to allow the conversion if it converts a variable).
4389 elsif Original_Node
(AV
) /= AV
then
4390 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
4392 -- All other non-variables are rejected
4397 end Is_OK_Variable_For_Out_Formal
;
4399 -----------------------------------
4400 -- Is_Partially_Initialized_Type --
4401 -----------------------------------
4403 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
4405 if Is_Scalar_Type
(Typ
) then
4408 elsif Is_Access_Type
(Typ
) then
4411 elsif Is_Array_Type
(Typ
) then
4413 -- If component type is partially initialized, so is array type
4415 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
4418 -- Otherwise we are only partially initialized if we are fully
4419 -- initialized (this is the empty array case, no point in us
4420 -- duplicating that code here).
4423 return Is_Fully_Initialized_Type
(Typ
);
4426 elsif Is_Record_Type
(Typ
) then
4428 -- A discriminated type is always partially initialized
4430 if Has_Discriminants
(Typ
) then
4433 -- A tagged type is always partially initialized
4435 elsif Is_Tagged_Type
(Typ
) then
4438 -- Case of non-discriminated record
4444 Component_Present
: Boolean := False;
4445 -- Set True if at least one component is present. If no
4446 -- components are present, then record type is fully
4447 -- initialized (another odd case, like the null array).
4450 -- Loop through components
4452 Ent
:= First_Entity
(Typ
);
4453 while Present
(Ent
) loop
4454 if Ekind
(Ent
) = E_Component
then
4455 Component_Present
:= True;
4457 -- If a component has an initialization expression then
4458 -- the enclosing record type is partially initialized
4460 if Present
(Parent
(Ent
))
4461 and then Present
(Expression
(Parent
(Ent
)))
4465 -- If a component is of a type which is itself partially
4466 -- initialized, then the enclosing record type is also.
4468 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
4476 -- No initialized components found. If we found any components
4477 -- they were all uninitialized so the result is false.
4479 if Component_Present
then
4482 -- But if we found no components, then all the components are
4483 -- initialized so we consider the type to be initialized.
4491 -- Concurrent types are always fully initialized
4493 elsif Is_Concurrent_Type
(Typ
) then
4496 -- For a private type, go to underlying type. If there is no underlying
4497 -- type then just assume this partially initialized. Not clear if this
4498 -- can happen in a non-error case, but no harm in testing for this.
4500 elsif Is_Private_Type
(Typ
) then
4502 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
4507 return Is_Partially_Initialized_Type
(U
);
4511 -- For any other type (are there any?) assume partially initialized
4516 end Is_Partially_Initialized_Type
;
4518 ------------------------------------
4519 -- Is_Potentially_Persistent_Type --
4520 ------------------------------------
4522 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
4527 -- For private type, test corrresponding full type
4529 if Is_Private_Type
(T
) then
4530 return Is_Potentially_Persistent_Type
(Full_View
(T
));
4532 -- Scalar types are potentially persistent
4534 elsif Is_Scalar_Type
(T
) then
4537 -- Record type is potentially persistent if not tagged and the types of
4538 -- all it components are potentially persistent, and no component has
4539 -- an initialization expression.
4541 elsif Is_Record_Type
(T
)
4542 and then not Is_Tagged_Type
(T
)
4543 and then not Is_Partially_Initialized_Type
(T
)
4545 Comp
:= First_Component
(T
);
4546 while Present
(Comp
) loop
4547 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
4556 -- Array type is potentially persistent if its component type is
4557 -- potentially persistent and if all its constraints are static.
4559 elsif Is_Array_Type
(T
) then
4560 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
4564 Indx
:= First_Index
(T
);
4565 while Present
(Indx
) loop
4566 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
4575 -- All other types are not potentially persistent
4580 end Is_Potentially_Persistent_Type
;
4582 -----------------------------
4583 -- Is_RCI_Pkg_Spec_Or_Body --
4584 -----------------------------
4586 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
4588 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
4589 -- Return True if the unit of Cunit is an RCI package declaration
4591 ---------------------------
4592 -- Is_RCI_Pkg_Decl_Cunit --
4593 ---------------------------
4595 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
4596 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
4599 if Nkind
(The_Unit
) /= N_Package_Declaration
then
4603 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
4604 end Is_RCI_Pkg_Decl_Cunit
;
4606 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
4609 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
4611 (Nkind
(Unit
(Cunit
)) = N_Package_Body
4612 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
4613 end Is_RCI_Pkg_Spec_Or_Body
;
4615 -----------------------------------------
4616 -- Is_Remote_Access_To_Class_Wide_Type --
4617 -----------------------------------------
4619 function Is_Remote_Access_To_Class_Wide_Type
4620 (E
: Entity_Id
) return Boolean
4624 function Comes_From_Limited_Private_Type_Declaration
4625 (E
: Entity_Id
) return Boolean;
4626 -- Check that the type is declared by a limited type declaration,
4627 -- or else is derived from a Remote_Type ancestor through private
4630 -------------------------------------------------
4631 -- Comes_From_Limited_Private_Type_Declaration --
4632 -------------------------------------------------
4634 function Comes_From_Limited_Private_Type_Declaration
4635 (E
: Entity_Id
) return Boolean
4637 N
: constant Node_Id
:= Declaration_Node
(E
);
4640 if Nkind
(N
) = N_Private_Type_Declaration
4641 and then Limited_Present
(N
)
4646 if Nkind
(N
) = N_Private_Extension_Declaration
then
4648 Comes_From_Limited_Private_Type_Declaration
(Etype
(E
))
4650 (Is_Remote_Types
(Etype
(E
))
4651 and then Is_Limited_Record
(Etype
(E
))
4652 and then Has_Private_Declaration
(Etype
(E
)));
4656 end Comes_From_Limited_Private_Type_Declaration
;
4658 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
4661 if not (Is_Remote_Call_Interface
(E
)
4662 or else Is_Remote_Types
(E
))
4663 or else Ekind
(E
) /= E_General_Access_Type
4668 D
:= Designated_Type
(E
);
4670 if Ekind
(D
) /= E_Class_Wide_Type
then
4674 return Comes_From_Limited_Private_Type_Declaration
4675 (Defining_Identifier
(Parent
(D
)));
4676 end Is_Remote_Access_To_Class_Wide_Type
;
4678 -----------------------------------------
4679 -- Is_Remote_Access_To_Subprogram_Type --
4680 -----------------------------------------
4682 function Is_Remote_Access_To_Subprogram_Type
4683 (E
: Entity_Id
) return Boolean
4686 return (Ekind
(E
) = E_Access_Subprogram_Type
4687 or else (Ekind
(E
) = E_Record_Type
4688 and then Present
(Corresponding_Remote_Type
(E
))))
4689 and then (Is_Remote_Call_Interface
(E
)
4690 or else Is_Remote_Types
(E
));
4691 end Is_Remote_Access_To_Subprogram_Type
;
4693 --------------------
4694 -- Is_Remote_Call --
4695 --------------------
4697 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
4699 if Nkind
(N
) /= N_Procedure_Call_Statement
4700 and then Nkind
(N
) /= N_Function_Call
4702 -- An entry call cannot be remote
4706 elsif Nkind
(Name
(N
)) in N_Has_Entity
4707 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
4709 -- A subprogram declared in the spec of a RCI package is remote
4713 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
4714 and then Is_Remote_Access_To_Subprogram_Type
4715 (Etype
(Prefix
(Name
(N
))))
4717 -- The dereference of a RAS is a remote call
4721 elsif Present
(Controlling_Argument
(N
))
4722 and then Is_Remote_Access_To_Class_Wide_Type
4723 (Etype
(Controlling_Argument
(N
)))
4725 -- Any primitive operation call with a controlling argument of
4726 -- a RACW type is a remote call.
4731 -- All other calls are local calls
4736 ----------------------
4737 -- Is_Renamed_Entry --
4738 ----------------------
4740 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
4741 Orig_Node
: Node_Id
:= Empty
;
4742 Subp_Decl
: Node_Id
:= Parent
(Parent
(Proc_Nam
));
4744 function Is_Entry
(Nam
: Node_Id
) return Boolean;
4745 -- Determine whether Nam is an entry. Traverse selectors
4746 -- if there are nested selected components.
4752 function Is_Entry
(Nam
: Node_Id
) return Boolean is
4754 if Nkind
(Nam
) = N_Selected_Component
then
4755 return Is_Entry
(Selector_Name
(Nam
));
4758 return Ekind
(Entity
(Nam
)) = E_Entry
;
4761 -- Start of processing for Is_Renamed_Entry
4764 if Present
(Alias
(Proc_Nam
)) then
4765 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
4768 -- Look for a rewritten subprogram renaming declaration
4770 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
4771 and then Present
(Original_Node
(Subp_Decl
))
4773 Orig_Node
:= Original_Node
(Subp_Decl
);
4776 -- The rewritten subprogram is actually an entry
4778 if Present
(Orig_Node
)
4779 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
4780 and then Is_Entry
(Name
(Orig_Node
))
4786 end Is_Renamed_Entry
;
4788 ----------------------
4789 -- Is_Selector_Name --
4790 ----------------------
4792 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
4794 if not Is_List_Member
(N
) then
4796 P
: constant Node_Id
:= Parent
(N
);
4797 K
: constant Node_Kind
:= Nkind
(P
);
4800 (K
= N_Expanded_Name
or else
4801 K
= N_Generic_Association
or else
4802 K
= N_Parameter_Association
or else
4803 K
= N_Selected_Component
)
4804 and then Selector_Name
(P
) = N
;
4809 L
: constant List_Id
:= List_Containing
(N
);
4810 P
: constant Node_Id
:= Parent
(L
);
4812 return (Nkind
(P
) = N_Discriminant_Association
4813 and then Selector_Names
(P
) = L
)
4815 (Nkind
(P
) = N_Component_Association
4816 and then Choices
(P
) = L
);
4819 end Is_Selector_Name
;
4825 function Is_Statement
(N
: Node_Id
) return Boolean is
4828 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
4829 or else Nkind
(N
) = N_Procedure_Call_Statement
;
4836 function Is_Transfer
(N
: Node_Id
) return Boolean is
4837 Kind
: constant Node_Kind
:= Nkind
(N
);
4840 if Kind
= N_Return_Statement
4842 Kind
= N_Goto_Statement
4844 Kind
= N_Raise_Statement
4846 Kind
= N_Requeue_Statement
4850 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
4851 and then No
(Condition
(N
))
4855 elsif Kind
= N_Procedure_Call_Statement
4856 and then Is_Entity_Name
(Name
(N
))
4857 and then Present
(Entity
(Name
(N
)))
4858 and then No_Return
(Entity
(Name
(N
)))
4862 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
4874 function Is_True
(U
: Uint
) return Boolean is
4883 function Is_Variable
(N
: Node_Id
) return Boolean is
4885 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
4886 -- We do the test on the original node, since this is basically a
4887 -- test of syntactic categories, so it must not be disturbed by
4888 -- whatever rewriting might have occurred. For example, an aggregate,
4889 -- which is certainly NOT a variable, could be turned into a variable
4892 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
4893 -- Within a protected function, the private components of the
4894 -- enclosing protected type are constants. A function nested within
4895 -- a (protected) procedure is not itself protected.
4897 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
4898 -- Prefixes can involve implicit dereferences, in which case we
4899 -- must test for the case of a reference of a constant access
4900 -- type, which can never be a variable.
4902 ---------------------------
4903 -- In_Protected_Function --
4904 ---------------------------
4906 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
4907 Prot
: constant Entity_Id
:= Scope
(E
);
4911 if not Is_Protected_Type
(Prot
) then
4915 while Present
(S
) and then S
/= Prot
loop
4916 if Ekind
(S
) = E_Function
4917 and then Scope
(S
) = Prot
4927 end In_Protected_Function
;
4929 ------------------------
4930 -- Is_Variable_Prefix --
4931 ------------------------
4933 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
4935 if Is_Access_Type
(Etype
(P
)) then
4936 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
4938 -- For the case of an indexed component whose prefix has a packed
4939 -- array type, the prefix has been rewritten into a type conversion.
4940 -- Determine variable-ness from the converted expression.
4942 elsif Nkind
(P
) = N_Type_Conversion
4943 and then not Comes_From_Source
(P
)
4944 and then Is_Array_Type
(Etype
(P
))
4945 and then Is_Packed
(Etype
(P
))
4947 return Is_Variable
(Expression
(P
));
4950 return Is_Variable
(P
);
4952 end Is_Variable_Prefix
;
4954 -- Start of processing for Is_Variable
4957 -- Definitely OK if Assignment_OK is set. Since this is something that
4958 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
4960 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
4963 -- Normally we go to the original node, but there is one exception
4964 -- where we use the rewritten node, namely when it is an explicit
4965 -- dereference. The generated code may rewrite a prefix which is an
4966 -- access type with an explicit dereference. The dereference is a
4967 -- variable, even though the original node may not be (since it could
4968 -- be a constant of the access type).
4970 elsif Nkind
(N
) = N_Explicit_Dereference
4971 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
4972 and then Is_Access_Type
(Etype
(Orig_Node
))
4974 return Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
4976 -- A function call is never a variable
4978 elsif Nkind
(N
) = N_Function_Call
then
4981 -- All remaining checks use the original node
4983 elsif Is_Entity_Name
(Orig_Node
) then
4985 E
: constant Entity_Id
:= Entity
(Orig_Node
);
4986 K
: constant Entity_Kind
:= Ekind
(E
);
4989 return (K
= E_Variable
4990 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
4991 or else (K
= E_Component
4992 and then not In_Protected_Function
(E
))
4993 or else K
= E_Out_Parameter
4994 or else K
= E_In_Out_Parameter
4995 or else K
= E_Generic_In_Out_Parameter
4997 -- Current instance of type:
4999 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
5000 or else (Is_Incomplete_Or_Private_Type
(E
)
5001 and then In_Open_Scopes
(Full_View
(E
)));
5005 case Nkind
(Orig_Node
) is
5006 when N_Indexed_Component | N_Slice
=>
5007 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
5009 when N_Selected_Component
=>
5010 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
5011 and then Is_Variable
(Selector_Name
(Orig_Node
));
5013 -- For an explicit dereference, the type of the prefix cannot
5014 -- be an access to constant or an access to subprogram.
5016 when N_Explicit_Dereference
=>
5018 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
5020 return Is_Access_Type
(Typ
)
5021 and then not Is_Access_Constant
(Root_Type
(Typ
))
5022 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
5025 -- The type conversion is the case where we do not deal with the
5026 -- context dependent special case of an actual parameter. Thus
5027 -- the type conversion is only considered a variable for the
5028 -- purposes of this routine if the target type is tagged. However,
5029 -- a type conversion is considered to be a variable if it does not
5030 -- come from source (this deals for example with the conversions
5031 -- of expressions to their actual subtypes).
5033 when N_Type_Conversion
=>
5034 return Is_Variable
(Expression
(Orig_Node
))
5036 (not Comes_From_Source
(Orig_Node
)
5038 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
5040 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
5042 -- GNAT allows an unchecked type conversion as a variable. This
5043 -- only affects the generation of internal expanded code, since
5044 -- calls to instantiations of Unchecked_Conversion are never
5045 -- considered variables (since they are function calls).
5046 -- This is also true for expression actions.
5048 when N_Unchecked_Type_Conversion
=>
5049 return Is_Variable
(Expression
(Orig_Node
));
5057 ------------------------
5058 -- Is_Volatile_Object --
5059 ------------------------
5061 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
5063 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
5064 -- Determines if given object has volatile components
5066 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
5067 -- If prefix is an implicit dereference, examine designated type
5069 ------------------------
5070 -- Is_Volatile_Prefix --
5071 ------------------------
5073 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
5074 Typ
: constant Entity_Id
:= Etype
(N
);
5077 if Is_Access_Type
(Typ
) then
5079 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
5082 return Is_Volatile
(Dtyp
)
5083 or else Has_Volatile_Components
(Dtyp
);
5087 return Object_Has_Volatile_Components
(N
);
5089 end Is_Volatile_Prefix
;
5091 ------------------------------------
5092 -- Object_Has_Volatile_Components --
5093 ------------------------------------
5095 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
5096 Typ
: constant Entity_Id
:= Etype
(N
);
5099 if Is_Volatile
(Typ
)
5100 or else Has_Volatile_Components
(Typ
)
5104 elsif Is_Entity_Name
(N
)
5105 and then (Has_Volatile_Components
(Entity
(N
))
5106 or else Is_Volatile
(Entity
(N
)))
5110 elsif Nkind
(N
) = N_Indexed_Component
5111 or else Nkind
(N
) = N_Selected_Component
5113 return Is_Volatile_Prefix
(Prefix
(N
));
5118 end Object_Has_Volatile_Components
;
5120 -- Start of processing for Is_Volatile_Object
5123 if Is_Volatile
(Etype
(N
))
5124 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
5128 elsif Nkind
(N
) = N_Indexed_Component
5129 or else Nkind
(N
) = N_Selected_Component
5131 return Is_Volatile_Prefix
(Prefix
(N
));
5136 end Is_Volatile_Object
;
5138 -------------------------
5139 -- Kill_Current_Values --
5140 -------------------------
5142 procedure Kill_Current_Values
(Ent
: Entity_Id
) is
5144 if Is_Object
(Ent
) then
5146 Set_Current_Value
(Ent
, Empty
);
5148 if not Can_Never_Be_Null
(Ent
) then
5149 Set_Is_Known_Non_Null
(Ent
, False);
5152 Set_Is_Known_Null
(Ent
, False);
5154 end Kill_Current_Values
;
5156 procedure Kill_Current_Values
is
5159 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
5160 -- Clear current value for entity E and all entities chained to E
5162 ------------------------------------------
5163 -- Kill_Current_Values_For_Entity_Chain --
5164 ------------------------------------------
5166 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
5170 while Present
(Ent
) loop
5171 Kill_Current_Values
(Ent
);
5174 end Kill_Current_Values_For_Entity_Chain
;
5176 -- Start of processing for Kill_Current_Values
5179 -- Kill all saved checks, a special case of killing saved values
5183 -- Loop through relevant scopes, which includes the current scope and
5184 -- any parent scopes if the current scope is a block or a package.
5189 -- Clear current values of all entities in current scope
5191 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
5193 -- If scope is a package, also clear current values of all
5194 -- private entities in the scope.
5196 if Ekind
(S
) = E_Package
5198 Ekind
(S
) = E_Generic_Package
5200 Is_Concurrent_Type
(S
)
5202 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
5205 -- If this is a block or nested package, deal with parent
5207 if Ekind
(S
) = E_Block
5208 or else (Ekind
(S
) = E_Package
5209 and then not Is_Library_Level_Entity
(S
))
5215 end loop Scope_Loop
;
5216 end Kill_Current_Values
;
5218 --------------------------
5219 -- Kill_Size_Check_Code --
5220 --------------------------
5222 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
5224 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
5225 and then Present
(Size_Check_Code
(E
))
5227 Remove
(Size_Check_Code
(E
));
5228 Set_Size_Check_Code
(E
, Empty
);
5230 end Kill_Size_Check_Code
;
5232 -------------------------
5233 -- New_External_Entity --
5234 -------------------------
5236 function New_External_Entity
5237 (Kind
: Entity_Kind
;
5238 Scope_Id
: Entity_Id
;
5239 Sloc_Value
: Source_Ptr
;
5240 Related_Id
: Entity_Id
;
5242 Suffix_Index
: Nat
:= 0;
5243 Prefix
: Character := ' ') return Entity_Id
5245 N
: constant Entity_Id
:=
5246 Make_Defining_Identifier
(Sloc_Value
,
5248 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
5251 Set_Ekind
(N
, Kind
);
5252 Set_Is_Internal
(N
, True);
5253 Append_Entity
(N
, Scope_Id
);
5254 Set_Public_Status
(N
);
5256 if Kind
in Type_Kind
then
5257 Init_Size_Align
(N
);
5261 end New_External_Entity
;
5263 -------------------------
5264 -- New_Internal_Entity --
5265 -------------------------
5267 function New_Internal_Entity
5268 (Kind
: Entity_Kind
;
5269 Scope_Id
: Entity_Id
;
5270 Sloc_Value
: Source_Ptr
;
5271 Id_Char
: Character) return Entity_Id
5273 N
: constant Entity_Id
:=
5274 Make_Defining_Identifier
(Sloc_Value
, New_Internal_Name
(Id_Char
));
5277 Set_Ekind
(N
, Kind
);
5278 Set_Is_Internal
(N
, True);
5279 Append_Entity
(N
, Scope_Id
);
5281 if Kind
in Type_Kind
then
5282 Init_Size_Align
(N
);
5286 end New_Internal_Entity
;
5292 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
5296 -- If we are pointing at a positional parameter, it is a member of
5297 -- a node list (the list of parameters), and the next parameter
5298 -- is the next node on the list, unless we hit a parameter
5299 -- association, in which case we shift to using the chain whose
5300 -- head is the First_Named_Actual in the parent, and then is
5301 -- threaded using the Next_Named_Actual of the Parameter_Association.
5302 -- All this fiddling is because the original node list is in the
5303 -- textual call order, and what we need is the declaration order.
5305 if Is_List_Member
(Actual_Id
) then
5306 N
:= Next
(Actual_Id
);
5308 if Nkind
(N
) = N_Parameter_Association
then
5309 return First_Named_Actual
(Parent
(Actual_Id
));
5315 return Next_Named_Actual
(Parent
(Actual_Id
));
5319 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
5321 Actual_Id
:= Next_Actual
(Actual_Id
);
5324 -----------------------
5325 -- Normalize_Actuals --
5326 -----------------------
5328 -- Chain actuals according to formals of subprogram. If there are no named
5329 -- associations, the chain is simply the list of Parameter Associations,
5330 -- since the order is the same as the declaration order. If there are named
5331 -- associations, then the First_Named_Actual field in the N_Function_Call
5332 -- or N_Procedure_Call_Statement node points to the Parameter_Association
5333 -- node for the parameter that comes first in declaration order. The
5334 -- remaining named parameters are then chained in declaration order using
5335 -- Next_Named_Actual.
5337 -- This routine also verifies that the number of actuals is compatible with
5338 -- the number and default values of formals, but performs no type checking
5339 -- (type checking is done by the caller).
5341 -- If the matching succeeds, Success is set to True and the caller proceeds
5342 -- with type-checking. If the match is unsuccessful, then Success is set to
5343 -- False, and the caller attempts a different interpretation, if there is
5346 -- If the flag Report is on, the call is not overloaded, and a failure to
5347 -- match can be reported here, rather than in the caller.
5349 procedure Normalize_Actuals
5353 Success
: out Boolean)
5355 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
5356 Actual
: Node_Id
:= Empty
;
5358 Last
: Node_Id
:= Empty
;
5359 First_Named
: Node_Id
:= Empty
;
5362 Formals_To_Match
: Integer := 0;
5363 Actuals_To_Match
: Integer := 0;
5365 procedure Chain
(A
: Node_Id
);
5366 -- Add named actual at the proper place in the list, using the
5367 -- Next_Named_Actual link.
5369 function Reporting
return Boolean;
5370 -- Determines if an error is to be reported. To report an error, we
5371 -- need Report to be True, and also we do not report errors caused
5372 -- by calls to init procs that occur within other init procs. Such
5373 -- errors must always be cascaded errors, since if all the types are
5374 -- declared correctly, the compiler will certainly build decent calls!
5380 procedure Chain
(A
: Node_Id
) is
5384 -- Call node points to first actual in list
5386 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
5389 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
5393 Set_Next_Named_Actual
(Last
, Empty
);
5400 function Reporting
return Boolean is
5405 elsif not Within_Init_Proc
then
5408 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
5416 -- Start of processing for Normalize_Actuals
5419 if Is_Access_Type
(S
) then
5421 -- The name in the call is a function call that returns an access
5422 -- to subprogram. The designated type has the list of formals.
5424 Formal
:= First_Formal
(Designated_Type
(S
));
5426 Formal
:= First_Formal
(S
);
5429 while Present
(Formal
) loop
5430 Formals_To_Match
:= Formals_To_Match
+ 1;
5431 Next_Formal
(Formal
);
5434 -- Find if there is a named association, and verify that no positional
5435 -- associations appear after named ones.
5437 if Present
(Actuals
) then
5438 Actual
:= First
(Actuals
);
5441 while Present
(Actual
)
5442 and then Nkind
(Actual
) /= N_Parameter_Association
5444 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5448 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
5450 -- Most common case: positional notation, no defaults
5455 elsif Actuals_To_Match
> Formals_To_Match
then
5457 -- Too many actuals: will not work
5460 if Is_Entity_Name
(Name
(N
)) then
5461 Error_Msg_N
("too many arguments in call to&", Name
(N
));
5463 Error_Msg_N
("too many arguments in call", N
);
5471 First_Named
:= Actual
;
5473 while Present
(Actual
) loop
5474 if Nkind
(Actual
) /= N_Parameter_Association
then
5476 ("positional parameters not allowed after named ones", Actual
);
5481 Actuals_To_Match
:= Actuals_To_Match
+ 1;
5487 if Present
(Actuals
) then
5488 Actual
:= First
(Actuals
);
5491 Formal
:= First_Formal
(S
);
5492 while Present
(Formal
) loop
5494 -- Match the formals in order. If the corresponding actual
5495 -- is positional, nothing to do. Else scan the list of named
5496 -- actuals to find the one with the right name.
5499 and then Nkind
(Actual
) /= N_Parameter_Association
5502 Actuals_To_Match
:= Actuals_To_Match
- 1;
5503 Formals_To_Match
:= Formals_To_Match
- 1;
5506 -- For named parameters, search the list of actuals to find
5507 -- one that matches the next formal name.
5509 Actual
:= First_Named
;
5512 while Present
(Actual
) loop
5513 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
5516 Actuals_To_Match
:= Actuals_To_Match
- 1;
5517 Formals_To_Match
:= Formals_To_Match
- 1;
5525 if Ekind
(Formal
) /= E_In_Parameter
5526 or else No
(Default_Value
(Formal
))
5529 if (Comes_From_Source
(S
)
5530 or else Sloc
(S
) = Standard_Location
)
5531 and then Is_Overloadable
(S
)
5535 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
5537 (Nkind
(Parent
(N
)) = N_Function_Call
5539 Nkind
(Parent
(N
)) = N_Parameter_Association
))
5540 and then Ekind
(S
) /= E_Function
5542 Set_Etype
(N
, Etype
(S
));
5544 Error_Msg_Name_1
:= Chars
(S
);
5545 Error_Msg_Sloc
:= Sloc
(S
);
5547 ("missing argument for parameter & " &
5548 "in call to % declared #", N
, Formal
);
5551 elsif Is_Overloadable
(S
) then
5552 Error_Msg_Name_1
:= Chars
(S
);
5554 -- Point to type derivation that generated the
5557 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
5560 ("missing argument for parameter & " &
5561 "in call to % (inherited) #", N
, Formal
);
5565 ("missing argument for parameter &", N
, Formal
);
5573 Formals_To_Match
:= Formals_To_Match
- 1;
5578 Next_Formal
(Formal
);
5581 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
5588 -- Find some superfluous named actual that did not get
5589 -- attached to the list of associations.
5591 Actual
:= First
(Actuals
);
5593 while Present
(Actual
) loop
5594 if Nkind
(Actual
) = N_Parameter_Association
5595 and then Actual
/= Last
5596 and then No
(Next_Named_Actual
(Actual
))
5598 Error_Msg_N
("unmatched actual & in call",
5599 Selector_Name
(Actual
));
5610 end Normalize_Actuals
;
5612 --------------------------------
5613 -- Note_Possible_Modification --
5614 --------------------------------
5616 procedure Note_Possible_Modification
(N
: Node_Id
) is
5617 Modification_Comes_From_Source
: constant Boolean :=
5618 Comes_From_Source
(Parent
(N
));
5624 -- Loop to find referenced entity, if there is one
5631 if Is_Entity_Name
(Exp
) then
5632 Ent
:= Entity
(Exp
);
5634 -- If the entity is missing, it is an undeclared identifier,
5635 -- and there is nothing to annotate.
5641 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
5643 P
: constant Node_Id
:= Prefix
(Exp
);
5646 if Nkind
(P
) = N_Selected_Component
5648 Entry_Formal
(Entity
(Selector_Name
(P
))))
5650 -- Case of a reference to an entry formal
5652 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
5654 elsif Nkind
(P
) = N_Identifier
5655 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
5656 and then Present
(Expression
(Parent
(Entity
(P
))))
5657 and then Nkind
(Expression
(Parent
(Entity
(P
))))
5660 -- Case of a reference to a value on which
5661 -- side effects have been removed.
5663 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
5672 elsif Nkind
(Exp
) = N_Type_Conversion
5673 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
5675 Exp
:= Expression
(Exp
);
5678 elsif Nkind
(Exp
) = N_Slice
5679 or else Nkind
(Exp
) = N_Indexed_Component
5680 or else Nkind
(Exp
) = N_Selected_Component
5682 Exp
:= Prefix
(Exp
);
5689 -- Now look for entity being referenced
5691 if Present
(Ent
) then
5692 if Is_Object
(Ent
) then
5693 if Comes_From_Source
(Exp
)
5694 or else Modification_Comes_From_Source
5696 Set_Never_Set_In_Source
(Ent
, False);
5699 Set_Is_True_Constant
(Ent
, False);
5700 Set_Current_Value
(Ent
, Empty
);
5701 Set_Is_Known_Null
(Ent
, False);
5703 if not Can_Never_Be_Null
(Ent
) then
5704 Set_Is_Known_Non_Null
(Ent
, False);
5707 -- Follow renaming chain
5709 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
5710 and then Present
(Renamed_Object
(Ent
))
5712 Exp
:= Renamed_Object
(Ent
);
5716 -- Generate a reference only if the assignment comes from
5717 -- source. This excludes, for example, calls to a dispatching
5718 -- assignment operation when the left-hand side is tagged.
5720 if Modification_Comes_From_Source
then
5721 Generate_Reference
(Ent
, Exp
, 'm');
5729 end Note_Possible_Modification
;
5731 -------------------------
5732 -- Object_Access_Level --
5733 -------------------------
5735 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
5738 -- Returns the static accessibility level of the view denoted
5739 -- by Obj. Note that the value returned is the result of a
5740 -- call to Scope_Depth. Only scope depths associated with
5741 -- dynamic scopes can actually be returned. Since only
5742 -- relative levels matter for accessibility checking, the fact
5743 -- that the distance between successive levels of accessibility
5744 -- is not always one is immaterial (invariant: if level(E2) is
5745 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
5748 if Is_Entity_Name
(Obj
) then
5751 -- If E is a type then it denotes a current instance.
5752 -- For this case we add one to the normal accessibility
5753 -- level of the type to ensure that current instances
5754 -- are treated as always being deeper than than the level
5755 -- of any visible named access type (see 3.10.2(21)).
5758 return Type_Access_Level
(E
) + 1;
5760 elsif Present
(Renamed_Object
(E
)) then
5761 return Object_Access_Level
(Renamed_Object
(E
));
5763 -- Similarly, if E is a component of the current instance of a
5764 -- protected type, any instance of it is assumed to be at a deeper
5765 -- level than the type. For a protected object (whose type is an
5766 -- anonymous protected type) its components are at the same level
5767 -- as the type itself.
5769 elsif not Is_Overloadable
(E
)
5770 and then Ekind
(Scope
(E
)) = E_Protected_Type
5771 and then Comes_From_Source
(Scope
(E
))
5773 return Type_Access_Level
(Scope
(E
)) + 1;
5776 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
5779 elsif Nkind
(Obj
) = N_Selected_Component
then
5780 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5781 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5783 return Object_Access_Level
(Prefix
(Obj
));
5786 elsif Nkind
(Obj
) = N_Indexed_Component
then
5787 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
5788 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5790 return Object_Access_Level
(Prefix
(Obj
));
5793 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
5795 -- If the prefix is a selected access discriminant then
5796 -- we make a recursive call on the prefix, which will
5797 -- in turn check the level of the prefix object of
5798 -- the selected discriminant.
5800 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
5801 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
5803 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
5805 return Object_Access_Level
(Prefix
(Obj
));
5807 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
5810 elsif Nkind
(Obj
) = N_Type_Conversion
5811 or else Nkind
(Obj
) = N_Unchecked_Type_Conversion
5813 return Object_Access_Level
(Expression
(Obj
));
5815 -- Function results are objects, so we get either the access level
5816 -- of the function or, in the case of an indirect call, the level of
5817 -- of the access-to-subprogram type.
5819 elsif Nkind
(Obj
) = N_Function_Call
then
5820 if Is_Entity_Name
(Name
(Obj
)) then
5821 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
5823 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
5826 -- For convenience we handle qualified expressions, even though
5827 -- they aren't technically object names.
5829 elsif Nkind
(Obj
) = N_Qualified_Expression
then
5830 return Object_Access_Level
(Expression
(Obj
));
5832 -- Otherwise return the scope level of Standard.
5833 -- (If there are cases that fall through
5834 -- to this point they will be treated as
5835 -- having global accessibility for now. ???)
5838 return Scope_Depth
(Standard_Standard
);
5840 end Object_Access_Level
;
5842 -----------------------
5843 -- Private_Component --
5844 -----------------------
5846 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
5847 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
5849 function Trace_Components
5851 Check
: Boolean) return Entity_Id
;
5852 -- Recursive function that does the work, and checks against circular
5853 -- definition for each subcomponent type.
5855 ----------------------
5856 -- Trace_Components --
5857 ----------------------
5859 function Trace_Components
5861 Check
: Boolean) return Entity_Id
5863 Btype
: constant Entity_Id
:= Base_Type
(T
);
5864 Component
: Entity_Id
;
5866 Candidate
: Entity_Id
:= Empty
;
5869 if Check
and then Btype
= Ancestor
then
5870 Error_Msg_N
("circular type definition", Type_Id
);
5874 if Is_Private_Type
(Btype
)
5875 and then not Is_Generic_Type
(Btype
)
5877 if Present
(Full_View
(Btype
))
5878 and then Is_Record_Type
(Full_View
(Btype
))
5879 and then not Is_Frozen
(Btype
)
5881 -- To indicate that the ancestor depends on a private type,
5882 -- the current Btype is sufficient. However, to check for
5883 -- circular definition we must recurse on the full view.
5885 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
5887 if Candidate
= Any_Type
then
5897 elsif Is_Array_Type
(Btype
) then
5898 return Trace_Components
(Component_Type
(Btype
), True);
5900 elsif Is_Record_Type
(Btype
) then
5901 Component
:= First_Entity
(Btype
);
5902 while Present
(Component
) loop
5904 -- Skip anonymous types generated by constrained components
5906 if not Is_Type
(Component
) then
5907 P
:= Trace_Components
(Etype
(Component
), True);
5910 if P
= Any_Type
then
5918 Next_Entity
(Component
);
5926 end Trace_Components
;
5928 -- Start of processing for Private_Component
5931 return Trace_Components
(Type_Id
, False);
5932 end Private_Component
;
5934 -----------------------
5935 -- Process_End_Label --
5936 -----------------------
5938 procedure Process_End_Label
5946 Label_Ref
: Boolean;
5947 -- Set True if reference to end label itself is required
5950 -- Gets set to the operator symbol or identifier that references
5951 -- the entity Ent. For the child unit case, this is the identifier
5952 -- from the designator. For other cases, this is simply Endl.
5954 procedure Generate_Parent_Ref
(N
: Node_Id
);
5955 -- N is an identifier node that appears as a parent unit reference
5956 -- in the case where Ent is a child unit. This procedure generates
5957 -- an appropriate cross-reference entry.
5959 -------------------------
5960 -- Generate_Parent_Ref --
5961 -------------------------
5963 procedure Generate_Parent_Ref
(N
: Node_Id
) is
5964 Parent_Ent
: Entity_Id
;
5967 -- Search up scope stack. The reason we do this is that normal
5968 -- visibility analysis would not work for two reasons. First in
5969 -- some subunit cases, the entry for the parent unit may not be
5970 -- visible, and in any case there can be a local entity that
5971 -- hides the scope entity.
5973 Parent_Ent
:= Current_Scope
;
5974 while Present
(Parent_Ent
) loop
5975 if Chars
(Parent_Ent
) = Chars
(N
) then
5977 -- Generate the reference. We do NOT consider this as a
5978 -- reference for unreferenced symbol purposes, but we do
5979 -- force a cross-reference even if the end line does not
5980 -- come from source (the caller already generated the
5981 -- appropriate Typ for this situation).
5984 (Parent_Ent
, N
, 'r', Set_Ref
=> False, Force
=> True);
5985 Style
.Check_Identifier
(N
, Parent_Ent
);
5989 Parent_Ent
:= Scope
(Parent_Ent
);
5992 -- Fall through means entity was not found -- that's odd, but
5993 -- the appropriate thing is simply to ignore and not generate
5994 -- any cross-reference for this entry.
5997 end Generate_Parent_Ref
;
5999 -- Start of processing for Process_End_Label
6002 -- If no node, ignore. This happens in some error situations,
6003 -- and also for some internally generated structures where no
6004 -- end label references are required in any case.
6010 -- Nothing to do if no End_Label, happens for internally generated
6011 -- constructs where we don't want an end label reference anyway.
6012 -- Also nothing to do if Endl is a string literal, which means
6013 -- there was some prior error (bad operator symbol)
6015 Endl
:= End_Label
(N
);
6017 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
6021 -- Reference node is not in extended main source unit
6023 if not In_Extended_Main_Source_Unit
(N
) then
6025 -- Generally we do not collect references except for the
6026 -- extended main source unit. The one exception is the 'e'
6027 -- entry for a package spec, where it is useful for a client
6028 -- to have the ending information to define scopes.
6036 -- For this case, we can ignore any parent references,
6037 -- but we need the package name itself for the 'e' entry.
6039 if Nkind
(Endl
) = N_Designator
then
6040 Endl
:= Identifier
(Endl
);
6044 -- Reference is in extended main source unit
6049 -- For designator, generate references for the parent entries
6051 if Nkind
(Endl
) = N_Designator
then
6053 -- Generate references for the prefix if the END line comes
6054 -- from source (otherwise we do not need these references)
6056 if Comes_From_Source
(Endl
) then
6058 while Nkind
(Nam
) = N_Selected_Component
loop
6059 Generate_Parent_Ref
(Selector_Name
(Nam
));
6060 Nam
:= Prefix
(Nam
);
6063 Generate_Parent_Ref
(Nam
);
6066 Endl
:= Identifier
(Endl
);
6070 -- If the end label is not for the given entity, then either we have
6071 -- some previous error, or this is a generic instantiation for which
6072 -- we do not need to make a cross-reference in this case anyway. In
6073 -- either case we simply ignore the call.
6075 if Chars
(Ent
) /= Chars
(Endl
) then
6079 -- If label was really there, then generate a normal reference
6080 -- and then adjust the location in the end label to point past
6081 -- the name (which should almost always be the semicolon).
6085 if Comes_From_Source
(Endl
) then
6087 -- If a label reference is required, then do the style check
6088 -- and generate an l-type cross-reference entry for the label
6092 Style
.Check_Identifier
(Endl
, Ent
);
6094 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
6097 -- Set the location to point past the label (normally this will
6098 -- mean the semicolon immediately following the label). This is
6099 -- done for the sake of the 'e' or 't' entry generated below.
6101 Get_Decoded_Name_String
(Chars
(Endl
));
6102 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
6105 -- Now generate the e/t reference
6107 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
6109 -- Restore Sloc, in case modified above, since we have an identifier
6110 -- and the normal Sloc should be left set in the tree.
6112 Set_Sloc
(Endl
, Loc
);
6113 end Process_End_Label
;
6119 -- We do the conversion to get the value of the real string by using
6120 -- the scanner, see Sinput for details on use of the internal source
6121 -- buffer for scanning internal strings.
6123 function Real_Convert
(S
: String) return Node_Id
is
6124 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
6128 Source
:= Internal_Source_Ptr
;
6131 for J
in S
'Range loop
6132 Source
(Source_Ptr
(J
)) := S
(J
);
6135 Source
(S
'Length + 1) := EOF
;
6137 if Source
(Scan_Ptr
) = '-' then
6139 Scan_Ptr
:= Scan_Ptr
+ 1;
6147 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
6154 ---------------------
6155 -- Rep_To_Pos_Flag --
6156 ---------------------
6158 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
6160 return New_Occurrence_Of
6161 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
6162 end Rep_To_Pos_Flag
;
6164 --------------------
6165 -- Require_Entity --
6166 --------------------
6168 procedure Require_Entity
(N
: Node_Id
) is
6170 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
6171 if Total_Errors_Detected
/= 0 then
6172 Set_Entity
(N
, Any_Id
);
6174 raise Program_Error
;
6179 ------------------------------
6180 -- Requires_Transient_Scope --
6181 ------------------------------
6183 -- A transient scope is required when variable-sized temporaries are
6184 -- allocated in the primary or secondary stack, or when finalization
6185 -- actions must be generated before the next instruction.
6187 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
6188 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
6190 -- Start of processing for Requires_Transient_Scope
6193 -- This is a private type which is not completed yet. This can only
6194 -- happen in a default expression (of a formal parameter or of a
6195 -- record component). Do not expand transient scope in this case
6200 -- Do not expand transient scope for non-existent procedure return
6202 elsif Typ
= Standard_Void_Type
then
6205 -- Elementary types do not require a transient scope
6207 elsif Is_Elementary_Type
(Typ
) then
6210 -- Generally, indefinite subtypes require a transient scope, since the
6211 -- back end cannot generate temporaries, since this is not a valid type
6212 -- for declaring an object. It might be possible to relax this in the
6213 -- future, e.g. by declaring the maximum possible space for the type.
6215 elsif Is_Indefinite_Subtype
(Typ
) then
6218 -- Functions returning tagged types may dispatch on result so their
6219 -- returned value is allocated on the secondary stack. Controlled
6220 -- type temporaries need finalization.
6222 elsif Is_Tagged_Type
(Typ
)
6223 or else Has_Controlled_Component
(Typ
)
6229 elsif Is_Record_Type
(Typ
) then
6231 -- In GCC 2, discriminated records always require a transient
6232 -- scope because the back end otherwise tries to allocate a
6233 -- variable length temporary for the particular variant.
6235 if Opt
.GCC_Version
= 2
6236 and then Has_Discriminants
(Typ
)
6240 -- For GCC 3, or for a non-discriminated record in GCC 2, we are
6241 -- OK if none of the component types requires a transient scope.
6242 -- Note that we already know that this is a definite type (i.e.
6243 -- has discriminant defaults if it is a discriminated record).
6249 Comp
:= First_Entity
(Typ
);
6250 while Present
(Comp
) loop
6251 if Ekind
(Comp
) = E_Component
6252 and then Requires_Transient_Scope
(Etype
(Comp
))
6264 -- String literal types never require transient scope
6266 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
6269 -- Array type. Note that we already know that this is a constrained
6270 -- array, since unconstrained arrays will fail the indefinite test.
6272 elsif Is_Array_Type
(Typ
) then
6274 -- If component type requires a transient scope, the array does too
6276 if Requires_Transient_Scope
(Component_Type
(Typ
)) then
6279 -- Otherwise, we only need a transient scope if the size is not
6280 -- known at compile time.
6283 return not Size_Known_At_Compile_Time
(Typ
);
6286 -- All other cases do not require a transient scope
6291 end Requires_Transient_Scope
;
6293 --------------------------
6294 -- Reset_Analyzed_Flags --
6295 --------------------------
6297 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
6299 function Clear_Analyzed
6300 (N
: Node_Id
) return Traverse_Result
;
6301 -- Function used to reset Analyzed flags in tree. Note that we do
6302 -- not reset Analyzed flags in entities, since there is no need to
6303 -- renalalyze entities, and indeed, it is wrong to do so, since it
6304 -- can result in generating auxiliary stuff more than once.
6306 --------------------
6307 -- Clear_Analyzed --
6308 --------------------
6310 function Clear_Analyzed
6311 (N
: Node_Id
) return Traverse_Result
6314 if not Has_Extension
(N
) then
6315 Set_Analyzed
(N
, False);
6321 function Reset_Analyzed
is
6322 new Traverse_Func
(Clear_Analyzed
);
6324 Discard
: Traverse_Result
;
6325 pragma Warnings
(Off
, Discard
);
6327 -- Start of processing for Reset_Analyzed_Flags
6330 Discard
:= Reset_Analyzed
(N
);
6331 end Reset_Analyzed_Flags
;
6333 ---------------------------
6334 -- Safe_To_Capture_Value --
6335 ---------------------------
6337 function Safe_To_Capture_Value
6339 Ent
: Entity_Id
) return Boolean
6342 -- The only entities for which we track constant values are variables,
6343 -- out parameters and in out parameters, so check if we have this case.
6345 if Ekind
(Ent
) /= E_Variable
6347 Ekind
(Ent
) /= E_Out_Parameter
6349 Ekind
(Ent
) /= E_In_Out_Parameter
6354 -- Skip volatile and aliased variables, since funny things might
6355 -- be going on in these cases which we cannot necessarily track.
6356 -- Also skip any variable for which an address clause is given.
6358 -- Should we have a flag Has_Address_Clause ???
6360 if Treat_As_Volatile
(Ent
)
6361 or else Is_Aliased
(Ent
)
6362 or else Present
(Address_Clause
(Ent
))
6367 -- OK, all above conditions are met. We also require that the scope
6368 -- of the reference be the same as the scope of the entity, not
6369 -- counting packages and blocks.
6372 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
6373 R_Scope
: Entity_Id
;
6376 R_Scope
:= Current_Scope
;
6377 while R_Scope
/= Standard_Standard
loop
6378 exit when R_Scope
= E_Scope
;
6380 if Ekind
(R_Scope
) /= E_Package
6382 Ekind
(R_Scope
) /= E_Block
6386 R_Scope
:= Scope
(R_Scope
);
6391 -- We also require that the reference does not appear in a context
6392 -- where it is not sure to be executed (i.e. a conditional context
6393 -- or an exception handler).
6402 while Present
(P
) loop
6403 if Nkind
(P
) = N_If_Statement
6404 or else Nkind
(P
) = N_Case_Statement
6405 or else (Nkind
(P
) = N_And_Then
and then Desc
= Right_Opnd
(P
))
6406 or else (Nkind
(P
) = N_Or_Else
and then Desc
= Right_Opnd
(P
))
6407 or else Nkind
(P
) = N_Exception_Handler
6408 or else Nkind
(P
) = N_Selective_Accept
6409 or else Nkind
(P
) = N_Conditional_Entry_Call
6410 or else Nkind
(P
) = N_Timed_Entry_Call
6411 or else Nkind
(P
) = N_Asynchronous_Select
6421 -- OK, looks safe to set value
6424 end Safe_To_Capture_Value
;
6430 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
6431 K1
: constant Node_Kind
:= Nkind
(N1
);
6432 K2
: constant Node_Kind
:= Nkind
(N2
);
6435 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
6436 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
6438 return Chars
(N1
) = Chars
(N2
);
6440 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
6441 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
6443 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
6444 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
6455 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
6460 elsif not Is_Constrained
(T1
)
6461 and then not Is_Constrained
(T2
)
6462 and then Base_Type
(T1
) = Base_Type
(T2
)
6466 -- For now don't bother with case of identical constraints, to be
6467 -- fiddled with later on perhaps (this is only used for optimization
6468 -- purposes, so it is not critical to do a best possible job)
6475 ------------------------
6476 -- Scope_Is_Transient --
6477 ------------------------
6479 function Scope_Is_Transient
return Boolean is
6481 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
6482 end Scope_Is_Transient
;
6488 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6493 while Scop
/= Standard_Standard
loop
6494 Scop
:= Scope
(Scop
);
6496 if Scop
= Scope2
then
6504 --------------------------
6505 -- Scope_Within_Or_Same --
6506 --------------------------
6508 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
6513 while Scop
/= Standard_Standard
loop
6514 if Scop
= Scope2
then
6517 Scop
:= Scope
(Scop
);
6522 end Scope_Within_Or_Same
;
6524 ------------------------
6525 -- Set_Current_Entity --
6526 ------------------------
6528 -- The given entity is to be set as the currently visible definition
6529 -- of its associated name (i.e. the Node_Id associated with its name).
6530 -- All we have to do is to get the name from the identifier, and
6531 -- then set the associated Node_Id to point to the given entity.
6533 procedure Set_Current_Entity
(E
: Entity_Id
) is
6535 Set_Name_Entity_Id
(Chars
(E
), E
);
6536 end Set_Current_Entity
;
6538 ---------------------------------
6539 -- Set_Entity_With_Style_Check --
6540 ---------------------------------
6542 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
6543 Val_Actual
: Entity_Id
;
6547 Set_Entity
(N
, Val
);
6550 and then not Suppress_Style_Checks
(Val
)
6551 and then not In_Instance
6553 if Nkind
(N
) = N_Identifier
then
6556 elsif Nkind
(N
) = N_Expanded_Name
then
6557 Nod
:= Selector_Name
(N
);
6563 -- A special situation arises for derived operations, where we want
6564 -- to do the check against the parent (since the Sloc of the derived
6565 -- operation points to the derived type declaration itself).
6568 while not Comes_From_Source
(Val_Actual
)
6569 and then Nkind
(Val_Actual
) in N_Entity
6570 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
6571 or else Is_Subprogram
(Val_Actual
)
6572 or else Is_Generic_Subprogram
(Val_Actual
))
6573 and then Present
(Alias
(Val_Actual
))
6575 Val_Actual
:= Alias
(Val_Actual
);
6578 -- Renaming declarations for generic actuals do not come from source,
6579 -- and have a different name from that of the entity they rename, so
6580 -- there is no style check to perform here.
6582 if Chars
(Nod
) = Chars
(Val_Actual
) then
6583 Style
.Check_Identifier
(Nod
, Val_Actual
);
6587 Set_Entity
(N
, Val
);
6588 end Set_Entity_With_Style_Check
;
6590 ------------------------
6591 -- Set_Name_Entity_Id --
6592 ------------------------
6594 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
6596 Set_Name_Table_Info
(Id
, Int
(Val
));
6597 end Set_Name_Entity_Id
;
6599 ---------------------
6600 -- Set_Next_Actual --
6601 ---------------------
6603 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
6605 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
6606 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
6608 end Set_Next_Actual
;
6610 -----------------------
6611 -- Set_Public_Status --
6612 -----------------------
6614 procedure Set_Public_Status
(Id
: Entity_Id
) is
6615 S
: constant Entity_Id
:= Current_Scope
;
6618 -- Everything in the scope of Standard is public
6620 if S
= Standard_Standard
then
6623 -- Entity is definitely not public if enclosing scope is not public
6625 elsif not Is_Public
(S
) then
6628 -- An object declaration that occurs in a handled sequence of statements
6629 -- is the declaration for a temporary object generated by the expander.
6630 -- It never needs to be made public and furthermore, making it public
6631 -- can cause back end problems if it is of variable size.
6633 elsif Nkind
(Parent
(Id
)) = N_Object_Declaration
6635 Nkind
(Parent
(Parent
(Id
))) = N_Handled_Sequence_Of_Statements
6639 -- Entities in public packages or records are public
6641 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
6644 -- The bounds of an entry family declaration can generate object
6645 -- declarations that are visible to the back-end, e.g. in the
6646 -- the declaration of a composite type that contains tasks.
6648 elsif Is_Concurrent_Type
(S
)
6649 and then not Has_Completion
(S
)
6650 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
6654 end Set_Public_Status
;
6656 ----------------------------
6657 -- Set_Scope_Is_Transient --
6658 ----------------------------
6660 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
6662 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
6663 end Set_Scope_Is_Transient
;
6669 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
6671 -- We copy Esize, but not RM_Size, since in general RM_Size is
6672 -- subtype specific and does not get inherited by all subtypes.
6674 Set_Esize
(T1
, Esize
(T2
));
6675 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
6677 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
6679 Is_Discrete_Or_Fixed_Point_Type
(T2
)
6681 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
6683 Set_Alignment
(T1
, Alignment
(T2
));
6686 --------------------
6687 -- Static_Integer --
6688 --------------------
6690 function Static_Integer
(N
: Node_Id
) return Uint
is
6692 Analyze_And_Resolve
(N
, Any_Integer
);
6695 or else Error_Posted
(N
)
6696 or else Etype
(N
) = Any_Type
6701 if Is_Static_Expression
(N
) then
6702 if not Raises_Constraint_Error
(N
) then
6703 return Expr_Value
(N
);
6708 elsif Etype
(N
) = Any_Type
then
6712 Flag_Non_Static_Expr
6713 ("static integer expression required here", N
);
6718 --------------------------
6719 -- Statically_Different --
6720 --------------------------
6722 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
6723 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
6724 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
6726 return Is_Entity_Name
(R1
)
6727 and then Is_Entity_Name
(R2
)
6728 and then Entity
(R1
) /= Entity
(R2
)
6729 and then not Is_Formal
(Entity
(R1
))
6730 and then not Is_Formal
(Entity
(R2
));
6731 end Statically_Different
;
6733 -----------------------------
6734 -- Subprogram_Access_Level --
6735 -----------------------------
6737 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
6739 if Present
(Alias
(Subp
)) then
6740 return Subprogram_Access_Level
(Alias
(Subp
));
6742 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
6744 end Subprogram_Access_Level
;
6750 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
6752 if Debug_Flag_W
then
6753 for J
in 0 .. Scope_Stack
.Last
loop
6758 Write_Name
(Chars
(E
));
6759 Write_Str
(" line ");
6760 Write_Int
(Int
(Get_Logical_Line_Number
(Sloc
(N
))));
6765 -----------------------
6766 -- Transfer_Entities --
6767 -----------------------
6769 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
6770 Ent
: Entity_Id
:= First_Entity
(From
);
6777 if (Last_Entity
(To
)) = Empty
then
6778 Set_First_Entity
(To
, Ent
);
6780 Set_Next_Entity
(Last_Entity
(To
), Ent
);
6783 Set_Last_Entity
(To
, Last_Entity
(From
));
6785 while Present
(Ent
) loop
6786 Set_Scope
(Ent
, To
);
6788 if not Is_Public
(Ent
) then
6789 Set_Public_Status
(Ent
);
6792 and then Ekind
(Ent
) = E_Record_Subtype
6795 -- The components of the propagated Itype must be public
6802 Comp
:= First_Entity
(Ent
);
6803 while Present
(Comp
) loop
6804 Set_Is_Public
(Comp
);
6814 Set_First_Entity
(From
, Empty
);
6815 Set_Last_Entity
(From
, Empty
);
6816 end Transfer_Entities
;
6818 -----------------------
6819 -- Type_Access_Level --
6820 -----------------------
6822 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
6826 -- If the type is an anonymous access type we treat it as being
6827 -- declared at the library level to ensure that names such as
6828 -- X.all'access don't fail static accessibility checks.
6830 -- Ada 2005 (AI-230): In case of anonymous access types that are
6831 -- component_definition or discriminants of a nonlimited type,
6832 -- the level is the same as that of the enclosing component type.
6834 Btyp
:= Base_Type
(Typ
);
6836 if Ekind
(Btyp
) in Access_Kind
then
6837 if Ekind
(Btyp
) = E_Anonymous_Access_Type
6838 and then not Is_Local_Anonymous_Access
(Typ
) -- Ada 2005 (AI-230)
6840 return Scope_Depth
(Standard_Standard
);
6843 Btyp
:= Root_Type
(Btyp
);
6845 -- The accessibility level of anonymous acccess types associated with
6846 -- discriminants is that of the current instance of the type, and
6847 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
6849 if Ekind
(Typ
) = E_Anonymous_Access_Type
6850 and then Present
(Associated_Node_For_Itype
(Typ
))
6851 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
6852 N_Discriminant_Specification
6854 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
6858 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
6859 end Type_Access_Level
;
6861 --------------------------
6862 -- Unit_Declaration_Node --
6863 --------------------------
6865 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
6866 N
: Node_Id
:= Parent
(Unit_Id
);
6869 -- Predefined operators do not have a full function declaration
6871 if Ekind
(Unit_Id
) = E_Operator
then
6875 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
6876 and then Nkind
(N
) /= N_Formal_Package_Declaration
6877 and then Nkind
(N
) /= N_Function_Instantiation
6878 and then Nkind
(N
) /= N_Generic_Package_Declaration
6879 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
6880 and then Nkind
(N
) /= N_Package_Declaration
6881 and then Nkind
(N
) /= N_Package_Body
6882 and then Nkind
(N
) /= N_Package_Instantiation
6883 and then Nkind
(N
) /= N_Package_Renaming_Declaration
6884 and then Nkind
(N
) /= N_Procedure_Instantiation
6885 and then Nkind
(N
) /= N_Protected_Body
6886 and then Nkind
(N
) /= N_Subprogram_Declaration
6887 and then Nkind
(N
) /= N_Subprogram_Body
6888 and then Nkind
(N
) /= N_Subprogram_Body_Stub
6889 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
6890 and then Nkind
(N
) /= N_Task_Body
6891 and then Nkind
(N
) /= N_Task_Type_Declaration
6892 and then Nkind
(N
) not in N_Formal_Subprogram_Declaration
6893 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
6896 pragma Assert
(Present
(N
));
6900 end Unit_Declaration_Node
;
6902 ------------------------------
6903 -- Universal_Interpretation --
6904 ------------------------------
6906 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
6907 Index
: Interp_Index
;
6911 -- The argument may be a formal parameter of an operator or subprogram
6912 -- with multiple interpretations, or else an expression for an actual.
6914 if Nkind
(Opnd
) = N_Defining_Identifier
6915 or else not Is_Overloaded
(Opnd
)
6917 if Etype
(Opnd
) = Universal_Integer
6918 or else Etype
(Opnd
) = Universal_Real
6920 return Etype
(Opnd
);
6926 Get_First_Interp
(Opnd
, Index
, It
);
6927 while Present
(It
.Typ
) loop
6928 if It
.Typ
= Universal_Integer
6929 or else It
.Typ
= Universal_Real
6934 Get_Next_Interp
(Index
, It
);
6939 end Universal_Interpretation
;
6941 ----------------------
6942 -- Within_Init_Proc --
6943 ----------------------
6945 function Within_Init_Proc
return Boolean is
6950 while not Is_Overloadable
(S
) loop
6951 if S
= Standard_Standard
then
6958 return Is_Init_Proc
(S
);
6959 end Within_Init_Proc
;
6965 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
6966 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
6967 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
6969 function Has_One_Matching_Field
return Boolean;
6970 -- Determines if Expec_Type is a record type with a single component or
6971 -- discriminant whose type matches the found type or is one dimensional
6972 -- array whose component type matches the found type.
6974 ----------------------------
6975 -- Has_One_Matching_Field --
6976 ----------------------------
6978 function Has_One_Matching_Field
return Boolean is
6982 if Is_Array_Type
(Expec_Type
)
6983 and then Number_Dimensions
(Expec_Type
) = 1
6985 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
6989 elsif not Is_Record_Type
(Expec_Type
) then
6993 E
:= First_Entity
(Expec_Type
);
6998 elsif (Ekind
(E
) /= E_Discriminant
6999 and then Ekind
(E
) /= E_Component
)
7000 or else (Chars
(E
) = Name_uTag
7001 or else Chars
(E
) = Name_uParent
)
7010 if not Covers
(Etype
(E
), Found_Type
) then
7013 elsif Present
(Next_Entity
(E
)) then
7020 end Has_One_Matching_Field
;
7022 -- Start of processing for Wrong_Type
7025 -- Don't output message if either type is Any_Type, or if a message
7026 -- has already been posted for this node. We need to do the latter
7027 -- check explicitly (it is ordinarily done in Errout), because we
7028 -- are using ! to force the output of the error messages.
7030 if Expec_Type
= Any_Type
7031 or else Found_Type
= Any_Type
7032 or else Error_Posted
(Expr
)
7036 -- In an instance, there is an ongoing problem with completion of
7037 -- type derived from private types. Their structure is what Gigi
7038 -- expects, but the Etype is the parent type rather than the
7039 -- derived private type itself. Do not flag error in this case. The
7040 -- private completion is an entity without a parent, like an Itype.
7041 -- Similarly, full and partial views may be incorrect in the instance.
7042 -- There is no simple way to insure that it is consistent ???
7044 elsif In_Instance
then
7046 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
7048 (Has_Private_Declaration
(Expected_Type
)
7049 or else Has_Private_Declaration
(Etype
(Expr
)))
7050 and then No
(Parent
(Expected_Type
))
7056 -- An interesting special check. If the expression is parenthesized
7057 -- and its type corresponds to the type of the sole component of the
7058 -- expected record type, or to the component type of the expected one
7059 -- dimensional array type, then assume we have a bad aggregate attempt.
7061 if Nkind
(Expr
) in N_Subexpr
7062 and then Paren_Count
(Expr
) /= 0
7063 and then Has_One_Matching_Field
7065 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
7067 -- Another special check, if we are looking for a pool-specific access
7068 -- type and we found an E_Access_Attribute_Type, then we have the case
7069 -- of an Access attribute being used in a context which needs a pool-
7070 -- specific type, which is never allowed. The one extra check we make
7071 -- is that the expected designated type covers the Found_Type.
7073 elsif Is_Access_Type
(Expec_Type
)
7074 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
7075 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
7076 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
7078 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
7080 Error_Msg_N
("result must be general access type!", Expr
);
7081 Error_Msg_NE
("add ALL to }!", Expr
, Expec_Type
);
7083 -- If the expected type is an anonymous access type, as for access
7084 -- parameters and discriminants, the error is on the designated types.
7086 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
7087 if Comes_From_Source
(Expec_Type
) then
7088 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
7091 ("expected an access type with designated}",
7092 Expr
, Designated_Type
(Expec_Type
));
7095 if Is_Access_Type
(Found_Type
)
7096 and then not Comes_From_Source
(Found_Type
)
7099 ("found an access type with designated}!",
7100 Expr
, Designated_Type
(Found_Type
));
7102 if From_With_Type
(Found_Type
) then
7103 Error_Msg_NE
("found incomplete}!", Expr
, Found_Type
);
7105 ("\possibly missing with_clause on&", Expr
,
7106 Scope
(Found_Type
));
7108 Error_Msg_NE
("found}!", Expr
, Found_Type
);
7112 -- Normal case of one type found, some other type expected
7115 -- If the names of the two types are the same, see if some
7116 -- number of levels of qualification will help. Don't try
7117 -- more than three levels, and if we get to standard, it's
7118 -- no use (and probably represents an error in the compiler)
7119 -- Also do not bother with internal scope names.
7122 Expec_Scope
: Entity_Id
;
7123 Found_Scope
: Entity_Id
;
7126 Expec_Scope
:= Expec_Type
;
7127 Found_Scope
:= Found_Type
;
7129 for Levels
in Int
range 0 .. 3 loop
7130 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
7131 Error_Msg_Qual_Level
:= Levels
;
7135 Expec_Scope
:= Scope
(Expec_Scope
);
7136 Found_Scope
:= Scope
(Found_Scope
);
7138 exit when Expec_Scope
= Standard_Standard
7139 or else Found_Scope
= Standard_Standard
7140 or else not Comes_From_Source
(Expec_Scope
)
7141 or else not Comes_From_Source
(Found_Scope
);
7145 if Is_Record_Type
(Expec_Type
)
7146 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
7148 Error_Msg_NE
("expected}!", Expr
,
7149 Corresponding_Remote_Type
(Expec_Type
));
7151 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
7154 if Is_Entity_Name
(Expr
)
7155 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
7157 Error_Msg_N
("found package name!", Expr
);
7159 elsif Is_Entity_Name
(Expr
)
7161 (Ekind
(Entity
(Expr
)) = E_Procedure
7163 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
7165 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
7167 ("found procedure name, possibly missing Access attribute!",
7170 Error_Msg_N
("found procedure name instead of function!", Expr
);
7173 elsif Nkind
(Expr
) = N_Function_Call
7174 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
7175 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
7176 and then No
(Parameter_Associations
(Expr
))
7179 ("found function name, possibly missing Access attribute!",
7182 -- Catch common error: a prefix or infix operator which is not
7183 -- directly visible because the type isn't.
7185 elsif Nkind
(Expr
) in N_Op
7186 and then Is_Overloaded
(Expr
)
7187 and then not Is_Immediately_Visible
(Expec_Type
)
7188 and then not Is_Potentially_Use_Visible
(Expec_Type
)
7189 and then not In_Use
(Expec_Type
)
7190 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
7193 ("operator of the type is not directly visible!", Expr
);
7195 elsif Ekind
(Found_Type
) = E_Void
7196 and then Present
(Parent
(Found_Type
))
7197 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
7199 Error_Msg_NE
("found premature usage of}!", Expr
, Found_Type
);
7202 Error_Msg_NE
("found}!", Expr
, Found_Type
);
7205 Error_Msg_Qual_Level
:= 0;